summaryrefslogtreecommitdiffstats
path: root/RISCOS/config.h
Commit message (Expand)AuthorAgeFilesLines
* RISCOS files by dschwertbergerGuido van Rossum2001-03-021-0/+488
generated by cgit v0.12 at 2025-12-26 23:57:31 (GMT)
omMathStubLib.o tclOOStubLib.o ${COMPAT_OBJS} +STUB_LIB_OBJS = tclStubLib.o tclStubLibTbl.o tclStubLibDl.o tclTomMathStubLib.o tclOOStubLib.o ${COMPAT_OBJS} UNIX_OBJS = tclUnixChan.o tclUnixEvent.o tclUnixFCmd.o \ tclUnixFile.o tclUnixPipe.o tclUnixSock.o \ @@ -471,6 +471,7 @@ OO_SRCS = \ STUB_SRCS = \ $(GENERIC_DIR)/tclStubLib.c \ $(GENERIC_DIR)/tclStubLibTbl.c \ + $(GENERIC_DIR)/tclStubLibDl.c \ $(GENERIC_DIR)/tclTomMathStubLib.c \ $(GENERIC_DIR)/tclOOStubLib.c @@ -1689,6 +1690,9 @@ tclStubLib.o: $(GENERIC_DIR)/tclStubLib.c tclStubLibTbl.o: $(GENERIC_DIR)/tclStubLibTbl.c $(CC) -c $(STUB_CC_SWITCHES) $(GENERIC_DIR)/tclStubLibTbl.c +tclStubLibDl.o: $(GENERIC_DIR)/tclStubLibDl.c + $(CC) -c $(STUB_CC_SWITCHES) -DTCL_LIB_FILE="\"$(TCL_LIB_FILE)\"" $(GENERIC_DIR)/tclStubLibDl.c + tclTomMathStubLib.o: $(GENERIC_DIR)/tclTomMathStubLib.c $(CC) -c $(STUB_CC_SWITCHES) $(GENERIC_DIR)/tclTomMathStubLib.c diff --git a/win/Makefile.in b/win/Makefile.in index d7b25b7..986b517 100644 --- a/win/Makefile.in +++ b/win/Makefile.in @@ -386,6 +386,7 @@ REG_OBJS = tclWinReg.$(OBJEXT) STUB_OBJS = \ tclStubLib.$(OBJEXT) \ tclStubLibTbl.$(OBJEXT) \ + tclStubLibDl.$(OBJEXT) \ tclTomMathStubLib.$(OBJEXT) \ tclOOStubLib.$(OBJEXT) @@ -519,6 +520,9 @@ tclStubLib.${OBJEXT}: tclStubLib.c tclStubLibTbl.${OBJEXT}: tclStubLibTbl.c $(CC) -c $(CC_SWITCHES) -DSTATIC_BUILD @DEPARG@ $(CC_OBJNAME) +tclStubLibDl.${OBJEXT}: tclStubLibDl.c + $(CC) -c $(CC_SWITCHES) -DSTATIC_BUILD -DTCL_LIB_FILE="\"$(TCL_LIB_FILE)\"" @DEPARG@ $(CC_OBJNAME) + tclTomMathStubLib.${OBJEXT}: tclTomMathStubLib.c $(CC) -c $(CC_SWITCHES) -DSTATIC_BUILD @DEPARG@ $(CC_OBJNAME) diff --git a/win/makefile.bc b/win/makefile.bc index 2726dad..0315c98 100644 --- a/win/makefile.bc +++ b/win/makefile.bc @@ -280,6 +280,7 @@ TCLOBJS = \ TCLSTUBOBJS = \ $(TMPDIR)\tclStubLib.obj \ $(TMPDIR)\tclStubLibTbl.obj \ + $(TMPDIR)\tclStubLibDl.obj \ $(TMPDIR)\tclTomMathStubLib.obj \ $(TMPDIR)\tclOOStubLib.obj @@ -532,6 +533,9 @@ $(TMPDIR)\tclStubLib.obj : $(GENERICDIR)\tclStubLib.c $(TMPDIR)\tclStubLibTbl.obj : $(GENERICDIR)\tclStubLibTbl.c $(cc32) $(TCL_CFLAGS) -DSTATIC_BUILD -o$(TMPDIR)\$@ $? +$(TMPDIR)\tclStubLibDl.obj : $(GENERICDIR)\tclStubLibDl.c + $(cc32) $(TCL_CFLAGS) -DSTATIC_BUILD -o$(TMPDIR)\$@ $? + $(TMPDIR)\tclTomMathStubLib.obj : $(GENERICDIR)\tclTomMathStubLib.c $(cc32) $(TCL_CFLAGS) -DSTATIC_BUILD -o$(TMPDIR)\$@ $? diff --git a/win/makefile.vc b/win/makefile.vc index c24534a..cf61bbf 100644 --- a/win/makefile.vc +++ b/win/makefile.vc @@ -451,6 +451,7 @@ TCLOBJS = $(COREOBJS) $(ZLIBOBJS) $(TOMMATHOBJS) $(PLATFORMOBJS) TCLSTUBOBJS = \ $(TMP_DIR)\tclStubLib.obj \ $(TMP_DIR)\tclStubLibTbl.obj \ + $(TMP_DIR)\tclStubLibDl.obj \ $(TMP_DIR)\tclTomMathStubLib.obj \ $(TMP_DIR)\tclOOStubLib.obj @@ -983,6 +984,9 @@ $(TMP_DIR)\tclStubLib.obj: $(GENERICDIR)\tclStubLib.c $(TMP_DIR)\tclStubLibTbl.obj: $(GENERICDIR)\tclStubLibTbl.c $(cc32) $(STUB_CFLAGS) -Zl -DSTATIC_BUILD $(TCL_INCLUDES) -Fo$@ $? +$(TMP_DIR)\tclStubLibDl.obj: $(GENERICDIR)\tclStubLibDl.c + $(cc32) $(STUB_CFLAGS) -Zl -DSTATIC_BUILD $(TCL_INCLUDES) -Fo$@ $? + $(TMP_DIR)\tclTomMathStubLib.obj: $(GENERICDIR)\tclTomMathStubLib.c $(cc32) $(STUB_CFLAGS) -Zl -DSTATIC_BUILD $(TCL_INCLUDES) -Fo$@ $? diff --git a/win/tcl.dsp b/win/tcl.dsp index 2708051..afe1960 100644 --- a/win/tcl.dsp +++ b/win/tcl.dsp @@ -1304,6 +1304,10 @@ SOURCE=..\generic\tclStubLibTbl.c # End Source File # Begin Source File +SOURCE=..\generic\tclStubLibDl.c +# End Source File +# Begin Source File + SOURCE=..\generic\tclOOStubLib.c # End Source File # Begin Source File -- cgit v0.12 From f44c65ff893ab9fe381cbd0556fe81c35d09c6fa Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 24 Sep 2015 14:43:22 +0000 Subject: Minor simplification and correct TCL_NORETURN decoration --- generic/tclStubLibDl.c | 15 ++++----------- 1 file changed, 4 insertions(+), 11 deletions(-) diff --git a/generic/tclStubLibDl.c b/generic/tclStubLibDl.c index bae2e64..2e09659 100644 --- a/generic/tclStubLibDl.c +++ b/generic/tclStubLibDl.c @@ -46,7 +46,7 @@ Tcl_InitSubsystems( const char *(*initSubsystems)(TCL_NORETURN1 Tcl_PanicProc *); int a,b,c,d; - if (!info.version[0]) { + if (!info.stubs) { void *handle = dlopen(TCL_DLL_FILE, RTLD_NOW|RTLD_LOCAL); if (!handle) { handle = dlopen(TCL_PREV_DLL_FILE, RTLD_NOW|RTLD_LOCAL); @@ -67,12 +67,11 @@ Tcl_InitSubsystems( if (initSubsystems) { /* If the core has TIP #414, use it. */ const char *version = initSubsystems(panicProc); + strcpy(info.version, version); info.stubs = ((const TclStubs **)version)[-1]; - strcpy(info.version+1, version+1); - info.version[0] = version[0]; } else { const TclStubs *stubs; - const char *(*setPanicProc)(Tcl_PanicProc *); + const char *(*setPanicProc)(TCL_NORETURN1 Tcl_PanicProc *); Tcl_Interp *interp, *(*createInterp)(void); setPanicProc = dlsym(handle, "Tcl_SetPanicProc"); @@ -88,14 +87,8 @@ Tcl_InitSubsystems( stubs = ((Interp *) interp)->stubTable; stubs->tcl_DeleteInterp(interp); stubs->tcl_GetVersion(&a, &b, &c, &d); + sprintf(info.version, "%d.%d%c%d", a, b, "ab."[d], c); info.stubs = stubs; - if (a>9) { - sprintf(info.version+1, "%d.%d%c%d", a%10, b, "ab."[d], c); - info.version[0] = '0' + (a/10); - } else { - sprintf(info.version+1, ".%d%c%d", b, "ab."[d], c); - info.version[0] = '0' + a; - } } } return info.version; -- cgit v0.12 From 8a04fcf1ecb00bae11f6d1e7a4482a61a33230b0 Mon Sep 17 00:00:00 2001 From: dgp Date: Mon, 5 Dec 2016 19:17:52 +0000 Subject: WIP trial of proper bytearrays in Tcl 9. --- generic/tclBinary.c | 21 +++++++++++++++------ 1 file changed, 15 insertions(+), 6 deletions(-) diff --git a/generic/tclBinary.c b/generic/tclBinary.c index 5c5e86d..4074596 100644 --- a/generic/tclBinary.c +++ b/generic/tclBinary.c @@ -452,7 +452,9 @@ Tcl_GetByteArrayFromObj( if ((objPtr->typePtr != &properByteArrayType) && (objPtr->typePtr != &tclByteArrayType)) { - SetByteArrayFromAny(NULL, objPtr); + if (TCL_ERROR == SetByteArrayFromAny(NULL, objPtr)) { + return NULL; + } } baPtr = GET_BYTEARRAY(objPtr); @@ -496,7 +498,9 @@ Tcl_SetByteArrayLength( } if ((objPtr->typePtr != &properByteArrayType) && (objPtr->typePtr != &tclByteArrayType)) { - SetByteArrayFromAny(NULL, objPtr); + if (TCL_ERROR == SetByteArrayFromAny(NULL, objPtr)) { + return NULL; + } } byteArrayPtr = GET_BYTEARRAY(objPtr); @@ -531,7 +535,7 @@ SetByteArrayFromAny( Tcl_Interp *interp, /* Not used. */ Tcl_Obj *objPtr) /* The object to convert to type ByteArray. */ { - int length, improper = 0; + int length; const char *src, *srcEnd; unsigned char *dst; ByteArray *byteArrayPtr; @@ -550,7 +554,10 @@ SetByteArrayFromAny( byteArrayPtr = ckalloc(BYTEARRAY_SIZE(length)); for (dst = byteArrayPtr->bytes; src < srcEnd; ) { src += Tcl_UtfToUniChar(src, &ch); - improper = improper || (ch > 255); + if (ch > 255) { + ckfree(byteArrayPtr); + return TCL_ERROR; + } *dst++ = UCHAR(ch); } @@ -558,7 +565,7 @@ SetByteArrayFromAny( byteArrayPtr->allocated = length; TclFreeIntRep(objPtr); - objPtr->typePtr = improper ? &tclByteArrayType : &properByteArrayType; + objPtr->typePtr = &properByteArrayType; SET_BYTEARRAY(objPtr, byteArrayPtr); return TCL_OK; } @@ -731,7 +738,9 @@ TclAppendBytesToByteArray( } if ((objPtr->typePtr != &properByteArrayType) && (objPtr->typePtr != &tclByteArrayType)) { - SetByteArrayFromAny(NULL, objPtr); + if (TCL_ERROR == SetByteArrayFromAny(NULL, objPtr)) { + Tcl_Panic("attempt to append bytes to non-bytearray"); + } } byteArrayPtr = GET_BYTEARRAY(objPtr); -- cgit v0.12 From dcd49ec1ee202c50fa9921cabd1b716ae0c159fe Mon Sep 17 00:00:00 2001 From: dgp Date: Tue, 6 Dec 2016 18:55:28 +0000 Subject: Several commands should be picky about expecting byte-valued arguments. Make them so. --- generic/tclBinary.c | 31 ++++++++++++++++++++++++++++--- generic/tclCmdAH.c | 6 ++++++ generic/tclTest.c | 4 ++++ tests/utf.test | 4 ++-- 4 files changed, 40 insertions(+), 5 deletions(-) diff --git a/generic/tclBinary.c b/generic/tclBinary.c index 4074596..350105a 100644 --- a/generic/tclBinary.c +++ b/generic/tclBinary.c @@ -453,6 +453,9 @@ Tcl_GetByteArrayFromObj( if ((objPtr->typePtr != &properByteArrayType) && (objPtr->typePtr != &tclByteArrayType)) { if (TCL_ERROR == SetByteArrayFromAny(NULL, objPtr)) { + if (lengthPtr != NULL) { + *lengthPtr = 0; + } return NULL; } } @@ -1370,9 +1373,13 @@ BinaryScanCmd( "value formatString ?varName ...?"); return TCL_ERROR; } + buffer = Tcl_GetByteArrayFromObj(objv[1], &length); + if (buffer == NULL) { + Tcl_AppendResult(interp, "binary scan expects bytes", NULL); + return TCL_ERROR; + } numberCachePtr = &numberCacheHash; Tcl_InitHashTable(numberCachePtr, TCL_ONE_WORD_KEYS); - buffer = Tcl_GetByteArrayFromObj(objv[1], &length); format = TclGetString(objv[2]); arg = 3; offset = 0; @@ -2411,8 +2418,13 @@ BinaryEncodeHex( return TCL_ERROR; } - TclNewObj(resultObj); data = Tcl_GetByteArrayFromObj(objv[1], &count); + if (data == NULL) { + Tcl_AppendResult(interp, "binary encode expects bytes", NULL); + return TCL_ERROR; + } + + TclNewObj(resultObj); cursor = Tcl_SetByteArrayLength(resultObj, count * 2); for (offset = 0; offset < count; ++offset) { *cursor++ = HexDigits[((data[offset] >> 4) & 0x0f)]; @@ -2605,8 +2617,12 @@ BinaryEncode64( } } - resultObj = Tcl_NewObj(); data = Tcl_GetByteArrayFromObj(objv[objc-1], &count); + if (data == NULL) { + Tcl_AppendResult(interp, "binary encode expects bytes", NULL); + return TCL_ERROR; + } + resultObj = Tcl_NewObj(); if (count > 0) { size = (((count * 4) / 3) + 3) & ~3; /* ensure 4 byte chunks */ if (maxlen > 0 && size > maxlen) { @@ -2705,6 +2721,11 @@ BinaryEncodeUu( break; case OPT_WRAPCHAR: wrapchar = Tcl_GetByteArrayFromObj(objv[i+1], &wrapcharlen); + if (wrapchar == NULL) { + Tcl_AppendResult(interp, + "binary encode -wrapchar expects bytes", NULL); + return TCL_ERROR; + } break; } } @@ -2717,6 +2738,10 @@ BinaryEncodeUu( resultObj = Tcl_NewObj(); offset = 0; data = Tcl_GetByteArrayFromObj(objv[objc-1], &count); + if (data == NULL) { + Tcl_AppendResult(interp, "binary encode expects bytes", NULL); + return TCL_ERROR; + } rawLength = (lineLength - 1) * 3 / 4; start = cursor = Tcl_SetByteArrayLength(resultObj, (lineLength + wrapcharlen) * diff --git a/generic/tclCmdAH.c b/generic/tclCmdAH.c index 0883a1d..9afc4f6 100644 --- a/generic/tclCmdAH.c +++ b/generic/tclCmdAH.c @@ -431,6 +431,12 @@ Tcl_EncodingObjCmd( */ stringPtr = (char *) Tcl_GetByteArrayFromObj(data, &length); + if (stringPtr == NULL) { + Tcl_AppendResult(interp, "encoding conversion expects bytes", + NULL); + Tcl_FreeEncoding(encoding); + return TCL_ERROR; + } Tcl_ExternalToUtfDString(encoding, stringPtr, length, &ds); /* diff --git a/generic/tclTest.c b/generic/tclTest.c index bc64594..d554c54 100644 --- a/generic/tclTest.c +++ b/generic/tclTest.c @@ -4847,6 +4847,10 @@ TestbytestringObjCmd( return TCL_ERROR; } p = (const char *)Tcl_GetByteArrayFromObj(objv[1], &n); + if (p == NULL) { + Tcl_AppendResult(interp, "testbytestring expects bytes", NULL); + return TCL_ERROR; + } Tcl_SetObjResult(interp, Tcl_NewStringObj(p, n)); return TCL_OK; } diff --git a/tests/utf.test b/tests/utf.test index a03dd6c..4a4c1d0 100644 --- a/tests/utf.test +++ b/tests/utf.test @@ -75,7 +75,7 @@ test utf-4.2 {Tcl_NumUtfChars: length 1} {testnumutfchars testbytestring} { testnumutfchars [testbytestring "\xC2\xA2"] } {1} test utf-4.3 {Tcl_NumUtfChars: long string} {testnumutfchars testbytestring} { - testnumutfchars [testbytestring "abc\xC2\xA2\xe4\xb9\x8e\uA2\u4e4e"] + testnumutfchars [testbytestring "abc\xC2\xA2\xe4\xb9\x8e\uA2\u4e"] } {7} test utf-4.4 {Tcl_NumUtfChars: #u0000} {testnumutfchars testbytestring} { testnumutfchars [testbytestring "\xC0\x80"] @@ -87,7 +87,7 @@ test utf-4.6 {Tcl_NumUtfChars: length 1, calc len} {testnumutfchars testbytestri testnumutfchars [testbytestring "\xC2\xA2"] 1 } {1} test utf-4.7 {Tcl_NumUtfChars: long string, calc len} {testnumutfchars testbytestring} { - testnumutfchars [testbytestring "abc\xC2\xA2\xe4\xb9\x8e\uA2\u4e4e"] 1 + testnumutfchars [testbytestring "abc\xC2\xA2\xe4\xb9\x8e\uA2\u4e"] 1 } {7} test utf-4.8 {Tcl_NumUtfChars: #u0000, calc len} {testnumutfchars testbytestring} { testnumutfchars [testbytestring "\xC0\x80"] 1 -- cgit v0.12 From 6cdaf31447fff194fce3985d881f5328e110a650 Mon Sep 17 00:00:00 2001 From: dgp Date: Tue, 6 Dec 2016 20:09:00 +0000 Subject: Purge the old and broken Tcl_ObjType. --- generic/tclBinary.c | 95 +++-------------------------------------------------- generic/tclInt.h | 1 - generic/tclObj.c | 1 - tests/execute.test | 2 +- tests/obj.test | 5 ++- 5 files changed, 8 insertions(+), 96 deletions(-) diff --git a/generic/tclBinary.c b/generic/tclBinary.c index 350105a..9175036 100644 --- a/generic/tclBinary.c +++ b/generic/tclBinary.c @@ -160,10 +160,6 @@ static const EnsembleImplMap decodeMap[] = { * without loss or damage. Such values are useful for things like * encoded strings or Tk images to name just two. * - * It's strange to have two Tcl_ObjTypes in place for this task when - * one would do, so a bit of detail and history how we got to this point - * and where we might go from here. - * * A bytearray is an ordered sequence of bytes. Each byte is an integer * value in the range [0-255]. To be a Tcl value type, we need a way to * encode each value in the value set as a Tcl string. The simplest @@ -173,75 +169,8 @@ static const EnsembleImplMap decodeMap[] = { * This approach creates a one-to-one map between all bytearray values * and a subset of Tcl string values. * - * When converting a Tcl string value to the bytearray internal rep, the - * question arises what to do with strings outside that subset? That is, - * those Tcl strings containing at least one codepoint greater than 255? - * The obviously correct answer is to raise an error! That string value - * does not represent any valid bytearray value. Full Stop. The - * setFromAnyProc signature has a completion code return value for just - * this reason, to reject invalid inputs. - * - * Unfortunately this was not the path taken by the authors of the - * original tclByteArrayType. They chose to accept all Tcl string values - * as acceptable string encodings of the bytearray values that result - * from masking away the high bits of any codepoint value at all. This - * meant that every bytearray value had multiple accepted string - * representations. - * - * The implications of this choice are truly ugly. When a Tcl value has - * a string representation, we are required to accept that as the true - * value. Bytearray values that possess a string representation cannot - * be processed as bytearrays because we cannot know which true value - * that bytearray represents. The consequence is that we drag around - * an internal rep that we cannot make any use of. This painful price - * is extracted at any point after a string rep happens to be generated - * for the value. This happens even when the troublesome codepoints - * outside the byte range never show up. This happens rather routinely - * in normal Tcl operations unless we burden the script writer with the - * cognitive burden of avoiding it. The price is also paid by callers - * of the C interface. The routine - * - * unsigned char *Tcl_GetByteArrayFromObj(objPtr, lenPtr) - * - * has a guarantee to always return a non-NULL value, but that value - * points to a byte sequence that cannot be used by the caller to - * process the Tcl value absent some sideband testing that objPtr - * is "pure". Tcl offers no public interface to perform this test, - * so callers either break encapsulation or are unavoidably buggy. Tcl - * has defined a public interface that cannot be used correctly. The - * Tcl source code itself suffers the same problem, and has been buggy, - * but progressively less so as more and more portions of the code have - * been retrofitted with the required "purity testing". The set of values - * able to pass the purity test can be increased via the introduction of - * a "canonical" flag marker, but the only way the broken interface itself - * can be discarded is to start over and define the Tcl_ObjType properly. - * Bytearrays should simply be usable as bytearrays without a kabuki - * dance of testing. - * - * The Tcl_ObjType "properByteArrayType" is (nearly) a correct - * implementation of bytearrays. Any Tcl value with the type - * properByteArrayType can have its bytearray value fetched and - * used with confidence that acting on that value is equivalent to - * acting on the true Tcl string value. This still implies a side - * testing burden -- past mistakes will not let us avoid that - * immediately, but it is at least a conventional test of type, and - * can be implemented entirely by examining the objPtr fields, with - * no need to query the intrep, as a canonical flag would require. - * - * Until Tcl_GetByteArrayFromObj() and Tcl_SetByteArrayLength() can - * be revised to admit the possibility of returning NULL when the true - * value is not a valid bytearray, we need a mechanism to retain - * compatibility with the deployed callers of the broken interface. - * That's what the retained "tclByteArrayType" provides. In those - * unusual circumstances where we convert an invalid bytearray value - * to a bytearray type, it is to this legacy type. Essentially any - * time this legacy type gets used, it's a signal of a bug being ignored. - * A TIP should be drafted to remove this connection to the broken past - * so that Tcl 9 will no longer have any trace of it. Prescribing a - * migration path will be the key element of that work. The internal - * changes now in place are the limit of what can be done short of - * interface repair. They provide a great expansion of the histories - * over which bytearray values can be useful in the meanwhile. + * When converting a Tcl string value to the bytearray internal rep, and + * the string value is outside that subset, an error is raised. */ static const Tcl_ObjType properByteArrayType = { @@ -252,14 +181,6 @@ static const Tcl_ObjType properByteArrayType = { NULL }; -const Tcl_ObjType tclByteArrayType = { - "bytearray", - FreeByteArrayInternalRep, - DupByteArrayInternalRep, - NULL, - SetByteArrayFromAny -}; - /* * The following structure is the internal rep for a ByteArray object. Keeps * track of how much memory has been used and how much has been allocated for @@ -450,8 +371,7 @@ Tcl_GetByteArrayFromObj( { ByteArray *baPtr; - if ((objPtr->typePtr != &properByteArrayType) - && (objPtr->typePtr != &tclByteArrayType)) { + if (objPtr->typePtr != &properByteArrayType) { if (TCL_ERROR == SetByteArrayFromAny(NULL, objPtr)) { if (lengthPtr != NULL) { *lengthPtr = 0; @@ -499,8 +419,7 @@ Tcl_SetByteArrayLength( if (Tcl_IsShared(objPtr)) { Tcl_Panic("%s called with shared object", "Tcl_SetByteArrayLength"); } - if ((objPtr->typePtr != &properByteArrayType) - && (objPtr->typePtr != &tclByteArrayType)) { + if (objPtr->typePtr != &properByteArrayType) { if (TCL_ERROR == SetByteArrayFromAny(NULL, objPtr)) { return NULL; } @@ -547,9 +466,6 @@ SetByteArrayFromAny( if (objPtr->typePtr == &properByteArrayType) { return TCL_OK; } - if (objPtr->typePtr == &tclByteArrayType) { - return TCL_OK; - } src = TclGetStringFromObj(objPtr, &length); srcEnd = src + length; @@ -739,8 +655,7 @@ TclAppendBytesToByteArray( /* Append zero bytes is a no-op. */ return; } - if ((objPtr->typePtr != &properByteArrayType) - && (objPtr->typePtr != &tclByteArrayType)) { + if (objPtr->typePtr != &properByteArrayType) { if (TCL_ERROR == SetByteArrayFromAny(NULL, objPtr)) { Tcl_Panic("attempt to append bytes to non-bytearray"); } diff --git a/generic/tclInt.h b/generic/tclInt.h index b36f004..253a2f0 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -2644,7 +2644,6 @@ MODULE_SCOPE ClientData tclTimeClientData; MODULE_SCOPE const Tcl_ObjType tclBignumType; MODULE_SCOPE const Tcl_ObjType tclBooleanType; -MODULE_SCOPE const Tcl_ObjType tclByteArrayType; MODULE_SCOPE const Tcl_ObjType tclByteCodeType; MODULE_SCOPE const Tcl_ObjType tclDoubleType; MODULE_SCOPE const Tcl_ObjType tclEndOffsetType; diff --git a/generic/tclObj.c b/generic/tclObj.c index 6a1d925..6b2793e 100644 --- a/generic/tclObj.c +++ b/generic/tclObj.c @@ -394,7 +394,6 @@ TclInitObjSubsystem(void) Tcl_InitHashTable(&typeTable, TCL_STRING_KEYS); Tcl_MutexUnlock(&tableMutex); - Tcl_RegisterObjType(&tclByteArrayType); Tcl_RegisterObjType(&tclDoubleType); Tcl_RegisterObjType(&tclEndOffsetType); Tcl_RegisterObjType(&tclIntType); diff --git a/tests/execute.test b/tests/execute.test index 2480a95..2d6bda2 100644 --- a/tests/execute.test +++ b/tests/execute.test @@ -993,7 +993,7 @@ test execute-9.1 {Interp result resetting [Bug 1522803]} { } SUCCESS test execute-10.1 {TclExecuteByteCode, INST_CONCAT1, bytearrays} { - apply {s {binary scan $s c x; list $x [scan $s$s %c%c]}} \u0130 + apply {s {binary scan [binary format a $s] c x; list $x [scan $s$s %c%c]}} \u0130 } {48 {304 304}} test execute-10.2 {Bug 2802881} -setup { interp create slave diff --git a/tests/obj.test b/tests/obj.test index 4d57c08..ce1883a 100644 --- a/tests/obj.test +++ b/tests/obj.test @@ -27,7 +27,6 @@ test obj-1.1 {Tcl_AppendAllObjTypes, and InitTypeTable, Tcl_RegisterObjType} tes set r 1 foreach {t} { {array search} - bytearray bytecode cmdName dict @@ -48,10 +47,10 @@ test obj-2.2 {Tcl_GetObjType and Tcl_ConvertToType} testobj { set result "" lappend result [testobj freeallvars] lappend result [testintobj set 1 12] - lappend result [testobj convert 1 bytearray] + lappend result [testobj convert 1 string] lappend result [testobj type 1] lappend result [testobj refcount 1] -} {{} 12 12 bytearray 3} +} {{} 12 12 string 3} test obj-3.1 {Tcl_ConvertToType error} testobj { list [testdoubleobj set 1 12.34] \ -- cgit v0.12 From 09a75041cf1f96850fad5020b35c1b5fb59579c6 Mon Sep 17 00:00:00 2001 From: dgp Date: Wed, 7 Dec 2016 18:57:34 +0000 Subject: Create a narrowing procedure to make the operation explicit when needed. --- generic/tclBinary.c | 68 +++++++++++++++++++++++++++++++++++++++------------- generic/tclDictObj.c | 3 ++- generic/tclInt.h | 1 + 3 files changed, 54 insertions(+), 18 deletions(-) diff --git a/generic/tclBinary.c b/generic/tclBinary.c index 9175036..bcba677 100644 --- a/generic/tclBinary.c +++ b/generic/tclBinary.c @@ -453,36 +453,70 @@ Tcl_SetByteArrayLength( */ static int -SetByteArrayFromAny( - Tcl_Interp *interp, /* Not used. */ - Tcl_Obj *objPtr) /* The object to convert to type ByteArray. */ +MakeByteArray( + Tcl_Obj *objPtr, + int earlyOut, + ByteArray **byteArrayPtrPtr) { - int length; - const char *src, *srcEnd; + int length, proper = 1; unsigned char *dst; - ByteArray *byteArrayPtr; - Tcl_UniChar ch; - - if (objPtr->typePtr == &properByteArrayType) { - return TCL_OK; - } - - src = TclGetStringFromObj(objPtr, &length); - srcEnd = src + length; + const char *src = TclGetStringFromObj(objPtr, &length); + ByteArray *byteArrayPtr = ckalloc(BYTEARRAY_SIZE(length)); + const char *srcEnd = src + length; - byteArrayPtr = ckalloc(BYTEARRAY_SIZE(length)); for (dst = byteArrayPtr->bytes; src < srcEnd; ) { + Tcl_UniChar ch; + src += Tcl_UtfToUniChar(src, &ch); if (ch > 255) { + proper = 0; + if (earlyOut) { ckfree(byteArrayPtr); - return TCL_ERROR; + *byteArrayPtrPtr = NULL; + return proper; + } } *dst++ = UCHAR(ch); } - byteArrayPtr->used = dst - byteArrayPtr->bytes; byteArrayPtr->allocated = length; + *byteArrayPtrPtr = byteArrayPtr; + return proper; +} + +Tcl_Obj * +TclNarrowToBytes( + Tcl_Obj *objPtr) +{ + ByteArray *byteArrayPtr; + + if (0 == MakeByteArray(objPtr, 0, &byteArrayPtr)) { + objPtr = Tcl_NewObj(); + TclInvalidateStringRep(objPtr); + } + TclFreeIntRep(objPtr); + objPtr->typePtr = &properByteArrayType; + SET_BYTEARRAY(objPtr, byteArrayPtr); + Tcl_IncrRefCount(objPtr); + return objPtr; +} + +static int +SetByteArrayFromAny( + Tcl_Interp *interp, /* Not used. */ + Tcl_Obj *objPtr) /* The object to convert to type ByteArray. */ +{ + ByteArray *byteArrayPtr; + + if (objPtr->typePtr == &properByteArrayType) { + return TCL_OK; + } + + if (0 == MakeByteArray(objPtr, 1, &byteArrayPtr)) { + return TCL_ERROR; + } + TclFreeIntRep(objPtr); objPtr->typePtr = &properByteArrayType; SET_BYTEARRAY(objPtr, byteArrayPtr); diff --git a/generic/tclDictObj.c b/generic/tclDictObj.c index 29ab973..3bb2d63 100644 --- a/generic/tclDictObj.c +++ b/generic/tclDictObj.c @@ -492,7 +492,8 @@ UpdateStringOfDict( Dict *dict = DICT(dictPtr); ChainEntry *cPtr; Tcl_Obj *keyPtr, *valuePtr; - size_t i, length, bytesNeeded = 0; + size_t i, length; + int bytesNeeded = 0; const char *elem; char *dst; diff --git a/generic/tclInt.h b/generic/tclInt.h index 253a2f0..4bbaa5c 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -2969,6 +2969,7 @@ MODULE_SCOPE int TclMaxListLength(const char *bytes, int numBytes, MODULE_SCOPE int TclMergeReturnOptions(Tcl_Interp *interp, int objc, Tcl_Obj *const objv[], Tcl_Obj **optionsPtrPtr, int *codePtr, int *levelPtr); +MODULE_SCOPE Tcl_Obj * TclNarrowToBytes(Tcl_Obj *objPtr); MODULE_SCOPE Tcl_Obj * TclNoErrorStack(Tcl_Interp *interp, Tcl_Obj *options); MODULE_SCOPE int TclNokia770Doubles(void); MODULE_SCOPE void TclNsDecrRefCount(Namespace *nsPtr); -- cgit v0.12 From 5f5f3e9be3ff39cf49acb9cd35ab85cae1dbe112 Mon Sep 17 00:00:00 2001 From: dgp Date: Wed, 7 Dec 2016 19:22:33 +0000 Subject: Make explicit the implicit byte-narrowing function of [binary format]. --- generic/tclBinary.c | 8 ++++++-- 1 file changed, 6 insertions(+), 2 deletions(-) diff --git a/generic/tclBinary.c b/generic/tclBinary.c index bcba677..92a9c7f 100644 --- a/generic/tclBinary.c +++ b/generic/tclBinary.c @@ -847,7 +847,9 @@ BinaryFormatCmd( goto badIndex; } if (count == BINARY_ALL) { - Tcl_GetByteArrayFromObj(objv[arg], &count); + Tcl_Obj *copy = TclNarrowToBytes(objv[arg]); + Tcl_GetByteArrayFromObj(copy, &count); + Tcl_DecrRefCount(copy); } else if (count == BINARY_NOCOUNT) { count = 1; } @@ -1010,8 +1012,9 @@ BinaryFormatCmd( case 'A': { char pad = (char) (cmd == 'a' ? '\0' : ' '); unsigned char *bytes; + Tcl_Obj *copy = TclNarrowToBytes(objv[arg++]); - bytes = Tcl_GetByteArrayFromObj(objv[arg++], &length); + bytes = Tcl_GetByteArrayFromObj(copy, &length); if (count == BINARY_ALL) { count = length; @@ -1025,6 +1028,7 @@ BinaryFormatCmd( memset(cursor + length, pad, (size_t) (count - length)); } cursor += count; + Tcl_DecrRefCount(copy); break; } case 'b': -- cgit v0.12 From 3c3a7d5a94f2d6f7a209f4af01b0855a3cb9a2f1 Mon Sep 17 00:00:00 2001 From: dgp Date: Wed, 7 Dec 2016 19:52:37 +0000 Subject: Put explicit byte-narrowing in the write pipeline of -encoding binary channels. This makes tests pass again. I don't much like it. It makes "-encoding binary" something different from "-encoding iso8859-1 -eofchar {} -translation lf" without a known good reason. Seems it would fit in better with other encodings if chars outside the supported set transformed in "?" instead. --- generic/tclIO.c | 17 ++++++++++++----- 1 file changed, 12 insertions(+), 5 deletions(-) diff --git a/generic/tclIO.c b/generic/tclIO.c index 4aaf399..e211d60 100644 --- a/generic/tclIO.c +++ b/generic/tclIO.c @@ -4078,7 +4078,7 @@ Tcl_WriteChars( Channel *chanPtr = (Channel *) chan; ChannelState *statePtr = chanPtr->state; /* State info for channel */ int result; - Tcl_Obj *objPtr; + Tcl_Obj *objPtr, *copy; if (CheckChannelErrors(statePtr, TCL_WRITABLE) != 0) { return -1; @@ -4105,9 +4105,11 @@ Tcl_WriteChars( } objPtr = Tcl_NewStringObj(src, len); - src = (char *) Tcl_GetByteArrayFromObj(objPtr, &len); - result = WriteBytes(chanPtr, src, len); + copy = TclNarrowToBytes(objPtr); + src = (char *) Tcl_GetByteArrayFromObj(copy, &len); TclDecrRefCount(objPtr); + result = WriteBytes(chanPtr, src, len); + TclDecrRefCount(copy); return result; } @@ -4157,8 +4159,13 @@ Tcl_WriteObj( return -1; } if (statePtr->encoding == NULL) { - src = (char *) Tcl_GetByteArrayFromObj(objPtr, &srcLen); - return WriteBytes(chanPtr, src, srcLen); + int result; + Tcl_Obj *copy = TclNarrowToBytes(objPtr); + + src = (char *) Tcl_GetByteArrayFromObj(copy, &srcLen); + result = WriteBytes(chanPtr, src, srcLen); + Tcl_DecrRefCount(copy); + return result; } else { src = TclGetStringFromObj(objPtr, &srcLen); return WriteChars(chanPtr, src, srcLen); -- cgit v0.12 From ae718b7106a323f299d3c8227cc740c304f18535 Mon Sep 17 00:00:00 2001 From: dgp Date: Wed, 7 Dec 2016 20:01:53 +0000 Subject: Enable the no-copy path through narrowing that was overlooked. --- generic/tclBinary.c | 16 +++++++++------- 1 file changed, 9 insertions(+), 7 deletions(-) diff --git a/generic/tclBinary.c b/generic/tclBinary.c index 92a9c7f..ec39caf 100644 --- a/generic/tclBinary.c +++ b/generic/tclBinary.c @@ -489,15 +489,17 @@ Tcl_Obj * TclNarrowToBytes( Tcl_Obj *objPtr) { - ByteArray *byteArrayPtr; + if (objPtr->typePtr != &properByteArrayType) { + ByteArray *byteArrayPtr; - if (0 == MakeByteArray(objPtr, 0, &byteArrayPtr)) { - objPtr = Tcl_NewObj(); - TclInvalidateStringRep(objPtr); + if (0 == MakeByteArray(objPtr, 0, &byteArrayPtr)) { + objPtr = Tcl_NewObj(); + TclInvalidateStringRep(objPtr); + } + TclFreeIntRep(objPtr); + objPtr->typePtr = &properByteArrayType; + SET_BYTEARRAY(objPtr, byteArrayPtr); } - TclFreeIntRep(objPtr); - objPtr->typePtr = &properByteArrayType; - SET_BYTEARRAY(objPtr, byteArrayPtr); Tcl_IncrRefCount(objPtr); return objPtr; } -- cgit v0.12 From 2c9bc042ace7212959a36dab4d7d48262b1aa358 Mon Sep 17 00:00:00 2001 From: dgp Date: Wed, 7 Dec 2016 20:32:50 +0000 Subject: plug memory leak --- generic/tclBinary.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/generic/tclBinary.c b/generic/tclBinary.c index ec39caf..082c368 100644 --- a/generic/tclBinary.c +++ b/generic/tclBinary.c @@ -2690,13 +2690,13 @@ BinaryEncodeUu( * enough". */ - resultObj = Tcl_NewObj(); offset = 0; data = Tcl_GetByteArrayFromObj(objv[objc-1], &count); if (data == NULL) { Tcl_AppendResult(interp, "binary encode expects bytes", NULL); return TCL_ERROR; } + resultObj = Tcl_NewObj(); rawLength = (lineLength - 1) * 3 / 4; start = cursor = Tcl_SetByteArrayLength(resultObj, (lineLength + wrapcharlen) * -- cgit v0.12 From f14fd295940da051d212c8b36a92336114cf182e Mon Sep 17 00:00:00 2001 From: dgp Date: Tue, 13 Dec 2016 16:49:58 +0000 Subject: Detect binary errors in reflected channels. --- generic/tclIOGT.c | 27 ++++++++++++++++++++------- generic/tclIORChan.c | 11 +++++++++-- 2 files changed, 29 insertions(+), 9 deletions(-) diff --git a/generic/tclIOGT.c b/generic/tclIOGT.c index c1e8c44..5c40212 100644 --- a/generic/tclIOGT.c +++ b/generic/tclIOGT.c @@ -444,9 +444,12 @@ ExecuteCallback( } resObj = Tcl_GetObjResult(eval); resBuf = Tcl_GetByteArrayFromObj(resObj, &resLen); - Tcl_WriteRaw(Tcl_GetStackedChannel(dataPtr->self), (char *) resBuf, - resLen); - break; + if (resBuf) { + Tcl_WriteRaw(Tcl_GetStackedChannel(dataPtr->self), + (char *) resBuf, resLen); + break; + } + goto nonBytes; case TRANSMIT_SELF: if (dataPtr->self == NULL) { @@ -454,14 +457,24 @@ ExecuteCallback( } resObj = Tcl_GetObjResult(eval); resBuf = Tcl_GetByteArrayFromObj(resObj, &resLen); - Tcl_WriteRaw(dataPtr->self, (char *) resBuf, resLen); - break; + if (resBuf) { + Tcl_WriteRaw(dataPtr->self, (char *) resBuf, resLen); + break; + } + goto nonBytes; case TRANSMIT_IBUF: resObj = Tcl_GetObjResult(eval); resBuf = Tcl_GetByteArrayFromObj(resObj, &resLen); - ResultAdd(&dataPtr->result, resBuf, resLen); - break; + if (resBuf) { + ResultAdd(&dataPtr->result, resBuf, resLen); + break; + } + nonBytes: + Tcl_AppendResult(interp, "chan transform callback received non-bytes", + NULL); + Tcl_Release(eval); + return TCL_ERROR; case TRANSMIT_NUM: /* diff --git a/generic/tclIORChan.c b/generic/tclIORChan.c index 5ecd99f..52ac933 100644 --- a/generic/tclIORChan.c +++ b/generic/tclIORChan.c @@ -446,6 +446,7 @@ static void MarkDead(ReflectedChannel *rcPtr); */ static const char *msg_read_toomuch = "{read delivered more than requested}"; +static const char *msg_read_nonbyte = "{read delivered nonbyte result}"; static const char *msg_write_toomuch = "{write wrote more than requested}"; static const char *msg_write_nothing = "{write wrote nothing}"; static const char *msg_seek_beforestart = "{Tried to seek before origin}"; @@ -1309,7 +1310,10 @@ ReflectInput( bytev = Tcl_GetByteArrayFromObj(resObj, &bytec); - if (toRead < bytec) { + if (bytev == NULL) { + SetChannelErrorStr(rcPtr->chan, msg_read_nonbyte); + goto invalid; + } else if (toRead < bytec) { SetChannelErrorStr(rcPtr->chan, msg_read_toomuch); goto invalid; } @@ -2982,7 +2986,10 @@ ForwardProc( bytev = Tcl_GetByteArrayFromObj(resObj, &bytec); - if (paramPtr->input.toRead < bytec) { + if (bytev == NULL) { + ForwardSetStaticError(paramPtr, msg_read_nonbyte); + paramPtr->input.toRead = -1; + } else if (paramPtr->input.toRead < bytec) { ForwardSetStaticError(paramPtr, msg_read_toomuch); paramPtr->input.toRead = -1; } else { -- cgit v0.12 From 8d50c93eced72fa6aa0dd6e72080c70796549bae Mon Sep 17 00:00:00 2001 From: dgp Date: Tue, 13 Dec 2016 18:29:12 +0000 Subject: Update Tcl_SetByteArrayLength() and callers. --- generic/tclBinary.c | 4 +++- generic/tclIO.c | 3 ++- 2 files changed, 5 insertions(+), 2 deletions(-) diff --git a/generic/tclBinary.c b/generic/tclBinary.c index 082c368..72f61cc 100644 --- a/generic/tclBinary.c +++ b/generic/tclBinary.c @@ -420,7 +420,9 @@ Tcl_SetByteArrayLength( Tcl_Panic("%s called with shared object", "Tcl_SetByteArrayLength"); } if (objPtr->typePtr != &properByteArrayType) { - if (TCL_ERROR == SetByteArrayFromAny(NULL, objPtr)) { + if (length == 0) { + Tcl_SetByteArrayObj(objPtr, NULL, 0); + } else if (TCL_ERROR == SetByteArrayFromAny(NULL, objPtr)) { return NULL; } } diff --git a/generic/tclIO.c b/generic/tclIO.c index e211d60..b707d81 100644 --- a/generic/tclIO.c +++ b/generic/tclIO.c @@ -4515,7 +4515,8 @@ Tcl_GetsObj( if ((statePtr->encoding == NULL) && ((statePtr->inputTranslation == TCL_TRANSLATE_LF) - || (statePtr->inputTranslation == TCL_TRANSLATE_CR))) { + || (statePtr->inputTranslation == TCL_TRANSLATE_CR)) + && Tcl_GetByteArrayFromObj(objPtr, NULL) != NULL) { return TclGetsObjBinary(chan, objPtr); } -- cgit v0.12 From af6005aab08877b0a6182f85622a1e69720c2fc6 Mon Sep 17 00:00:00 2001 From: dgp Date: Fri, 16 Jun 2017 21:12:27 +0000 Subject: repair merge --- tests/utf.test | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/tests/utf.test b/tests/utf.test index aa7a89f..2a8d9ff 100644 --- a/tests/utf.test +++ b/tests/utf.test @@ -105,7 +105,7 @@ test utf-4.6 {Tcl_NumUtfChars: length 1, calc len} {testnumutfchars testbytestri testnumutfchars [testbytestring "\xC2\xA2"] 2 } {1} test utf-4.7 {Tcl_NumUtfChars: long string, calc len} {testnumutfchars testbytestring} { - testnumutfchars [testbytestring "abc\xC2\xA2\xe4\xb9\x8e\uA2\u4e4e"] 10 + testnumutfchars [testbytestring "abc\xC2\xA2\xe4\xb9\x8e\uA2\u4e"] 10 } {7} test utf-4.8 {Tcl_NumUtfChars: #u0000, calc len} {testnumutfchars testbytestring} { testnumutfchars [testbytestring "\xC0\x80"] 2 -- cgit v0.12 From 73609c6f2462ad90f94d2038efec296e7ca99519 Mon Sep 17 00:00:00 2001 From: dgp Date: Fri, 22 Feb 2019 18:59:11 +0000 Subject: not broke yet --- generic/tclBasic.c | 12 +++--- generic/tclBinary.c | 93 ++++++++++++++++++++++++----------------------- generic/tclClock.c | 2 +- generic/tclCmdAH.c | 4 +- generic/tclCmdIL.c | 8 ++-- generic/tclCmdMZ.c | 4 +- generic/tclCompCmds.c | 6 +-- generic/tclCompCmdsGR.c | 8 ++-- generic/tclConfig.c | 9 +++-- generic/tclDate.c | 2 +- generic/tclDictObj.c | 4 +- generic/tclDisassemble.c | 2 +- generic/tclEnsemble.c | 2 +- generic/tclEvent.c | 2 +- generic/tclExecute.c | 14 +++---- generic/tclFileName.c | 53 ++++++++++++++------------- generic/tclIO.c | 15 +++++--- generic/tclIOCmd.c | 8 ++-- generic/tclIORChan.c | 6 +-- generic/tclIORTrans.c | 24 ++++++------ generic/tclIOUtil.c | 64 ++++++++++++++++---------------- generic/tclIndexObj.c | 16 ++++---- generic/tclInt.h | 8 ++-- generic/tclInterp.c | 8 ++-- generic/tclLink.c | 2 +- generic/tclListObj.c | 28 ++++++++------ generic/tclLoad.c | 16 ++++---- generic/tclMain.c | 8 ++-- generic/tclNamesp.c | 4 +- generic/tclOOBasic.c | 10 ++--- generic/tclOODefineCmds.c | 4 +- generic/tclOOInfo.c | 4 +- generic/tclOOMethod.c | 6 +-- generic/tclPathObj.c | 19 ++++++---- generic/tclPkg.c | 2 +- generic/tclProc.c | 6 +-- generic/tclResult.c | 2 +- generic/tclScan.c | 4 +- generic/tclStringObj.c | 22 +++++------ generic/tclTest.c | 2 +- generic/tclTimer.c | 2 +- generic/tclTrace.c | 28 +++++++------- generic/tclVar.c | 2 +- generic/tclZipfs.c | 87 +++++++++++++++++++++----------------------- generic/tclZlib.c | 16 ++++---- unix/tclLoadDl.c | 4 +- unix/tclLoadDyld.c | 2 +- unix/tclLoadNext.c | 2 +- unix/tclLoadOSF.c | 2 +- unix/tclLoadShl.c | 2 +- unix/tclUnixChan.c | 4 +- unix/tclUnixPipe.c | 4 +- unix/tclUnixSock.c | 3 +- win/tclWinFCmd.c | 10 ++--- win/tclWinFile.c | 22 +++++------ win/tclWinInit.c | 3 +- win/tclWinLoad.c | 4 +- win/tclWinPipe.c | 9 +++-- 58 files changed, 366 insertions(+), 353 deletions(-) diff --git a/generic/tclBasic.c b/generic/tclBasic.c index 5c51291..51ff8a6 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -1055,11 +1055,11 @@ Tcl_CreateInterp(void) Tcl_PkgProvideEx(interp, "Tcl", TCL_PATCH_LEVEL, &tclStubs); if (TclTommath_Init(interp) != TCL_OK) { - Tcl_Panic("%s", TclGetString(Tcl_GetObjResult(interp))); + Tcl_Panic("%s", Tcl_GetStringResult(interp)); } if (TclOOInit(interp) != TCL_OK) { - Tcl_Panic("%s", TclGetString(Tcl_GetObjResult(interp))); + Tcl_Panic("%s", Tcl_GetStringResult(interp)); } /* @@ -1069,10 +1069,10 @@ Tcl_CreateInterp(void) #ifdef HAVE_ZLIB if (TclZlibInit(interp) != TCL_OK) { - Tcl_Panic("%s", TclGetString(Tcl_GetObjResult(interp))); + Tcl_Panic("%s", Tcl_GetStringResult(interp)); } if (TclZipfs_Init(interp) != TCL_OK) { - Tcl_Panic("%s", Tcl_GetString(Tcl_GetObjResult(interp))); + Tcl_Panic("%s", Tcl_GetStringResult(interp)); } #endif @@ -1204,7 +1204,7 @@ TclHideUnsafeCommands( TclGetString(hideName)) != TCL_OK) { Tcl_Panic("problem making '%s %s' safe: %s", unsafePtr->ensembleNsName, unsafePtr->commandName, - Tcl_GetString(Tcl_GetObjResult(interp))); + Tcl_GetStringResult(interp)); } Tcl_CreateObjCommand(interp, TclGetString(cmdName), BadEnsembleSubcommand, (ClientData) unsafePtr, NULL); @@ -1219,7 +1219,7 @@ TclHideUnsafeCommands( unsafePtr->ensembleNsName) != TCL_OK) { Tcl_Panic("problem making '%s' safe: %s", unsafePtr->ensembleNsName, - Tcl_GetString(Tcl_GetObjResult(interp))); + Tcl_GetStringResult(interp)); } } } diff --git a/generic/tclBinary.c b/generic/tclBinary.c index 6760020..a78bc3b 100644 --- a/generic/tclBinary.c +++ b/generic/tclBinary.c @@ -22,8 +22,8 @@ * special conditions in the parsing of a format specifier. */ -#define BINARY_ALL -1 /* Use all elements in the argument. */ -#define BINARY_NOCOUNT -2 /* No count was specified in format. */ +#define BINARY_ALL ((size_t)-1) /* Use all elements in the argument. */ +#define BINARY_NOCOUNT ((size_t)-2) /* No count was specified in format. */ /* * The following flags may be ORed together and returned by GetFormatSpec @@ -64,7 +64,7 @@ static int FormatNumber(Tcl_Interp *interp, int type, static void FreeByteArrayInternalRep(Tcl_Obj *objPtr); static void FreeProperByteArrayInternalRep(Tcl_Obj *objPtr); static int GetFormatSpec(const char **formatPtr, char *cmdPtr, - int *countPtr, int *flagsPtr); + size_t *countPtr, int *flagsPtr); static Tcl_Obj * ScanNumber(unsigned char *buffer, int type, int flags, Tcl_HashTable **numberCachePtr); static int SetByteArrayFromAny(Tcl_Interp *interp, @@ -73,7 +73,7 @@ static void UpdateStringOfByteArray(Tcl_Obj *listPtr); static void DeleteScanNumberCache(Tcl_HashTable *numberCachePtr); static int NeedReversing(int format); static void CopyNumber(const void *from, void *to, - unsigned length, int type); + size_t length, int type); /* Binary ensemble commands */ static int BinaryFormatCmd(ClientData clientData, Tcl_Interp *interp, @@ -285,8 +285,8 @@ typedef struct { ((TclOffset(ByteArray, bytes) + (len))) #define GET_BYTEARRAY(irPtr) ((ByteArray *) (irPtr)->twoPtrValue.ptr1) #define SET_BYTEARRAY(irPtr, baPtr) \ - (irPtr)->twoPtrValue.ptr1 = (void *) (baPtr) - + (irPtr)->twoPtrValue.ptr1 = (baPtr) + int TclIsPureByteArray( Tcl_Obj * objPtr) @@ -876,7 +876,7 @@ BinaryFormatCmd( int value = 0; /* Current integer value to be packed. * Initialized to avoid compiler warning. */ char cmd; /* Current format character. */ - int count; /* Count associated with current format + size_t count; /* Count associated with current format * character. */ int flags; /* Format field flags */ const char *format; /* Pointer to current position in format @@ -888,7 +888,8 @@ BinaryFormatCmd( * cursor has visited.*/ const char *errorString; const char *errorValue, *str; - int offset, size, length; + int offset, size; + size_t length; if (objc < 2) { Tcl_WrongNumArgs(interp, 1, objv, "formatString ?arg ...?"); @@ -927,7 +928,7 @@ BinaryFormatCmd( goto badIndex; } if (count == BINARY_ALL) { - TclGetByteArrayFromObj(objv[arg], &count); + (void)TclGetByteArrayFromObj(objv[arg], &count); } else if (count == BINARY_NOCOUNT) { count = 1; } @@ -999,7 +1000,7 @@ BinaryFormatCmd( if (count == BINARY_ALL) { count = listc; - } else if (count > listc) { + } else if (count > (size_t)listc) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "number of elements in list does not match count", -1)); @@ -1023,16 +1024,16 @@ BinaryFormatCmd( if (count == BINARY_NOCOUNT) { count = 1; } - if ((count > offset) || (count == BINARY_ALL)) { + if ((count > (size_t)offset) || (count == BINARY_ALL)) { count = offset; } - if (offset > length) { + if (offset > (int)length) { length = offset; } offset -= count; break; case '@': - if (offset > length) { + if (offset > (int)length) { length = offset; } if (count == BINARY_ALL) { @@ -1048,7 +1049,7 @@ BinaryFormatCmd( goto badField; } } - if (offset > length) { + if (offset > (int)length) { length = offset; } if (length == 0) { @@ -1062,7 +1063,7 @@ BinaryFormatCmd( resultPtr = Tcl_NewObj(); buffer = Tcl_SetByteArrayLength(resultPtr, length); - memset(buffer, 0, (size_t) length); + memset(buffer, 0, length); /* * Pack the data into the result object. Note that we can skip the @@ -1099,10 +1100,10 @@ BinaryFormatCmd( count = 1; } if (length >= count) { - memcpy(cursor, bytes, (size_t) count); + memcpy(cursor, bytes, count); } else { - memcpy(cursor, bytes, (size_t) length); - memset(cursor + length, pad, (size_t) (count - length)); + memcpy(cursor, bytes, length); + memset(cursor + length, pad, count - length); } cursor += count; break; @@ -1111,7 +1112,7 @@ BinaryFormatCmd( case 'B': { unsigned char *last; - str = Tcl_GetStringFromObj(objv[arg], &length); + str = TclGetStringFromObj(objv[arg], &length); arg++; if (count == BINARY_ALL) { count = length; @@ -1125,7 +1126,7 @@ BinaryFormatCmd( value = 0; errorString = "binary"; if (cmd == 'B') { - for (offset = 0; offset < count; offset++) { + for (offset = 0; (size_t)offset < count; offset++) { value <<= 1; if (str[offset] == '1') { value |= 1; @@ -1140,7 +1141,7 @@ BinaryFormatCmd( } } } else { - for (offset = 0; offset < count; offset++) { + for (offset = 0; (size_t)offset < count; offset++) { value >>= 1; if (str[offset] == '1') { value |= 128; @@ -1173,7 +1174,7 @@ BinaryFormatCmd( unsigned char *last; int c; - str = Tcl_GetStringFromObj(objv[arg], &length); + str = TclGetStringFromObj(objv[arg], &length); arg++; if (count == BINARY_ALL) { count = length; @@ -1187,7 +1188,7 @@ BinaryFormatCmd( value = 0; errorString = "hexadecimal"; if (cmd == 'H') { - for (offset = 0; offset < count; offset++) { + for (offset = 0; (size_t)offset < count; offset++) { value <<= 4; if (!isxdigit(UCHAR(str[offset]))) { /* INTL: digit */ errorValue = str; @@ -1208,7 +1209,7 @@ BinaryFormatCmd( } } } else { - for (offset = 0; offset < count; offset++) { + for (offset = 0; (size_t)offset < count; offset++) { value >>= 4; if (!isxdigit(UCHAR(str[offset]))) { /* INTL: digit */ @@ -1279,7 +1280,7 @@ BinaryFormatCmd( } } arg++; - for (i = 0; i < count; i++) { + for (i = 0; (size_t)i < count; i++) { if (FormatNumber(interp, cmd, listv[i], &cursor)!=TCL_OK) { Tcl_DecrRefCount(resultPtr); return TCL_ERROR; @@ -1291,7 +1292,7 @@ BinaryFormatCmd( if (count == BINARY_NOCOUNT) { count = 1; } - memset(cursor, 0, (size_t) count); + memset(cursor, 0, count); cursor += count; break; case 'X': @@ -1301,7 +1302,7 @@ BinaryFormatCmd( if (count == BINARY_NOCOUNT) { count = 1; } - if ((count == BINARY_ALL) || (count > (cursor - buffer))) { + if ((count == BINARY_ALL) || (count > (size_t)(cursor - buffer))) { cursor = buffer; } else { cursor -= count; @@ -1381,7 +1382,7 @@ BinaryScanCmd( int value = 0; /* Current integer value to be packed. * Initialized to avoid compiler warning. */ char cmd; /* Current format character. */ - int count; /* Count associated with current format + size_t count; /* Count associated with current format * character. */ int flags; /* Format field flags */ const char *format; /* Pointer to current position in format @@ -1390,7 +1391,8 @@ BinaryScanCmd( unsigned char *buffer; /* Start of result buffer. */ const char *errorString; const char *str; - int offset, size, length; + int offset, size; + size_t length; int i; Tcl_Obj *valuePtr, *elementPtr; @@ -1429,7 +1431,7 @@ BinaryScanCmd( if (count == BINARY_NOCOUNT) { count = 1; } - if (count > (length - offset)) { + if (count > length - offset) { goto done; } } @@ -1488,7 +1490,7 @@ BinaryScanCmd( if (count == BINARY_NOCOUNT) { count = 1; } - if (count > (length - offset) * 8) { + if (count > (size_t)(length - offset) * 8) { goto done; } } @@ -1498,7 +1500,7 @@ BinaryScanCmd( dest = TclGetString(valuePtr); if (cmd == 'b') { - for (i = 0; i < count; i++) { + for (i = 0; (size_t)i < count; i++) { if (i % 8) { value >>= 1; } else { @@ -1507,7 +1509,7 @@ BinaryScanCmd( *dest++ = (char) ((value & 1) ? '1' : '0'); } } else { - for (i = 0; i < count; i++) { + for (i = 0; (size_t)i < count; i++) { if (i % 8) { value <<= 1; } else { @@ -1553,7 +1555,7 @@ BinaryScanCmd( dest = TclGetString(valuePtr); if (cmd == 'h') { - for (i = 0; i < count; i++) { + for (i = 0; (size_t)i < count; i++) { if (i % 2) { value >>= 4; } else { @@ -1562,7 +1564,7 @@ BinaryScanCmd( *dest++ = hexdigit[value & 0xf]; } } else { - for (i = 0; i < count; i++) { + for (i = 0; (size_t)i < count; i++) { if (i % 2) { value <<= 4; } else { @@ -1619,7 +1621,7 @@ BinaryScanCmd( goto badIndex; } if (count == BINARY_NOCOUNT) { - if ((length - offset) < size) { + if ((length - offset) < (size_t)size) { goto done; } valuePtr = ScanNumber(buffer+offset, cmd, flags, @@ -1634,7 +1636,7 @@ BinaryScanCmd( } valuePtr = Tcl_NewObj(); src = buffer + offset; - for (i = 0; i < count; i++) { + for (i = 0; (size_t)i < count; i++) { elementPtr = ScanNumber(src, cmd, flags, &numberCachePtr); src += size; Tcl_ListObjAppendElement(NULL, valuePtr, elementPtr); @@ -1655,7 +1657,7 @@ BinaryScanCmd( if (count == BINARY_NOCOUNT) { count = 1; } - if ((count == BINARY_ALL) || (count > (length - offset))) { + if ((count == BINARY_ALL) || (count > length - offset)) { offset = length; } else { offset += count; @@ -1665,7 +1667,7 @@ BinaryScanCmd( if (count == BINARY_NOCOUNT) { count = 1; } - if ((count == BINARY_ALL) || (count > offset)) { + if ((count == BINARY_ALL) || (count > (size_t)offset)) { offset = 0; } else { offset -= count; @@ -1749,7 +1751,7 @@ static int GetFormatSpec( const char **formatPtr, /* Pointer to format string. */ char *cmdPtr, /* Pointer to location of command char. */ - int *countPtr, /* Pointer to repeat count value. */ + size_t *countPtr, /* Pointer to repeat count value. */ int *flagsPtr) /* Pointer to field flags */ { /* @@ -1915,7 +1917,7 @@ static void CopyNumber( const void *from, /* source */ void *to, /* destination */ - unsigned length, /* Number of bytes to copy */ + size_t length, /* Number of bytes to copy */ int type) /* What type of thing are we copying? */ { switch (NeedReversing(type)) { @@ -2445,7 +2447,7 @@ BinaryEncodeHex( Tcl_Obj *resultObj = NULL; unsigned char *data = NULL; unsigned char *cursor = NULL; - int offset = 0, count = 0; + size_t offset = 0, count = 0; if (objc != 2) { Tcl_WrongNumArgs(interp, 1, objv, "data"); @@ -2611,7 +2613,8 @@ BinaryEncode64( int maxlen = 0; const char *wrapchar = "\n"; size_t wrapcharlen = 1; - int offset, i, index, size, outindex = 0, count = 0; + int i, index, size, outindex = 0; + size_t offset, count = 0; enum {OPT_MAXLEN, OPT_WRAPCHAR }; static const char *const optStrings[] = { "-maxlen", "-wrapchar", NULL }; @@ -2714,11 +2717,11 @@ BinaryEncodeUu( { Tcl_Obj *resultObj; unsigned char *data, *start, *cursor; - int offset, count, rawLength, n, i, j, bits, index; + int rawLength, n, i, bits, index; int lineLength = 61; const unsigned char SingleNewline[] = { (unsigned char) '\n' }; const unsigned char *wrapchar = SingleNewline; - int wrapcharlen = sizeof(SingleNewline); + size_t j, offset, count, wrapcharlen = sizeof(SingleNewline); enum { OPT_MAXLEN, OPT_WRAPCHAR }; static const char *const optStrings[] = { "-maxlen", "-wrapchar", NULL }; diff --git a/generic/tclClock.c b/generic/tclClock.c index f9a8008..ba12b66 100644 --- a/generic/tclClock.c +++ b/generic/tclClock.c @@ -1922,7 +1922,7 @@ ClockParseformatargsObjCmd( if (Tcl_GetIndexFromObj(interp, objv[i], options, "option", 0, &optionIndex) != TCL_OK) { Tcl_SetErrorCode(interp, "CLOCK", "badOption", - Tcl_GetString(objv[i]), NULL); + TclGetString(objv[i]), NULL); return TCL_ERROR; } switch (optionIndex) { diff --git a/generic/tclCmdAH.c b/generic/tclCmdAH.c index bcf5c48..970bdb4 100644 --- a/generic/tclCmdAH.c +++ b/generic/tclCmdAH.c @@ -1710,7 +1710,7 @@ PathFilesystemCmd( if (fsInfo == NULL) { Tcl_SetObjResult(interp, Tcl_NewStringObj("unrecognised path", -1)); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "FILESYSTEM", - Tcl_GetString(objv[1]), NULL); + TclGetString(objv[1]), NULL); return TCL_ERROR; } Tcl_SetObjResult(interp, fsInfo); @@ -1962,7 +1962,7 @@ FilesystemSeparatorCmd( Tcl_SetObjResult(interp, Tcl_NewStringObj( "unrecognised path", -1)); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "FILESYSTEM", - Tcl_GetString(objv[1]), NULL); + TclGetString(objv[1]), NULL); return TCL_ERROR; } Tcl_SetObjResult(interp, separatorObj); diff --git a/generic/tclCmdIL.c b/generic/tclCmdIL.c index 3fdb890..e7ff8cb 100644 --- a/generic/tclCmdIL.c +++ b/generic/tclCmdIL.c @@ -1047,7 +1047,7 @@ InfoErrorStackCmd( target = interp; if (objc == 2) { - target = Tcl_GetSlave(interp, Tcl_GetString(objv[1])); + target = Tcl_GetSlave(interp, TclGetString(objv[1])); if (target == NULL) { return TCL_ERROR; } @@ -2155,7 +2155,7 @@ InfoCmdTypeCmd( Tcl_WrongNumArgs(interp, 1, objv, "commandName"); return TCL_ERROR; } - command = Tcl_FindCommand(interp, Tcl_GetString(objv[1]), NULL, + command = Tcl_FindCommand(interp, TclGetString(objv[1]), NULL, TCL_LEAVE_ERR_MSG); if (command == NULL) { return TCL_ERROR; @@ -3248,7 +3248,7 @@ Tcl_LsearchObjCmd( if (encoded == TCL_INDEX_NONE) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "index \"%s\" cannot select an element " - "from any list", Tcl_GetString(indices[j]))); + "from any list", TclGetString(indices[j]))); Tcl_SetErrorCode(interp, "TCL", "VALUE", "INDEX" "OUTOFRANGE", NULL); result = TCL_ERROR; @@ -3965,7 +3965,7 @@ Tcl_LsortObjCmd( if ((result == TCL_OK) && (encoded == TCL_INDEX_NONE)) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "index \"%s\" cannot select an element " - "from any list", Tcl_GetString(indexv[j]))); + "from any list", TclGetString(indexv[j]))); Tcl_SetErrorCode(interp, "TCL", "VALUE", "INDEX" "OUTOFRANGE", NULL); result = TCL_ERROR; diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c index 75dac00..8afc98c 100644 --- a/generic/tclCmdMZ.c +++ b/generic/tclCmdMZ.c @@ -4211,7 +4211,7 @@ TclNRTryObjCmd( if (Tcl_ListObjLength(NULL, objv[i+1], &dummy) != TCL_OK) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "bad prefix '%s': must be a list", - Tcl_GetString(objv[i+1]))); + TclGetString(objv[i+1]))); Tcl_DecrRefCount(handlersObj); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "TRY", "TRAP", "EXNFORMAT", NULL); @@ -4750,7 +4750,7 @@ TclListLines( Tcl_Obj *const *elems) /* The list elems as Tcl_Obj*, in need of * derived continuation data */ { - const char *listStr = Tcl_GetString(listObj); + const char *listStr = TclGetString(listObj); const char *listHead = listStr; int i, length = strlen(listStr); const char *element = NULL, *next = NULL; diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c index 810b26e..22faa16 100644 --- a/generic/tclCompCmds.c +++ b/generic/tclCompCmds.c @@ -3185,7 +3185,7 @@ TclCompileFormatCmd( * the format is broken). Do the format now. */ - tmpObj = Tcl_Format(interp, Tcl_GetString(formatObj), + tmpObj = Tcl_Format(interp, TclGetString(formatObj), parsePtr->numWords-2, objv); for (; --i>=0 ;) { Tcl_DecrRefCount(objv[i]); @@ -3229,7 +3229,7 @@ TclCompileFormatCmd( * Now scan through and check for non-%s and non-%% substitutions. */ - for (bytes = Tcl_GetString(formatObj) ; *bytes ; bytes++) { + for (bytes = TclGetString(formatObj) ; *bytes ; bytes++) { if (*bytes == '%') { bytes++; if (*bytes == 's') { @@ -3262,7 +3262,7 @@ TclCompileFormatCmd( i = 0; /* The count of things to concat. */ j = 2; /* The index into the argument tokens, for * TIP#280 handling. */ - start = Tcl_GetString(formatObj); + start = TclGetString(formatObj); /* The start of the currently-scanned literal * in the format string. */ tmpObj = Tcl_NewObj(); /* The buffer used to accumulate the literal diff --git a/generic/tclCompCmdsGR.c b/generic/tclCompCmdsGR.c index 3e8bfee..c790729 100644 --- a/generic/tclCompCmdsGR.c +++ b/generic/tclCompCmdsGR.c @@ -607,7 +607,7 @@ TclCompileInfoCommandsCmd( if (!TclWordKnownAtCompileTime(tokenPtr, objPtr)) { goto notCompilable; } - bytes = Tcl_GetString(objPtr); + bytes = TclGetString(objPtr); /* * We require that the argument start with "::" and not have any of "*\[?" @@ -2298,8 +2298,8 @@ TclCompileRegsubCmd( if (!TclWordKnownAtCompileTime(tokenPtr, patternObj)) { goto done; } - if (Tcl_GetString(patternObj)[0] == '-') { - if (strcmp(Tcl_GetString(patternObj), "--") != 0 + if (TclGetString(patternObj)[0] == '-') { + if (strcmp(TclGetString(patternObj), "--") != 0 || parsePtr->numWords == 5) { goto done; } @@ -2364,7 +2364,7 @@ TclCompileRegsubCmd( bytes++; } isSimpleGlob: - for (bytes = Tcl_GetString(replacementObj); *bytes; bytes++) { + for (bytes = TclGetString(replacementObj); *bytes; bytes++) { switch (*bytes) { case '\\': case '&': goto done; diff --git a/generic/tclConfig.c b/generic/tclConfig.c index 3d017ed..7e5a311 100644 --- a/generic/tclConfig.c +++ b/generic/tclConfig.c @@ -202,7 +202,8 @@ QueryConfigObjCmd( QCCD *cdPtr = clientData; Tcl_Obj *pkgName = cdPtr->pkg; Tcl_Obj *pDB, *pkgDict, *val, *listPtr; - int n, index; + size_t n; + int index, m; static const char *const subcmdStrings[] = { "get", "list", NULL }; @@ -274,8 +275,8 @@ QueryConfigObjCmd( return TCL_ERROR; } - Tcl_DictObjSize(interp, pkgDict, &n); - listPtr = Tcl_NewListObj(n, NULL); + Tcl_DictObjSize(interp, pkgDict, &m); + listPtr = Tcl_NewListObj(m, NULL); if (!listPtr) { Tcl_SetObjResult(interp, Tcl_NewStringObj( @@ -284,7 +285,7 @@ QueryConfigObjCmd( return TCL_ERROR; } - if (n) { + if (m) { Tcl_DictSearch s; Tcl_Obj *key; int done; diff --git a/generic/tclDate.c b/generic/tclDate.c index 6bc88d9..aa65e77 100644 --- a/generic/tclDate.c +++ b/generic/tclDate.c @@ -2761,7 +2761,7 @@ TclClockOldscanObjCmd( return TCL_ERROR; } - yyInput = Tcl_GetString( objv[1] ); + yyInput = TclGetString(objv[1]); dateInfo.dateStart = yyInput; yyHaveDate = 0; diff --git a/generic/tclDictObj.c b/generic/tclDictObj.c index 9462581..42b4f87 100644 --- a/generic/tclDictObj.c +++ b/generic/tclDictObj.c @@ -640,7 +640,7 @@ SetDictFromAny( * convert back. */ - (void) Tcl_GetString(objPtr); + (void) TclGetString(objPtr); TclDecrRefCount(discardedValue); } @@ -3236,7 +3236,7 @@ DictUpdateCmd( } if (objPtr == NULL) { /* ??? */ - Tcl_UnsetVar(interp, Tcl_GetString(objv[i+1]), 0); + Tcl_UnsetVar(interp, TclGetString(objv[i+1]), 0); } else if (Tcl_ObjSetVar2(interp, objv[i+1], NULL, objPtr, TCL_LEAVE_ERR_MSG) == NULL) { TclDecrRefCount(dictPtr); diff --git a/generic/tclDisassemble.c b/generic/tclDisassemble.c index 9847b6b..6e4d541 100644 --- a/generic/tclDisassemble.c +++ b/generic/tclDisassemble.c @@ -288,7 +288,7 @@ DisassembleByteCodeObj( GetLocationInformation(codePtr->procPtr, &fileObj, &line); if (line > -1 && fileObj != NULL) { Tcl_AppendPrintfToObj(bufferObj, "\n File \"%s\" Line %d", - Tcl_GetString(fileObj), line); + TclGetString(fileObj), line); } Tcl_AppendPrintfToObj(bufferObj, "\n Cmds %d, src %d, inst %d, litObjs %u, aux %d, stkDepth %u, code/src %.2f\n", diff --git a/generic/tclEnsemble.c b/generic/tclEnsemble.c index ef3b0cf..870c6b0 100644 --- a/generic/tclEnsemble.c +++ b/generic/tclEnsemble.c @@ -1624,7 +1624,7 @@ TclMakeEnsemble( Tcl_DStringSetLength(&hiddenBuf, hiddenLen); if (Tcl_HideCommand(interp, "___tmp", Tcl_DStringAppend(&hiddenBuf, map[i].name, -1))) { - Tcl_Panic("%s", Tcl_GetString(Tcl_GetObjResult(interp))); + Tcl_Panic("%s", Tcl_GetStringResult(interp)); } } else { /* diff --git a/generic/tclEvent.c b/generic/tclEvent.c index 91a5323..5d180d5 100644 --- a/generic/tclEvent.c +++ b/generic/tclEvent.c @@ -1403,7 +1403,7 @@ Tcl_VwaitObjCmd( Tcl_WrongNumArgs(interp, 1, objv, "name"); return TCL_ERROR; } - nameString = Tcl_GetString(objv[1]); + nameString = TclGetString(objv[1]); if (Tcl_TraceVar2(interp, nameString, NULL, TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS, VwaitVarProc, &done) != TCL_OK) { diff --git a/generic/tclExecute.c b/generic/tclExecute.c index a30cd4b..c1b85ad 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -3562,7 +3562,7 @@ TEBCresume( arrayPtr = NULL; part1Ptr = part2Ptr = NULL; cleanup = 0; - TRACE(("%u %s => ", opnd, Tcl_GetString(incrPtr))); + TRACE(("%u %s => ", opnd, TclGetString(incrPtr))); doIncrVar: if (TclIsVarDirectModifyable2(varPtr, arrayPtr)) { @@ -4524,8 +4524,8 @@ TEBCresume( { int index, numIndices, fromIdx, toIdx; - int nocase, match, length2, cflags, s1len, s2len; - size_t slength; + int nocase, match, cflags, s1len, s2len; + size_t slength, length2; const char *s1, *s2; case INST_LIST: @@ -5114,7 +5114,7 @@ TEBCresume( { Tcl_UniChar *ustring1, *ustring2, *ustring3, *end, *p; - int length3; + size_t length3; Tcl_Obj *value3Ptr; case INST_STR_REPLACE: @@ -5190,10 +5190,10 @@ TEBCresume( goto doneStringMap; } ustring2 = TclGetUnicodeFromObj(value2Ptr, &length2); - if (length2 > (int)slength || length2 == 0) { + if (length2 > slength || length2 == 0) { objResultPtr = valuePtr; goto doneStringMap; - } else if (length2 == (int)slength) { + } else if (length2 == slength) { if (memcmp(ustring1, ustring2, sizeof(Tcl_UniChar) * slength)) { objResultPtr = valuePtr; } else { @@ -8638,7 +8638,7 @@ IllegalExprOperandType( Tcl_SetObjResult(interp, Tcl_ObjPrintf( "can't use %s \"%s\" as operand of \"%s\"", description, - Tcl_GetString(opndPtr), operator)); + TclGetString(opndPtr), operator)); Tcl_SetErrorCode(interp, "ARITH", "DOMAIN", description, NULL); } diff --git a/generic/tclFileName.c b/generic/tclFileName.c index 33980eb..5d0cff6 100644 --- a/generic/tclFileName.c +++ b/generic/tclFileName.c @@ -386,8 +386,7 @@ TclpGetNativePathType( Tcl_Obj **driveNameRef) { Tcl_PathType type = TCL_PATH_ABSOLUTE; - int pathLen; - const char *path = TclGetStringFromObj(pathPtr, &pathLen); + const char *path = TclGetString(pathPtr); if (path[0] == '~') { /* @@ -504,11 +503,11 @@ TclpNativeSplitPath( switch (tclPlatform) { case TCL_PLATFORM_UNIX: - resultPtr = SplitUnixPath(Tcl_GetString(pathPtr)); + resultPtr = SplitUnixPath(TclGetString(pathPtr)); break; case TCL_PLATFORM_WINDOWS: - resultPtr = SplitWinPath(Tcl_GetString(pathPtr)); + resultPtr = SplitWinPath(TclGetString(pathPtr)); break; } @@ -557,7 +556,8 @@ Tcl_SplitPath( { Tcl_Obj *resultPtr = NULL; /* Needed only to prevent gcc warnings. */ Tcl_Obj *tmpPtr, *eltPtr; - int i, size, len; + int i; + size_t size, len; char *p; const char *str; @@ -896,7 +896,7 @@ TclpNativeJoinPath( Tcl_SetObjLength(prefix, length + (int) strlen(p)); - dest = Tcl_GetString(prefix) + length; + dest = TclGetString(prefix) + length; for (; *p != '\0'; p++) { if (*p == '/') { while (p[1] == '/') { @@ -910,7 +910,7 @@ TclpNativeJoinPath( needsSep = 1; } } - length = dest - Tcl_GetString(prefix); + length = dest - TclGetString(prefix); Tcl_SetObjLength(prefix, length); break; @@ -931,7 +931,7 @@ TclpNativeJoinPath( */ Tcl_SetObjLength(prefix, length + (int) strlen(p)); - dest = Tcl_GetString(prefix) + length; + dest = TclGetString(prefix) + length; for (; *p != '\0'; p++) { if ((*p == '/') || (*p == '\\')) { while ((p[1] == '/') || (p[1] == '\\')) { @@ -945,7 +945,7 @@ TclpNativeJoinPath( needsSep = 1; } } - length = dest - Tcl_GetString(prefix); + length = dest - TclGetString(prefix); Tcl_SetObjLength(prefix, length); break; } @@ -977,7 +977,8 @@ Tcl_JoinPath( const char *const *argv, Tcl_DString *resultPtr) /* Pointer to previously initialized DString */ { - int i, len; + int i; + size_t len; Tcl_Obj *listObj = Tcl_NewObj(); Tcl_Obj *resultObj; const char *resultStr; @@ -1250,7 +1251,7 @@ Tcl_GlobObjCmd( for (i = 1; i < objc; i++) { if (Tcl_GetIndexFromObj(interp, objv[i], options, "option", 0, &index) != TCL_OK) { - string = TclGetStringFromObj(objv[i], &length); + string = TclGetString(objv[i]); if (string[0] == '-') { /* * It looks like the command contains an option so signal an @@ -1356,7 +1357,7 @@ Tcl_GlobObjCmd( } if (dir == PATH_GENERAL) { - int pathlength; + size_t pathlength; const char *last; const char *first = TclGetStringFromObj(pathOrDir,&pathlength); @@ -1408,7 +1409,7 @@ Tcl_GlobObjCmd( * there are none presently in the prefix. */ - if (strpbrk(Tcl_GetString(pathOrDir), "\\/") == NULL) { + if (strpbrk(TclGetString(pathOrDir), "\\/") == NULL) { Tcl_AppendToObj(pathOrDir, last-1, 1); } } @@ -1520,9 +1521,9 @@ Tcl_GlobObjCmd( if ((Tcl_ListObjLength(NULL, look, &llen) == TCL_OK) && (llen == 3)) { Tcl_ListObjIndex(interp, look, 0, &item); - if (!strcmp("macintosh", Tcl_GetString(item))) { + if (!strcmp("macintosh", TclGetString(item))) { Tcl_ListObjIndex(interp, look, 1, &item); - if (!strcmp("type", Tcl_GetString(item))) { + if (!strcmp("type", TclGetString(item))) { Tcl_ListObjIndex(interp, look, 2, &item); if (globTypes->macType != NULL) { goto badMacTypesArg; @@ -1530,7 +1531,7 @@ Tcl_GlobObjCmd( globTypes->macType = item; Tcl_IncrRefCount(item); continue; - } else if (!strcmp("creator", Tcl_GetString(item))) { + } else if (!strcmp("creator", TclGetString(item))) { Tcl_ListObjIndex(interp, look, 2, &item); if (globTypes->macCreator != NULL) { goto badMacTypesArg; @@ -1550,7 +1551,7 @@ Tcl_GlobObjCmd( badTypesArg: Tcl_SetObjResult(interp, Tcl_ObjPrintf( "bad argument to \"-types\": %s", - Tcl_GetString(look))); + TclGetString(look))); Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "BAD", NULL); result = TCL_ERROR; join = 0; @@ -1614,7 +1615,7 @@ Tcl_GlobObjCmd( Tcl_DStringFree(&str); } else { for (i = 0; i < objc; i++) { - string = Tcl_GetString(objv[i]); + string = TclGetString(objv[i]); if (TclGlob(interp, string, pathOrDir, globFlags, globTypes) != TCL_OK) { result = TCL_ERROR; @@ -1646,7 +1647,7 @@ Tcl_GlobObjCmd( for (i = 0; i < objc; i++) { Tcl_AppendPrintfToObj(errorMsg, "%s%s", - sep, Tcl_GetString(objv[i])); + sep, TclGetString(objv[i])); sep = " "; } } @@ -1849,7 +1850,7 @@ TclGlob( Tcl_DecrRefCount(temp); return TCL_ERROR; } - pathPrefix = Tcl_NewStringObj(Tcl_GetString(cwd), 3); + pathPrefix = Tcl_NewStringObj(TclGetString(cwd), 3); Tcl_DecrRefCount(cwd); if (tail[0] == '/') { tail++; @@ -1983,7 +1984,7 @@ TclGlob( if (globFlags & TCL_GLOBMODE_TAILS) { int objc, i; Tcl_Obj **objv; - int prefixLen; + size_t prefixLen; const char *pre; /* @@ -2011,7 +2012,7 @@ TclGlob( Tcl_ListObjGetElements(NULL, filenamesObj, &objc, &objv); for (i = 0; i< objc; i++) { - int len; + size_t len; const char *oldStr = TclGetStringFromObj(objv[i], &len); Tcl_Obj *elem; @@ -2343,7 +2344,7 @@ DoGlob( for (i=0; result==TCL_OK && istate; /* State info for channel */ ChannelBuffer *bufPtr; - int inEofChar, skip, copiedTotal, oldLength, oldFlags, oldRemoved; + int inEofChar, skip, copiedTotal, oldFlags, oldRemoved; + size_t oldLength; Tcl_Encoding encoding; char *dst, *dstEnd, *eol, *eof; Tcl_EncodingState oldState; @@ -6085,7 +6086,8 @@ ReadChars( int savedIEFlags = statePtr->inputEncodingFlags; int savedFlags = statePtr->flags; char *dst, *src = RemovePoint(bufPtr); - int numBytes, srcLen = BytesLeft(bufPtr); + size_t numBytes; + int srcLen = BytesLeft(bufPtr); /* * One src byte can yield at most one character. So when the number of @@ -9426,7 +9428,8 @@ CopyData( Tcl_Obj *cmdPtr, *errObj = NULL, *bufObj = NULL, *msg = NULL; Tcl_Channel inChan, outChan; ChannelState *inStatePtr, *outStatePtr; - int result = TCL_OK, size, sizeb; + int result = TCL_OK, size; + size_t sizeb; Tcl_WideInt total; const char *buffer; int inBinary, outBinary, sameEncoding; @@ -9492,7 +9495,7 @@ CopyData( || (csPtr->toRead > (Tcl_WideInt) csPtr->bufSize)) { sizeb = csPtr->bufSize; } else { - sizeb = (int) csPtr->toRead; + sizeb = csPtr->toRead; } if (inBinary || sameEncoding) { @@ -9502,7 +9505,7 @@ CopyData( size = DoReadChars(inStatePtr->topChanPtr, bufObj, sizeb, 0 /* No append */); } - underflow = (size >= 0) && (size < sizeb); /* Input underflow */ + underflow = (size >= 0) && ((size_t)size < sizeb); /* Input underflow */ } if (size < 0) { @@ -9586,7 +9589,7 @@ CopyData( * unsuitable for updating totals and toRead. */ - if (sizeb < 0) { + if (sizeb == TCL_AUTO_LENGTH) { writeError: if (interp) { TclNewObj(errObj); diff --git a/generic/tclIOCmd.c b/generic/tclIOCmd.c index 3e65002..cbfd1da 100644 --- a/generic/tclIOCmd.c +++ b/generic/tclIOCmd.c @@ -708,7 +708,7 @@ Tcl_CloseObjCmd( Tcl_Obj *resultPtr = Tcl_GetObjResult(interp); const char *string; - int len; + size_t len; if (Tcl_IsShared(resultPtr)) { resultPtr = Tcl_DuplicateObj(resultPtr); @@ -870,8 +870,8 @@ Tcl_ExecObjCmd( * on the _Tcl_ stack. */ const char *string; Tcl_Channel chan; - int argc, background, i, index, keepNewline, result, skip, length; - int ignoreStderr; + int argc, background, i, index, keepNewline, result, skip, ignoreStderr; + size_t length; static const char *const options[] = { "-ignorestderr", "-keepnewline", "--", NULL }; @@ -1476,7 +1476,7 @@ Tcl_SocketObjCmd( } for (a = 1; a < objc; a++) { - const char *arg = Tcl_GetString(objv[a]); + const char *arg = TclGetString(objv[a]); if (arg[0] != '-') { break; diff --git a/generic/tclIORChan.c b/generic/tclIORChan.c index c8858af..cae0836 100644 --- a/generic/tclIORChan.c +++ b/generic/tclIORChan.c @@ -1957,7 +1957,7 @@ ReflectGetOption( (listc == 1 ? "" : "s"))); goto error; } else { - int len; + size_t len; const char *str = TclGetStringFromObj(resObj, &len); if (len) { @@ -2330,7 +2330,7 @@ InvokeTclMethod( */ if (result != TCL_ERROR) { - int cmdLen; + size_t cmdLen; const char *cmdString = TclGetStringFromObj(cmd, &cmdLen); Tcl_IncrRefCount(cmd); @@ -3194,7 +3194,7 @@ ForwardProc( ForwardSetDynamicError(paramPtr, buf); } else { - int len; + size_t len; const char *str = TclGetStringFromObj(resObj, &len); if (len) { diff --git a/generic/tclIORTrans.c b/generic/tclIORTrans.c index 678fcc1..3769533 100644 --- a/generic/tclIORTrans.c +++ b/generic/tclIORTrans.c @@ -89,8 +89,8 @@ static const Tcl_ChannelType tclRTransformType = { typedef struct { unsigned char *buf; /* Reference to the buffer area. */ - int allocated; /* Allocated size of the buffer area. */ - int used; /* Number of bytes in the buffer, + size_t allocated; /* Allocated size of the buffer area. */ + size_t used; /* Number of bytes in the buffer, * <= allocated. */ } ResultBuffer; @@ -270,7 +270,7 @@ struct ForwardParamTransform { ForwardParamBase base; /* "Supertype". MUST COME FIRST. */ char *buf; /* I: Bytes to transform, * O: Bytes in transform result */ - int size; /* I: #bytes to transform, + size_t size; /* I: #bytes to transform, * O: #bytes in the transform result */ }; struct ForwardParamLimit { @@ -620,7 +620,7 @@ TclChanPushObjCmd( Tcl_SetObjResult(interp, Tcl_ObjPrintf( "chan handler \"%s initialize\" returned %s", TclGetString(cmdObj), - Tcl_GetString(Tcl_GetObjResult(interp)))); + Tcl_GetStringResult(interp))); Tcl_DecrRefCount(resObj); goto error; } @@ -1014,7 +1014,7 @@ ReflectClose( if (!rtPtr->dead) { rtmPtr = GetReflectedTransformMap(rtPtr->interp); - hPtr = Tcl_FindHashEntry(&rtmPtr->map, Tcl_GetString(rtPtr->handle)); + hPtr = Tcl_FindHashEntry(&rtmPtr->map, TclGetString(rtPtr->handle)); if (hPtr) { Tcl_DeleteHashEntry(hPtr); } @@ -2041,7 +2041,7 @@ InvokeTclMethod( */ if (result != TCL_ERROR) { Tcl_Obj *cmd = Tcl_NewListObj(cmdc, rtPtr->argv); - int cmdLen; + size_t cmdLen; const char *cmdString = TclGetStringFromObj(cmd, &cmdLen); Tcl_IncrRefCount(cmd); @@ -2590,7 +2590,7 @@ ForwardProc( if (InvokeTclMethod(rtPtr, "read", bufObj, NULL, &resObj) != TCL_OK) { ForwardSetObjError(paramPtr, resObj); - paramPtr->transform.size = -1; + paramPtr->transform.size = TCL_AUTO_LENGTH; } else { /* * Process a regular return. Contains the transformation result. @@ -2624,7 +2624,7 @@ ForwardProc( if (InvokeTclMethod(rtPtr, "write", bufObj, NULL, &resObj) != TCL_OK) { ForwardSetObjError(paramPtr, resObj); - paramPtr->transform.size = -1; + paramPtr->transform.size = TCL_AUTO_LENGTH; } else { /* * Process a regular return. Contains the transformation result. @@ -2654,7 +2654,7 @@ ForwardProc( case ForwardedDrain: if (InvokeTclMethod(rtPtr, "drain", NULL, NULL, &resObj) != TCL_OK) { ForwardSetObjError(paramPtr, resObj); - paramPtr->transform.size = -1; + paramPtr->transform.size = TCL_AUTO_LENGTH; } else { /* * Process a regular return. Contains the transformation result. @@ -2680,7 +2680,7 @@ ForwardProc( case ForwardedFlush: if (InvokeTclMethod(rtPtr, "flush", NULL, NULL, &resObj) != TCL_OK) { ForwardSetObjError(paramPtr, resObj); - paramPtr->transform.size = -1; + paramPtr->transform.size = TCL_AUTO_LENGTH; } else { /* * Process a regular return. Contains the transformation result. @@ -3037,7 +3037,7 @@ ResultCopy( */ copied = 0; - } else if (rPtr->used == toRead) { + } else if (rPtr->used == (size_t)toRead) { /* * We have just enough. Copy everything to the caller. */ @@ -3045,7 +3045,7 @@ ResultCopy( memcpy(buf, rPtr->buf, toRead); rPtr->used = 0; copied = toRead; - } else if (rPtr->used > toRead) { + } else if (rPtr->used > (size_t)toRead) { /* * The internal buffer contains more than requested. Copy the * requested subset to the caller, and shift the remaining bytes down. diff --git a/generic/tclIOUtil.c b/generic/tclIOUtil.c index 3a6233a..c366af9 100644 --- a/generic/tclIOUtil.c +++ b/generic/tclIOUtil.c @@ -539,7 +539,7 @@ TclFSCwdPointerEquals( if (tsdPtr->cwdPathPtr == *pathPtrPtr) { return 1; } else { - int len1, len2; + size_t len1, len2; const char *str1, *str2; str1 = TclGetStringFromObj(tsdPtr->cwdPathPtr, &len1); @@ -681,7 +681,7 @@ FsUpdateCwd( Tcl_Obj *cwdObj, ClientData clientData) { - int len = 0; + size_t len = 0; const char *str = NULL; ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&fsDataKey); @@ -1203,7 +1203,7 @@ FsAddMountsToGlobResult( } if (!found && dir) { Tcl_Obj *norm; - int len, mlen; + size_t len, mlen; /* * We know mElt is absolute normalized and lies inside pathPtr, so @@ -1390,7 +1390,7 @@ TclFSNormalizeToUniquePath( { FilesystemRecord *fsRecPtr, *firstFsRecPtr; - int i; + size_t i; int isVfsPath = 0; char *path; @@ -1403,7 +1403,7 @@ TclFSNormalizeToUniquePath( * We check these first to avoid useless calls to the native filesystem's * normalizePathProc. */ - path = Tcl_GetStringFromObj(pathPtr, &i); + path = TclGetStringFromObj(pathPtr, &i); if ( (i >= 3) && ( (path[0] == '/' && path[1] == '/') || (path[0] == '\\' && path[1] == '\\') ) ) { @@ -1769,14 +1769,14 @@ Tcl_FSEvalFileEx( Tcl_SetErrno(errno); Tcl_SetObjResult(interp, Tcl_ObjPrintf( "couldn't read file \"%s\": %s", - Tcl_GetString(pathPtr), Tcl_PosixError(interp))); + TclGetString(pathPtr), Tcl_PosixError(interp))); return result; } chan = Tcl_FSOpenFileChannel(interp, pathPtr, "r", 0644); if (chan == NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "couldn't read file \"%s\": %s", - Tcl_GetString(pathPtr), Tcl_PosixError(interp))); + TclGetString(pathPtr), Tcl_PosixError(interp))); return result; } @@ -1812,10 +1812,10 @@ Tcl_FSEvalFileEx( Tcl_Close(interp, chan); Tcl_SetObjResult(interp, Tcl_ObjPrintf( "couldn't read file \"%s\": %s", - Tcl_GetString(pathPtr), Tcl_PosixError(interp))); + TclGetString(pathPtr), Tcl_PosixError(interp))); goto end; } - string = Tcl_GetString(objPtr); + string = TclGetString(objPtr); /* * If first character is not a BOM, append the remaining characters, @@ -1827,7 +1827,7 @@ Tcl_FSEvalFileEx( Tcl_Close(interp, chan); Tcl_SetObjResult(interp, Tcl_ObjPrintf( "couldn't read file \"%s\": %s", - Tcl_GetString(pathPtr), Tcl_PosixError(interp))); + TclGetString(pathPtr), Tcl_PosixError(interp))); goto end; } @@ -1903,17 +1903,17 @@ TclNREvalFile( Tcl_SetErrno(errno); Tcl_SetObjResult(interp, Tcl_ObjPrintf( "couldn't read file \"%s\": %s", - Tcl_GetString(pathPtr), Tcl_PosixError(interp))); + TclGetString(pathPtr), Tcl_PosixError(interp))); return TCL_ERROR; } chan = Tcl_FSOpenFileChannel(interp, pathPtr, "r", 0644); if (chan == NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "couldn't read file \"%s\": %s", - Tcl_GetString(pathPtr), Tcl_PosixError(interp))); + TclGetString(pathPtr), Tcl_PosixError(interp))); return TCL_ERROR; } - TclPkgFileSeen(interp, Tcl_GetString(pathPtr)); + TclPkgFileSeen(interp, TclGetString(pathPtr)); /* * The eofchar is \32 (^Z). This is the usual on Windows, but we effect @@ -1947,11 +1947,11 @@ TclNREvalFile( Tcl_Close(interp, chan); Tcl_SetObjResult(interp, Tcl_ObjPrintf( "couldn't read file \"%s\": %s", - Tcl_GetString(pathPtr), Tcl_PosixError(interp))); + TclGetString(pathPtr), Tcl_PosixError(interp))); Tcl_DecrRefCount(objPtr); return TCL_ERROR; } - string = Tcl_GetString(objPtr); + string = TclGetString(objPtr); /* * If first character is not a BOM, append the remaining characters, @@ -1963,7 +1963,7 @@ TclNREvalFile( Tcl_Close(interp, chan); Tcl_SetObjResult(interp, Tcl_ObjPrintf( "couldn't read file \"%s\": %s", - Tcl_GetString(pathPtr), Tcl_PosixError(interp))); + TclGetString(pathPtr), Tcl_PosixError(interp))); Tcl_DecrRefCount(objPtr); return TCL_ERROR; } @@ -2017,14 +2017,14 @@ EvalFileCallback( * Record information telling where the error occurred. */ - int length; + size_t length; const char *pathString = TclGetStringFromObj(pathPtr, &length); - const int limit = 150; + const unsigned int limit = 150; int overflow = (length > limit); Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( "\n (file \"%.*s%s\" line %d)", - (overflow ? limit : length), pathString, + (overflow ? limit : (unsigned int)length), pathString, (overflow ? "..." : ""), Tcl_GetErrorLine(interp))); } @@ -2301,7 +2301,7 @@ Tcl_FSOpenFileChannel( if (interp != NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "could not seek to end of file while opening \"%s\": %s", - Tcl_GetString(pathPtr), Tcl_PosixError(interp))); + TclGetString(pathPtr), Tcl_PosixError(interp))); } Tcl_Close(NULL, retVal); return NULL; @@ -2320,7 +2320,7 @@ Tcl_FSOpenFileChannel( if (interp != NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "couldn't open \"%s\": %s", - Tcl_GetString(pathPtr), Tcl_PosixError(interp))); + TclGetString(pathPtr), Tcl_PosixError(interp))); } return NULL; } @@ -2868,7 +2868,7 @@ Tcl_FSGetCwd( * bug when trying to normalize tsdPtr->cwdPathPtr. */ - int len1, len2; + size_t len1, len2; const char *str1, *str2; str1 = TclGetStringFromObj(tsdPtr->cwdPathPtr, &len1); @@ -3228,7 +3228,7 @@ skipUnlink( #ifndef AUFS_SUPER_MAGIC #define AUFS_SUPER_MAGIC ('a' << 24 | 'u' << 16 | 'f' << 8 | 's') #endif /* AUFS_SUPER_MAGIC */ - if ((statfs(Tcl_GetString(shlibFile), &fs) == 0) + if ((statfs(TclGetString(shlibFile), &fs) == 0) && (fs.f_type == AUFS_SUPER_MAGIC)) { return 1; } @@ -3304,7 +3304,7 @@ Tcl_LoadFile( if (interp) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "couldn't load library \"%s\": %s", - Tcl_GetString(pathPtr), Tcl_PosixError(interp))); + TclGetString(pathPtr), Tcl_PosixError(interp))); } return TCL_ERROR; } @@ -4034,7 +4034,7 @@ Tcl_FSSplitPath( if (sep != NULL) { Tcl_IncrRefCount(sep); - separator = Tcl_GetString(sep)[0]; + separator = TclGetString(sep)[0]; Tcl_DecrRefCount(sep); } } @@ -4046,7 +4046,7 @@ Tcl_FSSplitPath( */ result = Tcl_NewObj(); - p = Tcl_GetString(pathPtr); + p = TclGetString(pathPtr); Tcl_ListObjAppendElement(NULL, result, Tcl_NewStringObj(p, driveNameLength)); p += driveNameLength; @@ -4123,7 +4123,7 @@ TclGetPathType( * path, already with a refCount for the * caller. */ { - int pathLen; + size_t pathLen; const char *path = TclGetStringFromObj(pathPtr, &pathLen); Tcl_PathType type; @@ -4231,16 +4231,16 @@ TclFSNonnativePathType( } while (numVolumes > 0) { Tcl_Obj *vol; - int len; + size_t len; const char *strVol; numVolumes--; Tcl_ListObjIndex(NULL, thisFsVolumes, numVolumes, &vol); strVol = TclGetStringFromObj(vol,&len); - if (pathLen < len) { + if ((size_t) pathLen < len) { continue; } - if (strncmp(strVol, path, (size_t) len) == 0) { + if (strncmp(strVol, path, len) == 0) { type = TCL_PATH_ABSOLUTE; if (filesystemPtrPtr != NULL) { *filesystemPtrPtr = fsRecPtr->fsPtr; @@ -4579,14 +4579,14 @@ Tcl_FSRemoveDirectory( if (cwdPtr != NULL) { const char *cwdStr, *normPathStr; - int cwdLen, normLen; + size_t cwdLen, normLen; Tcl_Obj *normPath = Tcl_FSGetNormalizedPath(NULL, pathPtr); if (normPath != NULL) { normPathStr = TclGetStringFromObj(normPath, &normLen); cwdStr = TclGetStringFromObj(cwdPtr, &cwdLen); if ((cwdLen >= normLen) && (strncmp(normPathStr, cwdStr, - (size_t) normLen) == 0)) { + normLen) == 0)) { /* * The cwd is inside the directory, so we perform a 'cd * [file dirname $path]'. diff --git a/generic/tclIndexObj.c b/generic/tclIndexObj.c index 33656d6..eec6efa 100644 --- a/generic/tclIndexObj.c +++ b/generic/tclIndexObj.c @@ -143,7 +143,7 @@ GetIndexFromObjList( return TCL_OK; } - tablePtr[t] = Tcl_GetString(objv[t]); + tablePtr[t] = TclGetString(objv[t]); } tablePtr[objc] = NULL; @@ -544,7 +544,7 @@ PrefixMatchObjCmd( return TCL_ERROR; } i++; - message = Tcl_GetString(objv[i]); + message = TclGetString(objv[i]); break; case PRFMATCH_ERROR: if (i > objc-4) { @@ -634,7 +634,8 @@ PrefixAllObjCmd( int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - int tableObjc, result, t, length, elemLength; + int tableObjc, result, t; + size_t length, elemLength; const char *string, *elemString; Tcl_Obj **tableObjv, *resultPtr; @@ -691,7 +692,8 @@ PrefixLongestObjCmd( int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - int tableObjc, result, i, t, length, elemLength, resultLength; + int tableObjc, result, t; + size_t i, length, elemLength, resultLength; const char *string, *elemString, *resultString; Tcl_Obj **tableObjv; @@ -1124,7 +1126,7 @@ Tcl_ParseArgsObjv( (int *) infoPtr->dstPtr) == TCL_ERROR) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "expected integer argument for \"%s\" but got \"%s\"", - infoPtr->keyStr, Tcl_GetString(objv[srcIndex]))); + infoPtr->keyStr, TclGetString(objv[srcIndex]))); goto error; } srcIndex++; @@ -1135,7 +1137,7 @@ Tcl_ParseArgsObjv( goto missingArg; } *((const char **) infoPtr->dstPtr) = - Tcl_GetString(objv[srcIndex]); + TclGetString(objv[srcIndex]); srcIndex++; objc--; break; @@ -1157,7 +1159,7 @@ Tcl_ParseArgsObjv( (double *) infoPtr->dstPtr) == TCL_ERROR) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "expected floating-point argument for \"%s\" but got \"%s\"", - infoPtr->keyStr, Tcl_GetString(objv[srcIndex]))); + infoPtr->keyStr, TclGetString(objv[srcIndex]))); goto error; } srcIndex++; diff --git a/generic/tclInt.h b/generic/tclInt.h index c5022c6..4b41ada 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -4394,7 +4394,7 @@ MODULE_SCOPE void TclDbInitNewObj(Tcl_Obj *objPtr, const char *file, #define TclGetByteArrayFromObj(objPtr, lenPtr) \ (Tcl_GetByteArrayFromObj(objPtr, NULL), \ *(lenPtr) = *((size_t *) (objPtr)->internalRep.twoPtrValue.ptr1), \ - Tcl_GetByteArrayFromObj(objPtr, NULL)) + (unsigned char *)(((size_t *) (objPtr)->internalRep.twoPtrValue.ptr1) + 2)) #endif /* @@ -4492,19 +4492,19 @@ MODULE_SCOPE void TclDbInitNewObj(Tcl_Obj *objPtr, const char *file, allocated = TCL_MAX_TOKENS; \ } \ newPtr = (Tcl_Token *) Tcl_AttemptRealloc((char *) oldPtr, \ - (unsigned int) (allocated * sizeof(Tcl_Token))); \ + (allocated * sizeof(Tcl_Token))); \ if (newPtr == NULL) { \ allocated = _needed + (append) + TCL_MIN_TOKEN_GROWTH; \ if (allocated > TCL_MAX_TOKENS) { \ allocated = TCL_MAX_TOKENS; \ } \ newPtr = (Tcl_Token *) Tcl_Realloc((char *) oldPtr, \ - (unsigned int) (allocated * sizeof(Tcl_Token))); \ + (allocated * sizeof(Tcl_Token))); \ } \ (available) = allocated; \ if (oldPtr == NULL) { \ memcpy(newPtr, staticPtr, \ - (size_t) ((used) * sizeof(Tcl_Token))); \ + ((used) * sizeof(Tcl_Token))); \ } \ (tokenPtr) = newPtr; \ } \ diff --git a/generic/tclInterp.c b/generic/tclInterp.c index dd9fec8..6b28ff2 100644 --- a/generic/tclInterp.c +++ b/generic/tclInterp.c @@ -786,7 +786,7 @@ NRInterpCmd( slavePtr = NULL; last = 0; for (i = 2; i < objc; i++) { - if ((last == 0) && (Tcl_GetString(objv[i])[0] == '-')) { + if ((last == 0) && (TclGetString(objv[i])[0] == '-')) { if (Tcl_GetIndexFromObj(interp, objv[i], createOptions, "option", 0, &index) != TCL_OK) { return TCL_ERROR; @@ -1100,7 +1100,7 @@ NRInterpCmd( if (hPtr == NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "alias \"%s\" in path \"%s\" not found", - aliasName, Tcl_GetString(objv[2]))); + aliasName, TclGetString(objv[2]))); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ALIAS", aliasName, NULL); return TCL_ERROR; @@ -1109,7 +1109,7 @@ NRInterpCmd( if (Tcl_GetInterpPath(interp, aliasPtr->targetInterp) != TCL_OK) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "target interpreter for alias \"%s\" in path \"%s\" is " - "not my descendant", aliasName, Tcl_GetString(objv[2]))); + "not my descendant", aliasName, TclGetString(objv[2]))); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP", "TARGETSHROUDED", NULL); return TCL_ERROR; @@ -1727,7 +1727,7 @@ AliasDescribe( */ slavePtr = &((InterpInfo *) ((Interp *) slaveInterp)->interpInfo)->slave; - hPtr = Tcl_FindHashEntry(&slavePtr->aliasTable, Tcl_GetString(namePtr)); + hPtr = Tcl_FindHashEntry(&slavePtr->aliasTable, TclGetString(namePtr)); if (hPtr == NULL) { return TCL_OK; } diff --git a/generic/tclLink.c b/generic/tclLink.c index 1ae8501..1ca9215 100644 --- a/generic/tclLink.c +++ b/generic/tclLink.c @@ -293,7 +293,7 @@ LinkTraceProc( } else if (flags & TCL_TRACE_DESTROYED) { Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr), TCL_GLOBAL_ONLY); - Tcl_TraceVar2(interp, Tcl_GetString(linkPtr->varName), NULL, + Tcl_TraceVar2(interp, TclGetString(linkPtr->varName), NULL, TCL_GLOBAL_ONLY|TCL_TRACE_READS|TCL_TRACE_WRITES |TCL_TRACE_UNSETS, LinkTraceProc, linkPtr); } diff --git a/generic/tclListObj.c b/generic/tclListObj.c index 504af4b..85f391c 100644 --- a/generic/tclListObj.c +++ b/generic/tclListObj.c @@ -536,9 +536,10 @@ Tcl_ListObjGetElements( ListGetIntRep(listPtr, listRepPtr); if (listRepPtr == NULL) { - int result, length; + int result; + size_t length; - (void) Tcl_GetStringFromObj(listPtr, &length); + (void) TclGetStringFromObj(listPtr, &length); if (length == 0) { *objcPtr = 0; *objvPtr = NULL; @@ -659,9 +660,10 @@ Tcl_ListObjAppendElement( ListGetIntRep(listPtr, listRepPtr); if (listRepPtr == NULL) { - int result, length; + int result; + size_t length; - (void) Tcl_GetStringFromObj(listPtr, &length); + (void) TclGetStringFromObj(listPtr, &length); if (length == 0) { Tcl_SetListObj(listPtr, 1, &objPtr); return TCL_OK; @@ -833,9 +835,10 @@ Tcl_ListObjIndex( ListGetIntRep(listPtr, listRepPtr); if (listRepPtr == NULL) { - int result, length; + int result; + size_t length; - (void) Tcl_GetStringFromObj(listPtr, &length); + (void) TclGetStringFromObj(listPtr, &length); if (length == 0) { *objPtrPtr = NULL; return TCL_OK; @@ -889,9 +892,10 @@ Tcl_ListObjLength( ListGetIntRep(listPtr, listRepPtr); if (listRepPtr == NULL) { - int result, length; + int result; + size_t length; - (void) Tcl_GetStringFromObj(listPtr, &length); + (void) TclGetStringFromObj(listPtr, &length); if (length == 0) { *intPtr = 0; return TCL_OK; @@ -1775,9 +1779,10 @@ TclListObjSetElement( ListGetIntRep(listPtr, listRepPtr); if (listRepPtr == NULL) { - int result, length; + int result; + size_t length; - (void) Tcl_GetStringFromObj(listPtr, &length); + (void) TclGetStringFromObj(listPtr, &length); if (length == 0) { if (interp != NULL) { Tcl_SetObjResult(interp, @@ -2011,7 +2016,8 @@ SetListFromAny( Tcl_DictObjNext(&search, &keyPtr, &valuePtr, &done); } } else { - int estCount, length; + int estCount; + size_t length; const char *limit, *nextElem = TclGetStringFromObj(objPtr, &length); /* diff --git a/generic/tclLoad.c b/generic/tclLoad.c index ce8a85f..062e1a0 100644 --- a/generic/tclLoad.c +++ b/generic/tclLoad.c @@ -165,7 +165,7 @@ Tcl_LoadObjCmd( if (Tcl_FSConvertToPathType(interp, objv[1]) != TCL_OK) { return TCL_ERROR; } - fullFileName = Tcl_GetString(objv[1]); + fullFileName = TclGetString(objv[1]); Tcl_DStringInit(&pkgName); Tcl_DStringInit(&initName); @@ -176,7 +176,7 @@ Tcl_LoadObjCmd( packageName = NULL; if (objc >= 3) { - packageName = Tcl_GetString(objv[2]); + packageName = TclGetString(objv[2]); if (packageName[0] == '\0') { packageName = NULL; } @@ -196,7 +196,7 @@ Tcl_LoadObjCmd( target = interp; if (objc == 4) { - const char *slaveIntName = Tcl_GetString(objv[3]); + const char *slaveIntName = TclGetString(objv[3]); target = Tcl_GetSlave(interp, slaveIntName); if (target == NULL) { @@ -324,7 +324,7 @@ Tcl_LoadObjCmd( splitPtr = Tcl_FSSplitPath(objv[1], &pElements); Tcl_ListObjIndex(NULL, splitPtr, pElements -1, &pkgGuessPtr); - pkgGuess = Tcl_GetString(pkgGuessPtr); + pkgGuess = TclGetString(pkgGuessPtr); if ((pkgGuess[0] == 'l') && (pkgGuess[1] == 'i') && (pkgGuess[2] == 'b')) { pkgGuess += 3; @@ -564,7 +564,7 @@ Tcl_UnloadObjCmd( for (i = 1; i < objc; i++) { if (Tcl_GetIndexFromObj(interp, objv[i], options, "option", 0, &index) != TCL_OK) { - fullFileName = Tcl_GetString(objv[i]); + fullFileName = TclGetString(objv[i]); if (fullFileName[0] == '-') { /* * It looks like the command contains an option so signal an @@ -604,13 +604,13 @@ Tcl_UnloadObjCmd( return TCL_ERROR; } - fullFileName = Tcl_GetString(objv[i]); + fullFileName = TclGetString(objv[i]); Tcl_DStringInit(&pkgName); Tcl_DStringInit(&tmp); packageName = NULL; if (objc - i >= 2) { - packageName = Tcl_GetString(objv[i+1]); + packageName = TclGetString(objv[i+1]); if (packageName[0] == '\0') { packageName = NULL; } @@ -630,7 +630,7 @@ Tcl_UnloadObjCmd( target = interp; if (objc - i == 3) { - const char *slaveIntName = Tcl_GetString(objv[i + 2]); + const char *slaveIntName = TclGetString(objv[i + 2]); target = Tcl_GetSlave(interp, slaveIntName); if (target == NULL) { diff --git a/generic/tclMain.c b/generic/tclMain.c index f85f8aa..c4afcd9 100644 --- a/generic/tclMain.c +++ b/generic/tclMain.c @@ -215,7 +215,7 @@ Tcl_GetStartupScript( if (tsdPtr->encoding == NULL) { *encodingPtr = NULL; } else { - *encodingPtr = Tcl_GetString(tsdPtr->encoding); + *encodingPtr = TclGetString(tsdPtr->encoding); } } return tsdPtr->path; @@ -343,7 +343,7 @@ Tcl_MainEx( && ('-' != argv[3][0])) { Tcl_Obj *value = NewNativeObj(argv[2], -1); Tcl_SetStartupScript(NewNativeObj(argv[3], -1), - Tcl_GetString(value)); + TclGetString(value)); Tcl_DecrRefCount(value); argc -= 3; argv += 3; @@ -488,7 +488,7 @@ Tcl_MainEx( Tcl_IncrRefCount(is.commandPtr); } length = Tcl_GetsObj(is.input, is.commandPtr); - if (length == (size_t)-1) { + if (length == TCL_AUTO_LENGTH) { if (Tcl_InputBlocked(is.input)) { /* * This can only happen if stdin has been set to @@ -766,7 +766,7 @@ StdinProc( Tcl_IncrRefCount(commandPtr); } length = Tcl_GetsObj(chan, commandPtr); - if (length == (size_t)-1) { + if (length == TCL_AUTO_LENGTH) { if (Tcl_InputBlocked(chan)) { return; } diff --git a/generic/tclNamesp.c b/generic/tclNamesp.c index 48a0e34..3c23b97 100644 --- a/generic/tclNamesp.c +++ b/generic/tclNamesp.c @@ -3570,7 +3570,7 @@ NamespaceExportCmd( */ firstArg = 1; - if (strcmp("-clear", Tcl_GetString(objv[firstArg])) == 0) { + if (strcmp("-clear", TclGetString(objv[firstArg])) == 0) { Tcl_Export(interp, NULL, "::", 1); Tcl_ResetResult(interp); firstArg++; @@ -3581,7 +3581,7 @@ NamespaceExportCmd( */ for (i = firstArg; i < objc; i++) { - int result = Tcl_Export(interp, NULL, Tcl_GetString(objv[i]), 0); + int result = Tcl_Export(interp, NULL, TclGetString(objv[i]), 0); if (result != TCL_OK) { return result; } diff --git a/generic/tclOOBasic.c b/generic/tclOOBasic.c index 60e7456..72b755b 100644 --- a/generic/tclOOBasic.c +++ b/generic/tclOOBasic.c @@ -744,7 +744,7 @@ TclOO_Object_VarName( return TCL_ERROR; } argPtr = objv[objc-1]; - arg = Tcl_GetString(argPtr); + arg = TclGetString(argPtr); /* * Convert the variable name to fully-qualified form if it wasn't already. @@ -781,8 +781,8 @@ TclOO_Object_VarName( if (mPtr->declaringObjectPtr == oPtr) { FOREACH_STRUCT(pvPtr, oPtr->privateVariables) { - if (!strcmp(Tcl_GetString(pvPtr->variableObj), - Tcl_GetString(argPtr))) { + if (!strcmp(TclGetString(pvPtr->variableObj), + TclGetString(argPtr))) { argPtr = pvPtr->fullNameObj; break; } @@ -803,8 +803,8 @@ TclOO_Object_VarName( } if (isInstance) { FOREACH_STRUCT(pvPtr, clsPtr->privateVariables) { - if (!strcmp(Tcl_GetString(pvPtr->variableObj), - Tcl_GetString(argPtr))) { + if (!strcmp(TclGetString(pvPtr->variableObj), + TclGetString(argPtr))) { argPtr = pvPtr->fullNameObj; break; } diff --git a/generic/tclOODefineCmds.c b/generic/tclOODefineCmds.c index 28ea4b5..6685f08 100644 --- a/generic/tclOODefineCmds.c +++ b/generic/tclOODefineCmds.c @@ -556,7 +556,7 @@ InstallPrivateVariableMapping( privatePtr->variableObj = varv[i]; privatePtr->fullNameObj = Tcl_ObjPrintf( PRIVATE_VARIABLE_PATTERN, - creationEpoch, Tcl_GetString(varv[i])); + creationEpoch, TclGetString(varv[i])); Tcl_IncrRefCount(privatePtr->fullNameObj); } else { Tcl_DecrRefCount(varv[i]); @@ -1620,7 +1620,7 @@ TclOODefineDefnNsObjCmd( &kind) != TCL_OK) { return TCL_ERROR; } - if (!Tcl_GetString(objv[objc - 1])[0]) { + if (!TclGetString(objv[objc - 1])[0]) { nsNamePtr = NULL; } else { nsPtr = GetNamespaceInOuterContext(interp, objv[objc - 1]); diff --git a/generic/tclOOInfo.c b/generic/tclOOInfo.c index faf3676..f9767a7 100644 --- a/generic/tclOOInfo.c +++ b/generic/tclOOInfo.c @@ -816,7 +816,7 @@ InfoObjectVariablesCmd( return TCL_ERROR; } if (objc == 3) { - if (strcmp("-private", Tcl_GetString(objv[2])) != 0) { + if (strcmp("-private", TclGetString(objv[2])) != 0) { return TCL_ERROR; } private = 1; @@ -1595,7 +1595,7 @@ InfoClassVariablesCmd( return TCL_ERROR; } if (objc == 3) { - if (strcmp("-private", Tcl_GetString(objv[2])) != 0) { + if (strcmp("-private", TclGetString(objv[2])) != 0) { return TCL_ERROR; } private = 1; diff --git a/generic/tclOOMethod.c b/generic/tclOOMethod.c index fa3cd6c..fa5cbc9 100644 --- a/generic/tclOOMethod.c +++ b/generic/tclOOMethod.c @@ -1120,8 +1120,8 @@ ProcedureMethodCompiledVarResolver( * which look like array accesses. Both will lead us astray. */ - if (strstr(Tcl_GetString(variableObj), "::") != NULL || - Tcl_StringMatch(Tcl_GetString(variableObj), "*(*)")) { + if (strstr(TclGetString(variableObj), "::") != NULL || + Tcl_StringMatch(TclGetString(variableObj), "*(*)")) { Tcl_DecrRefCount(variableObj); return TCL_CONTINUE; } @@ -1338,7 +1338,7 @@ CloneProcedureMethod( */ bodyObj = Tcl_DuplicateObj(pmPtr->procPtr->bodyPtr); - Tcl_GetString(bodyObj); + TclGetString(bodyObj); Tcl_StoreIntRep(pmPtr->procPtr->bodyPtr, &tclByteCodeType, NULL); /* diff --git a/generic/tclPathObj.c b/generic/tclPathObj.c index d53b05c..b500c7e 100644 --- a/generic/tclPathObj.c +++ b/generic/tclPathObj.c @@ -916,7 +916,7 @@ TclJoinPath( */ if ((tclPlatform != TCL_PLATFORM_WINDOWS) - || (strchr(Tcl_GetString(elt), '\\') == NULL)) { + || (strchr(TclGetString(elt), '\\') == NULL)) { if (PATHFLAGS(elt)) { return TclNewFSPathObj(elt, str, len); @@ -952,7 +952,8 @@ TclJoinPath( assert ( res == NULL ); for (i = 0; i < elements; i++) { - int driveNameLength, strEltLen, length; + int driveNameLength; + size_t strEltLen, length; Tcl_PathType type; char *strElt, *ptr; Tcl_Obj *driveName = NULL; @@ -1407,7 +1408,7 @@ TclFSMakePathRelative( Tcl_Obj *pathPtr, /* The path we have. */ Tcl_Obj *cwdPtr) /* Make it relative to this. */ { - int cwdLen, len; + size_t cwdLen, len; const char *tempStr; Tcl_ObjIntRep *irPtr = TclFetchIntRep(pathPtr, &fsPathType); @@ -1677,11 +1678,11 @@ Tcl_FSGetTranslatedStringPath( Tcl_Obj *transPtr = Tcl_FSGetTranslatedPath(interp, pathPtr); if (transPtr != NULL) { - int len; + size_t len; const char *orig = TclGetStringFromObj(transPtr, &len); char *result = Tcl_Alloc(len+1); - memcpy(result, orig, (size_t) len+1); + memcpy(result, orig, len+1); TclDecrRefCount(transPtr); return result; } @@ -1727,7 +1728,8 @@ Tcl_FSGetNormalizedPath( */ Tcl_Obj *dir, *copy; - int tailLen, cwdLen, pathType; + size_t tailLen, cwdLen; + int pathType; pathType = Tcl_FSGetPathType(fsPathPtr->cwdPtr); dir = Tcl_FSGetNormalizedPath(interp, fsPathPtr->cwdPtr); @@ -1843,7 +1845,7 @@ Tcl_FSGetNormalizedPath( copy = AppendPath(fsPathPtr->cwdPtr, pathPtr); (void) TclGetStringFromObj(fsPathPtr->cwdPtr, &cwdLen); - cwdLen += (Tcl_GetString(copy)[cwdLen] == '/'); + cwdLen += (TclGetString(copy)[cwdLen] == '/'); /* * Normalize the combined string, but only starting after the end @@ -2364,7 +2366,8 @@ SetFsPathFromAny( objc--; objv++; while (objc--) { - TclpNativeJoinPath(transPtr, Tcl_GetString(*objv++)); + TclpNativeJoinPath(transPtr, TclGetString(*objv)); + objv++; } TclDecrRefCount(parts); } else { diff --git a/generic/tclPkg.c b/generic/tclPkg.c index ed04cb1..8966387 100644 --- a/generic/tclPkg.c +++ b/generic/tclPkg.c @@ -1007,7 +1007,7 @@ TclNRPackageObjCmd( } pkgFiles = (PkgFiles *) Tcl_GetAssocData(interp, "tclPkgFiles", NULL); if (pkgFiles) { - Tcl_HashEntry *entry = Tcl_FindHashEntry(&pkgFiles->table, Tcl_GetString(objv[2])); + Tcl_HashEntry *entry = Tcl_FindHashEntry(&pkgFiles->table, TclGetString(objv[2])); if (entry) { Tcl_SetObjResult(interp, (Tcl_Obj *)Tcl_GetHashValue(entry)); } diff --git a/generic/tclProc.c b/generic/tclProc.c index f4d2210..d12e0f2 100644 --- a/generic/tclProc.c +++ b/generic/tclProc.c @@ -329,7 +329,7 @@ Tcl_ProcObjCmd( * of all procs whose argument list is just _args_ */ - if (TclFetchIntRep(objv[3], &tclProcBodyType)) { + if (objv[3]->typePtr == &tclProcBodyType) { goto done; } @@ -553,7 +553,7 @@ TclCreateProc( if (*argnamelast == ')') { /* We have an array element. */ Tcl_SetObjResult(interp, Tcl_ObjPrintf( "formal parameter \"%s\" is an array element", - Tcl_GetString(fieldValues[0]))); + TclGetString(fieldValues[0]))); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC", "FORMALARGUMENTFORMAT", NULL); goto procError; @@ -2423,7 +2423,7 @@ SetLambdaFromAny( if ((result != TCL_OK) || ((objc != 2) && (objc != 3))) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "can't interpret \"%s\" as a lambda expression", - Tcl_GetString(objPtr))); + TclGetString(objPtr))); Tcl_SetErrorCode(interp, "TCL", "VALUE", "LAMBDA", NULL); return TCL_ERROR; } diff --git a/generic/tclResult.c b/generic/tclResult.c index 76ba02a..a4df031 100644 --- a/generic/tclResult.c +++ b/generic/tclResult.c @@ -230,7 +230,7 @@ Tcl_GetStringResult( { Interp *iPtr = (Interp *) interp; - return Tcl_GetString(iPtr->objResultPtr); + return TclGetString(iPtr->objResultPtr); } /* diff --git a/generic/tclScan.c b/generic/tclScan.c index bf611fc..1d7edf9 100644 --- a/generic/tclScan.c +++ b/generic/tclScan.c @@ -589,7 +589,7 @@ Tcl_ScanObjCmd( return TCL_ERROR; } - format = Tcl_GetString(objv[2]); + format = TclGetString(objv[2]); numVars = objc-3; /* @@ -611,7 +611,7 @@ Tcl_ScanObjCmd( } } - string = Tcl_GetString(objv[1]); + string = TclGetString(objv[1]); baseString = string; /* diff --git a/generic/tclStringObj.c b/generic/tclStringObj.c index 9537490..0bae9f0 100644 --- a/generic/tclStringObj.c +++ b/generic/tclStringObj.c @@ -2642,7 +2642,7 @@ AppendPrintfToObjVA( if (code != TCL_OK) { Tcl_AppendPrintfToObj(objPtr, "Unable to format \"%s\" with supplied arguments: %s", - format, Tcl_GetString(list)); + format, TclGetString(list)); } Tcl_DecrRefCount(list); } @@ -2784,10 +2784,10 @@ TclStringRepeat( if (binary) { /* Result will be pure byte array. Pre-size it */ - TclGetByteArrayFromObj(objPtr, &length); + (void)TclGetByteArrayFromObj(objPtr, &length); } else if (unichar) { /* Result will be pure Tcl_UniChar array. Pre-size it. */ - TclGetUnicodeFromObj(objPtr, &length); + (void)TclGetUnicodeFromObj(objPtr, &length); } else { /* Result will be concat of string reps. Pre-size it. */ (void)TclGetStringFromObj(objPtr, &length); @@ -2856,7 +2856,7 @@ TclStringRepeat( */ if (!inPlace || Tcl_IsShared(objPtr)) { - objResultPtr = Tcl_NewStringObj(Tcl_GetString(objPtr), length); + objResultPtr = Tcl_NewStringObj(TclGetString(objPtr), length); } else { TclFreeIntRep(objPtr); objResultPtr = objPtr; @@ -2875,7 +2875,7 @@ TclStringRepeat( Tcl_AppendObjToObj(objResultPtr, objResultPtr); done *= 2; } - Tcl_AppendToObj(objResultPtr, Tcl_GetString(objResultPtr), + Tcl_AppendToObj(objResultPtr, TclGetString(objResultPtr), (count - done) * length); } return objResultPtr; @@ -2980,7 +2980,7 @@ TclStringCat( */ if (TclIsPureByteArray(objPtr)) { - TclGetByteArrayFromObj(objPtr, &numBytes); /* PANIC? */ + (void)TclGetByteArrayFromObj(objPtr, &numBytes); /* PANIC? */ if (numBytes) { last = objc - oc; @@ -3061,7 +3061,7 @@ TclStringCat( do { Tcl_Obj *objPtr = *ov++; - Tcl_GetString(objPtr); /* PANIC? */ + TclGetString(objPtr); /* PANIC? */ numBytes = objPtr->length; } while (--oc && numBytes == 0 && pendingPtr->bytes == NULL); @@ -3088,7 +3088,7 @@ TclStringCat( /* assert ( length > 0 && pendingPtr == NULL ) */ - Tcl_GetString(objPtr); /* PANIC? */ + TclGetString(objPtr); /* PANIC? */ numBytes = objPtr->length; if (numBytes) { last = objc - oc; @@ -3122,7 +3122,7 @@ TclStringCat( size_t start; objResultPtr = *objv++; objc--; - TclGetByteArrayFromObj(objResultPtr, &start); + (void)TclGetByteArrayFromObj(objResultPtr, &start); dst = Tcl_SetByteArrayLength(objResultPtr, length) + start; } else { objResultPtr = Tcl_NewByteArrayObj(NULL, length); @@ -3214,7 +3214,7 @@ TclStringCat( } return NULL; } - dst = Tcl_GetString(objResultPtr) + start; + dst = TclGetString(objResultPtr) + start; /* assert ( length > start ) */ TclFreeIntRep(objResultPtr); @@ -3230,7 +3230,7 @@ TclStringCat( } return NULL; } - dst = Tcl_GetString(objResultPtr); + dst = TclGetString(objResultPtr); } while (objc--) { Tcl_Obj *objPtr = *objv++; diff --git a/generic/tclTest.c b/generic/tclTest.c index 08669db..277322a 100644 --- a/generic/tclTest.c +++ b/generic/tclTest.c @@ -976,7 +976,7 @@ AsyncHandlerProc( TclFormatInt(string, code); listArgv[0] = asyncPtr->command; - listArgv[1] = Tcl_GetString(Tcl_GetObjResult(interp)); + listArgv[1] = Tcl_GetStringResult(interp); listArgv[2] = string; listArgv[3] = NULL; cmd = Tcl_Merge(3, listArgv); diff --git a/generic/tclTimer.c b/generic/tclTimer.c index 0dbf834..0833722 100644 --- a/generic/tclTimer.c +++ b/generic/tclTimer.c @@ -821,7 +821,7 @@ Tcl_AfterObjCmd( if (Tcl_GetWideIntFromObj(NULL, objv[1], &ms) != TCL_OK) { if (Tcl_GetIndexFromObj(NULL, objv[1], afterSubCmds, "", 0, &index) != TCL_OK) { - const char *arg = Tcl_GetString(objv[1]); + const char *arg = TclGetString(objv[1]); Tcl_SetObjResult(interp, Tcl_ObjPrintf( "bad argument \"%s\": must be" diff --git a/generic/tclTrace.c b/generic/tclTrace.c index 13b7528..c60babb 100644 --- a/generic/tclTrace.c +++ b/generic/tclTrace.c @@ -324,7 +324,7 @@ Tcl_TraceObjCmd( return TCL_ERROR; } resultListPtr = Tcl_NewObj(); - name = Tcl_GetString(objv[2]); + name = TclGetString(objv[2]); FOREACH_VAR_TRACE(interp, name, clientData) { TraceVarInfo *tvarPtr = clientData; char *q = ops; @@ -485,7 +485,7 @@ TraceExecutionObjCmd( flags |= (TCL_TRACE_ENTER_EXEC | TCL_TRACE_LEAVE_EXEC); } memcpy(tcmdPtr->command, command, length+1); - name = Tcl_GetString(objv[3]); + name = TclGetString(objv[3]); if (Tcl_TraceCommand(interp, name, flags, TraceCommandProc, tcmdPtr) != TCL_OK) { Tcl_Free(tcmdPtr); @@ -504,7 +504,7 @@ TraceExecutionObjCmd( * First ensure the name given is valid. */ - name = Tcl_GetString(objv[3]); + name = TclGetString(objv[3]); if (Tcl_FindCommand(interp,name,NULL,TCL_LEAVE_ERR_MSG) == NULL) { return TCL_ERROR; } @@ -565,7 +565,7 @@ TraceExecutionObjCmd( return TCL_ERROR; } - name = Tcl_GetString(objv[3]); + name = TclGetString(objv[3]); /* * First ensure the name given is valid. @@ -718,7 +718,7 @@ TraceCommandObjCmd( tcmdPtr->refCount = 1; flags |= TCL_TRACE_DELETE; memcpy(tcmdPtr->command, command, length+1); - name = Tcl_GetString(objv[3]); + name = TclGetString(objv[3]); if (Tcl_TraceCommand(interp, name, flags, TraceCommandProc, tcmdPtr) != TCL_OK) { Tcl_Free(tcmdPtr); @@ -737,7 +737,7 @@ TraceCommandObjCmd( * First ensure the name given is valid. */ - name = Tcl_GetString(objv[3]); + name = TclGetString(objv[3]); if (Tcl_FindCommand(interp,name,NULL,TCL_LEAVE_ERR_MSG) == NULL) { return TCL_ERROR; } @@ -773,7 +773,7 @@ TraceCommandObjCmd( * First ensure the name given is valid. */ - name = Tcl_GetString(objv[3]); + name = TclGetString(objv[3]); if (Tcl_FindCommand(interp, name, NULL, TCL_LEAVE_ERR_MSG) == NULL) { return TCL_ERROR; } @@ -926,7 +926,7 @@ TraceVariableObjCmd( ctvarPtr->traceInfo.traceProc = TraceVarProc; ctvarPtr->traceInfo.clientData = &ctvarPtr->traceCmdInfo; ctvarPtr->traceInfo.flags = flags; - name = Tcl_GetString(objv[3]); + name = TclGetString(objv[3]); if (TraceVarEx(interp, name, NULL, (VarTrace *) ctvarPtr) != TCL_OK) { Tcl_Free(ctvarPtr); @@ -939,7 +939,7 @@ TraceVariableObjCmd( * first one that matches. */ - name = Tcl_GetString(objv[3]); + name = TclGetString(objv[3]); FOREACH_VAR_TRACE(interp, name, clientData) { TraceVarInfo *tvarPtr = clientData; @@ -969,7 +969,7 @@ TraceVariableObjCmd( } resultListPtr = Tcl_NewObj(); - name = Tcl_GetString(objv[3]); + name = TclGetString(objv[3]); FOREACH_VAR_TRACE(interp, name, clientData) { Tcl_Obj *opObjPtr, *eachTraceObjPtr, *elemObjPtr; TraceVarInfo *tvarPtr = clientData; @@ -1831,7 +1831,7 @@ TraceExecutionProc( Tcl_DStringInit(&sub); for (i = 0; i < objc; i++) { - Tcl_DStringAppendElement(&sub, Tcl_GetString(objv[i])); + Tcl_DStringAppendElement(&sub, TclGetString(objv[i])); } Tcl_DStringAppendElement(&cmd, Tcl_DStringValue(&sub)); Tcl_DStringFree(&sub); @@ -1855,7 +1855,7 @@ TraceExecutionProc( */ resultCode = Tcl_NewIntObj(code); - resultCodeStr = Tcl_GetString(resultCode); + resultCodeStr = TclGetString(resultCode); Tcl_DStringAppendElement(&cmd, resultCodeStr); Tcl_DecrRefCount(resultCode); @@ -2278,7 +2278,7 @@ StringTraceProc( argv = (const char **) TclStackAlloc(interp, (objc + 1) * sizeof(const char *)); for (i = 0; i < objc; i++) { - argv[i] = Tcl_GetString(objv[i]); + argv[i] = TclGetString(objv[i]); } argv[objc] = 0; @@ -2781,7 +2781,7 @@ TclCallVarTraces( (part2 ? ")" : "") )); if (disposeFlags & TCL_TRACE_RESULT_OBJECT) { TclVarErrMsg((Tcl_Interp *) iPtr, part1, part2, verb, - Tcl_GetString((Tcl_Obj *) result)); + TclGetString((Tcl_Obj *) result)); } else { TclVarErrMsg((Tcl_Interp *) iPtr, part1, part2, verb, result); } diff --git a/generic/tclVar.c b/generic/tclVar.c index c4d95b6..308af04 100644 --- a/generic/tclVar.c +++ b/generic/tclVar.c @@ -343,7 +343,7 @@ NotArrayError( Tcl_Interp *interp, Tcl_Obj *name) { - const char *nameStr = Tcl_GetString(name); + const char *nameStr = TclGetString(name); Tcl_SetObjResult(interp, Tcl_ObjPrintf("\"%s\" isn't an array", nameStr)); diff --git a/generic/tclZipfs.c b/generic/tclZipfs.c index c9a58df..2c91161 100644 --- a/generic/tclZipfs.c +++ b/generic/tclZipfs.c @@ -1873,9 +1873,9 @@ ZipFSMountObjCmd( return TCL_ERROR; } - return TclZipfs_Mount(interp, (objc > 1) ? Tcl_GetString(objv[1]) : NULL, - (objc > 2) ? Tcl_GetString(objv[2]) : NULL, - (objc > 3) ? Tcl_GetString(objv[3]) : NULL); + return TclZipfs_Mount(interp, (objc > 1) ? TclGetString(objv[1]) : NULL, + (objc > 2) ? TclGetString(objv[2]) : NULL, + (objc > 3) ? TclGetString(objv[3]) : NULL); } /* @@ -1918,7 +1918,7 @@ ZipFSMountBufferObjCmd( return ret; } - mountPoint = Tcl_GetString(objv[1]); + mountPoint = TclGetString(objv[1]); if (objc < 3) { ReadLock(); DescribeMounted(interp, mountPoint); @@ -1984,7 +1984,7 @@ ZipFSUnmountObjCmd( Tcl_WrongNumArgs(interp, 1, objv, "zipfile"); return TCL_ERROR; } - return TclZipfs_Unmount(interp, Tcl_GetString(objv[1])); + return TclZipfs_Unmount(interp, TclGetString(objv[1])); } /* @@ -2018,7 +2018,7 @@ ZipFSMkKeyObjCmd( Tcl_WrongNumArgs(interp, 1, objv, "password"); return TCL_ERROR; } - pw = Tcl_GetString(objv[1]); + pw = TclGetString(objv[1]); len = strlen(pw); if (len == 0) { return TCL_OK; @@ -2453,7 +2453,7 @@ ZipFSMkZipOrImgObjCmd( passBuf[0] = 0; if (objc > (isList ? 3 : 4)) { - pw = Tcl_GetString(objv[isList ? 3 : 4]); + pw = TclGetString(objv[isList ? 3 : 4]); pwlen = strlen(pw); if ((pwlen > 255) || strchr(pw, 0xff)) { Tcl_SetObjResult(interp, @@ -2497,7 +2497,7 @@ ZipFSMkZipOrImgObjCmd( Tcl_SetErrorCode(interp, "TCL", "ZIPFS", "EMPTY", NULL); return TCL_ERROR; } - out = Tcl_OpenFileChannel(interp, Tcl_GetString(objv[1]), "wb", 0755); + out = Tcl_OpenFileChannel(interp, TclGetString(objv[1]), "wb", 0755); if (out == NULL) { Tcl_DecrRefCount(list); return TCL_ERROR; @@ -2512,10 +2512,10 @@ ZipFSMkZipOrImgObjCmd( const char *imgName; if (isList) { - imgName = (objc > 4) ? Tcl_GetString(objv[4]) : + imgName = (objc > 4) ? TclGetString(objv[4]) : Tcl_GetNameOfExecutable(); } else { - imgName = (objc > 5) ? Tcl_GetString(objv[5]) : + imgName = (objc > 5) ? TclGetString(objv[5]) : Tcl_GetNameOfExecutable(); } if (pwlen) { @@ -2645,15 +2645,15 @@ ZipFSMkZipOrImgObjCmd( Tcl_InitHashTable(&fileHash, TCL_STRING_KEYS); pos[0] = Tcl_Tell(out); if (!isList && (objc > 3)) { - strip = Tcl_GetString(objv[3]); + strip = TclGetString(objv[3]); slen = strlen(strip); } for (i = 0; i < (size_t) lobjc; i += (isList ? 2 : 1)) { const char *path, *name; - path = Tcl_GetString(lobjv[i]); + path = TclGetString(lobjv[i]); if (isList) { - name = Tcl_GetString(lobjv[i + 1]); + name = TclGetString(lobjv[i + 1]); } else { name = path; if (slen > 0) { @@ -2680,9 +2680,9 @@ ZipFSMkZipOrImgObjCmd( for (i = 0; i < (size_t) lobjc; i += (isList ? 2 : 1)) { const char *path, *name; - path = Tcl_GetString(lobjv[i]); + path = TclGetString(lobjv[i]); if (isList) { - name = Tcl_GetString(lobjv[i + 1]); + name = TclGetString(lobjv[i + 1]); } else { name = path; if (slen > 0) { @@ -2916,11 +2916,11 @@ ZipFSCanonicalObjCmd( } Tcl_DStringInit(&dPath); if (objc == 2) { - filename = Tcl_GetString(objv[1]); + filename = TclGetString(objv[1]); result = CanonicalPath("", filename, &dPath, 1); } else if (objc == 3) { - mntpoint = Tcl_GetString(objv[1]); - filename = Tcl_GetString(objv[2]); + mntpoint = TclGetString(objv[1]); + filename = TclGetString(objv[2]); result = CanonicalPath(mntpoint, filename, &dPath, 1); } else { int zipfs = 0; @@ -2928,8 +2928,8 @@ ZipFSCanonicalObjCmd( if (Tcl_GetBooleanFromObj(interp, objv[3], &zipfs)) { return TCL_ERROR; } - mntpoint = Tcl_GetString(objv[1]); - filename = Tcl_GetString(objv[2]); + mntpoint = TclGetString(objv[1]); + filename = TclGetString(objv[2]); result = CanonicalPath(mntpoint, filename, &dPath, zipfs); } Tcl_SetObjResult(interp, Tcl_NewStringObj(result, -1)); @@ -2974,7 +2974,7 @@ ZipFSExistsObjCmd( * Prepend ZIPFS_VOLUME to filename, eliding the final / */ - filename = Tcl_GetString(objv[1]); + filename = TclGetString(objv[1]); Tcl_DStringInit(&ds); Tcl_DStringAppend(&ds, ZIPFS_VOLUME, ZIPFS_VOLUME_LEN - 1); Tcl_DStringAppend(&ds, filename, -1); @@ -3021,7 +3021,7 @@ ZipFSInfoObjCmd( Tcl_WrongNumArgs(interp, 1, objv, "filename"); return TCL_ERROR; } - filename = Tcl_GetString(objv[1]); + filename = TclGetString(objv[1]); ReadLock(); z = ZipFSLookup(filename); if (z) { @@ -3075,13 +3075,13 @@ ZipFSListObjCmd( return TCL_ERROR; } if (objc == 3) { - int n; - char *what = Tcl_GetStringFromObj(objv[1], &n); + size_t n; + char *what = TclGetStringFromObj(objv[1], &n); if ((n >= 2) && (strncmp(what, "-glob", n) == 0)) { - pattern = Tcl_GetString(objv[2]); + pattern = TclGetString(objv[2]); } else if ((n >= 2) && (strncmp(what, "-regexp", n) == 0)) { - regexp = Tcl_RegExpCompile(interp, Tcl_GetString(objv[2])); + regexp = Tcl_RegExpCompile(interp, TclGetString(objv[2])); if (!regexp) { return TCL_ERROR; } @@ -3092,7 +3092,7 @@ ZipFSListObjCmd( return TCL_ERROR; } } else if (objc == 2) { - pattern = Tcl_GetString(objv[1]); + pattern = TclGetString(objv[1]); } ReadLock(); if (pattern) { @@ -3709,7 +3709,7 @@ ZipChannelOpen( if (trunc) { info->numBytes = 0; } else if (z->data) { - unsigned int j = z->numBytes; + size_t j = z->numBytes; if (j > info->maxWrite) { j = info->maxWrite; @@ -3747,7 +3747,7 @@ ZipChannelOpen( stream.opaque = Z_NULL; stream.avail_in = z->numCompressedBytes; if (z->isEncrypted) { - unsigned int j; + size_t j; stream.avail_in -= 12; cbuf = Tcl_AttemptAlloc(stream.avail_in); @@ -3841,7 +3841,7 @@ ZipChannelOpen( z_stream stream; int err; unsigned char *ubuf = NULL; - unsigned int j; + size_t j; memset(&stream, 0, sizeof(z_stream)); stream.zalloc = Z_NULL; @@ -3911,7 +3911,7 @@ ZipChannelOpen( goto error; } else if (info->isEncrypted) { unsigned char *ubuf = NULL; - unsigned int j, len; + size_t j, len; /* * Decode encrypted but uncompressed file, since we support @@ -4045,13 +4045,11 @@ ZipFSOpenFileChannelProc( int mode, int permissions) { - int len; - pathPtr = Tcl_FSGetNormalizedPath(NULL, pathPtr); if (!pathPtr) { return NULL; } - return ZipChannelOpen(interp, Tcl_GetStringFromObj(pathPtr, &len), mode, + return ZipChannelOpen(interp, TclGetString(pathPtr), mode, permissions); } @@ -4077,13 +4075,12 @@ ZipFSStatProc( Tcl_Obj *pathPtr, Tcl_StatBuf *buf) { - int len; pathPtr = Tcl_FSGetNormalizedPath(NULL, pathPtr); if (!pathPtr) { return -1; } - return ZipEntryStat(Tcl_GetStringFromObj(pathPtr, &len), buf); + return ZipEntryStat(TclGetString(pathPtr), buf); } /* @@ -4108,13 +4105,11 @@ ZipFSAccessProc( Tcl_Obj *pathPtr, int mode) { - int len; - pathPtr = Tcl_FSGetNormalizedPath(NULL, pathPtr); if (!pathPtr) { return -1; } - return ZipEntryAccess(Tcl_GetStringFromObj(pathPtr, &len), mode); + return ZipEntryAccess(TclGetString(pathPtr), mode); } /* @@ -4173,8 +4168,8 @@ ZipFSMatchInDirectoryProc( Tcl_HashEntry *hPtr; Tcl_HashSearch search; Tcl_Obj *normPathPtr = Tcl_FSGetNormalizedPath(NULL, pathPtr); - int scnt, l, dirOnly = -1, prefixLen, strip = 0; - size_t len; + int scnt, l, dirOnly = -1, strip = 0; + size_t len, prefixLen; char *pat, *prefix, *path; Tcl_DString dsPref; @@ -4189,13 +4184,13 @@ ZipFSMatchInDirectoryProc( * The prefix that gets prepended to results. */ - prefix = Tcl_GetStringFromObj(pathPtr, &prefixLen); + prefix = TclGetStringFromObj(pathPtr, &prefixLen); /* * The (normalized) path we're searching. */ - path = Tcl_GetString(normPathPtr); + path = TclGetString(normPathPtr); len = normPathPtr->length; Tcl_DStringInit(&dsPref); @@ -4368,7 +4363,7 @@ ZipFSPathInFilesystemProc( return -1; } - path = Tcl_GetString(pathPtr); + path = TclGetString(pathPtr); if (strncmp(path, ZIPFS_VOLUME, ZIPFS_VOLUME_LEN) != 0) { return -1; } @@ -4493,7 +4488,7 @@ ZipFSFileAttrsGetProc( Tcl_Obj *pathPtr, Tcl_Obj **objPtrRef) { - int len, ret = TCL_OK; + int ret = TCL_OK; char *path; ZipEntry *z; @@ -4501,7 +4496,7 @@ ZipFSFileAttrsGetProc( if (!pathPtr) { return -1; } - path = Tcl_GetStringFromObj(pathPtr, &len); + path = TclGetString(pathPtr); ReadLock(); z = ZipFSLookup(path); if (!z) { diff --git a/generic/tclZlib.c b/generic/tclZlib.c index 34ea90c..ef5eab3 100644 --- a/generic/tclZlib.c +++ b/generic/tclZlib.c @@ -185,7 +185,7 @@ static int GenerateHeader(Tcl_Interp *interp, Tcl_Obj *dictObj, static int ZlibPushSubcmd(Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); static inline int ResultCopy(ZlibChannelData *cd, char *buf, - int toRead); + size_t toRead); static int ResultGenerate(ZlibChannelData *cd, int n, int flush, int *errorCodePtr); static Tcl_Channel ZlibStackChannelTransform(Tcl_Interp *interp, @@ -3391,7 +3391,7 @@ ZlibTransformGetOption( Tcl_DStringAppendElement(dsPtr, "-dictionary"); if (cd->compDictObj) { Tcl_DStringAppendElement(dsPtr, - Tcl_GetString(cd->compDictObj)); + TclGetString(cd->compDictObj)); } else { Tcl_DStringAppendElement(dsPtr, ""); } @@ -3417,7 +3417,7 @@ ZlibTransformGetOption( ExtractHeader(&cd->inHeader.header, tmpObj); if (optionName == NULL) { Tcl_DStringAppendElement(dsPtr, "-header"); - Tcl_DStringAppendElement(dsPtr, Tcl_GetString(tmpObj)); + Tcl_DStringAppendElement(dsPtr, TclGetString(tmpObj)); Tcl_DecrRefCount(tmpObj); } else { TclDStringAppendObj(dsPtr, tmpObj); @@ -3740,9 +3740,9 @@ static inline int ResultCopy( ZlibChannelData *cd, /* The location of the buffer to read from. */ char *buf, /* The buffer to copy into */ - int toRead) /* Number of requested bytes */ + size_t toRead) /* Number of requested bytes */ { - int have = Tcl_DStringLength(&cd->decompressed); + size_t have = Tcl_DStringLength(&cd->decompressed); if (have == 0) { /* @@ -4003,7 +4003,7 @@ int Tcl_ZlibStreamGet( Tcl_ZlibStream zshandle, Tcl_Obj *data, - int count) + size_t count) { return TCL_OK; } @@ -4041,7 +4041,7 @@ Tcl_ZlibInflate( unsigned int Tcl_ZlibCRC32( unsigned int crc, - const char *buf, + const unsigned char *buf, size_t len) { return 0; @@ -4050,7 +4050,7 @@ Tcl_ZlibCRC32( unsigned int Tcl_ZlibAdler32( unsigned int adler, - const char *buf, + const unsigned char *buf, size_t len) { return 0; diff --git a/unix/tclLoadDl.c b/unix/tclLoadDl.c index 88854da..8a801c9 100644 --- a/unix/tclLoadDl.c +++ b/unix/tclLoadDl.c @@ -106,7 +106,7 @@ TclpDlopen( */ Tcl_DString ds; - const char *fileName = Tcl_GetString(pathPtr); + const char *fileName = TclGetString(pathPtr); native = Tcl_UtfToExternalDString(NULL, fileName, -1, &ds); /* @@ -127,7 +127,7 @@ TclpDlopen( if (interp) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "couldn't load file \"%s\": %s", - Tcl_GetString(pathPtr), errorStr)); + TclGetString(pathPtr), errorStr)); } return TCL_ERROR; } diff --git a/unix/tclLoadDyld.c b/unix/tclLoadDyld.c index d1701da..af24841 100644 --- a/unix/tclLoadDyld.c +++ b/unix/tclLoadDyld.c @@ -184,7 +184,7 @@ TclpDlopen( */ nativePath = Tcl_FSGetNativePath(pathPtr); - nativeFileName = Tcl_UtfToExternalDString(NULL, Tcl_GetString(pathPtr), + nativeFileName = Tcl_UtfToExternalDString(NULL, TclGetString(pathPtr), -1, &ds); #if TCL_DYLD_USE_DLFCN diff --git a/unix/tclLoadNext.c b/unix/tclLoadNext.c index 58657c8..393bfc5 100644 --- a/unix/tclLoadNext.c +++ b/unix/tclLoadNext.c @@ -61,7 +61,7 @@ TclpDlopen( NXStream *errorStream = NXOpenMemory(0,0,NX_READWRITE); - fileName = Tcl_GetString(pathPtr); + fileName = TclGetString(pathPtr); /* * First try the full path the user gave us. This is particularly diff --git a/unix/tclLoadOSF.c b/unix/tclLoadOSF.c index 6a06b3e..f67725f 100644 --- a/unix/tclLoadOSF.c +++ b/unix/tclLoadOSF.c @@ -79,7 +79,7 @@ TclpDlopen( Tcl_LoadHandle newHandle; ldr_module_t lm; char *pkg; - char *fileName = Tcl_GetString(pathPtr); + char *fileName = TclGetString(pathPtr); const char *native; /* diff --git a/unix/tclLoadShl.c b/unix/tclLoadShl.c index a849ac6..fc5f27c 100644 --- a/unix/tclLoadShl.c +++ b/unix/tclLoadShl.c @@ -57,7 +57,7 @@ TclpDlopen( shl_t handle; Tcl_LoadHandle newHandle; const char *native; - char *fileName = Tcl_GetString(pathPtr); + char *fileName = TclGetString(pathPtr); /* * The flags below used to be BIND_IMMEDIATE; they were changed at the diff --git a/unix/tclUnixChan.c b/unix/tclUnixChan.c index 04bb28c..1dd2340 100644 --- a/unix/tclUnixChan.c +++ b/unix/tclUnixChan.c @@ -579,7 +579,7 @@ TtySetOptionProc( const char *value) /* New value for option. */ { FileState *fsPtr = instanceData; - unsigned int len, vlen; + size_t len, vlen; TtyAttrs tty; int argc; const char **argv; @@ -806,7 +806,7 @@ TtyGetOptionProc( Tcl_DString *dsPtr) /* Where to store value(s). */ { FileState *fsPtr = instanceData; - unsigned int len; + size_t len; char buf[3*TCL_INTEGER_SPACE + 16]; int valid = 0; /* Flag if valid option parsed. */ diff --git a/unix/tclUnixPipe.c b/unix/tclUnixPipe.c index c42dfa7..0623648 100644 --- a/unix/tclUnixPipe.c +++ b/unix/tclUnixPipe.c @@ -524,7 +524,7 @@ TclpCreateProcess( errPipeOut = NULL; fd = GetFd(errPipeIn); - count = read(fd, errSpace, (size_t) (sizeof(errSpace) - 1)); + count = read(fd, errSpace, sizeof(errSpace) - 1); if (count > 0) { char *end; @@ -1274,7 +1274,7 @@ Tcl_PidObjCmd( * Get the channel and make sure that it refers to a pipe. */ - chan = Tcl_GetChannel(interp, Tcl_GetString(objv[1]), NULL); + chan = Tcl_GetChannel(interp, TclGetString(objv[1]), NULL); if (chan == NULL) { return TCL_ERROR; } diff --git a/unix/tclUnixSock.c b/unix/tclUnixSock.c index 23ef1ba..d53b3de 100644 --- a/unix/tclUnixSock.c +++ b/unix/tclUnixSock.c @@ -313,7 +313,8 @@ InitializeHostName( const char * Tcl_GetHostName(void) { - return Tcl_GetString(TclGetProcessGlobalValue(&hostName)); + Tcl_Obj *tclObj = TclGetProcessGlobalValue(&hostName); + return TclGetString(tclObj); } /* diff --git a/win/tclWinFCmd.c b/win/tclWinFCmd.c index 164ed83..d281c22 100644 --- a/win/tclWinFCmd.c +++ b/win/tclWinFCmd.c @@ -911,8 +911,8 @@ TclpObjCopyDirectory( return TCL_ERROR; } - Tcl_WinUtfToTChar(Tcl_GetString(normSrcPtr), -1, &srcString); - Tcl_WinUtfToTChar(Tcl_GetString(normDestPtr), -1, &dstString); + Tcl_WinUtfToTChar(TclGetString(normSrcPtr), -1, &srcString); + Tcl_WinUtfToTChar(TclGetString(normDestPtr), -1, &dstString); ret = TraverseWinTree(TraversalCopy, &srcString, &dstString, &ds); @@ -984,7 +984,7 @@ TclpObjRemoveDirectory( if (normPtr == NULL) { return TCL_ERROR; } - Tcl_WinUtfToTChar(Tcl_GetString(normPtr), -1, &native); + Tcl_WinUtfToTChar(TclGetString(normPtr), -1, &native); ret = DoRemoveDirectory(&native, recursive, &ds); Tcl_DStringFree(&native); } else { @@ -1593,7 +1593,7 @@ ConvertFileNameFormat( if (interp != NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "could not read \"%s\": no such file or directory", - Tcl_GetString(fileName))); + TclGetString(fileName))); errno = ENOENT; Tcl_PosixError(interp); } @@ -1883,7 +1883,7 @@ CannotSetAttribute( { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "cannot set attribute \"%s\" for file \"%s\": attribute is readonly", - tclpFileAttrStrings[objIndex], Tcl_GetString(fileName))); + tclpFileAttrStrings[objIndex], TclGetString(fileName))); errno = EINVAL; Tcl_PosixError(interp); return TCL_ERROR; diff --git a/win/tclWinFile.c b/win/tclWinFile.c index 9545381..7ff8b9b 100644 --- a/win/tclWinFile.c +++ b/win/tclWinFile.c @@ -973,8 +973,7 @@ TclpMatchInDirectory( */ Tcl_DStringInit(&dsOrig); - dirName = TclGetString(fileNamePtr); - dirLength = fileNamePtr->length; + dirName = TclGetStringFromObj(fileNamePtr, &dirLength); Tcl_DStringAppend(&dsOrig, dirName, dirLength); lastChar = dirName[dirLength -1]; @@ -2398,7 +2397,7 @@ TclpFilesystemPathType( if (normPath == NULL) { return NULL; } - path = Tcl_GetString(normPath); + path = TclGetString(normPath); if (path == NULL) { return NULL; } @@ -2476,7 +2475,7 @@ TclpObjNormalizePath( Tcl_DString ds; /* Some workspace. */ Tcl_DStringInit(&dsNorm); - path = Tcl_GetString(pathPtr); + path = TclGetString(pathPtr); currentPathEndPosition = path + nextCheckpoint; if (*currentPathEndPosition == '/') { @@ -2570,12 +2569,12 @@ TclpObjNormalizePath( * Convert link to forward slashes. */ - for (path = Tcl_GetString(to); *path != 0; path++) { + for (path = TclGetString(to); *path != 0; path++) { if (*path == '\\') { *path = '/'; } } - path = Tcl_GetString(to); + path = TclGetString(to); currentPathEndPosition = path + nextCheckpoint; if (temp != NULL) { Tcl_DecrRefCount(temp); @@ -2807,7 +2806,7 @@ TclWinVolumeRelativeNormalize( * current volume. */ - const char *drive = Tcl_GetString(useThisCwd); + const char *drive = TclGetString(useThisCwd); absolutePath = Tcl_NewStringObj(drive,2); Tcl_AppendToObj(absolutePath, path, -1); @@ -2822,8 +2821,8 @@ TclWinVolumeRelativeNormalize( * also on drive C. */ - const char *drive = TclGetString(useThisCwd); - size_t cwdLen = useThisCwd->length; + size_t cwdLen; + const char *drive = TclGetStringFromObj(useThisCwd, &cwdLen); char drive_cur = path[0]; if (drive_cur >= 'a') { @@ -2986,10 +2985,9 @@ TclNativeCreateNativeRep( Tcl_IncrRefCount(validPathPtr); } - str = Tcl_GetString(validPathPtr); - len = validPathPtr->length; + str = TclGetStringFromObj(validPathPtr, &len); - if (strlen(str)!=(unsigned int)len) { + if (strlen(str) != len) { /* String contains NUL-bytes. This is invalid. */ goto done; } diff --git a/win/tclWinInit.c b/win/tclWinInit.c index 11d182a..e7ecd72 100644 --- a/win/tclWinInit.c +++ b/win/tclWinInit.c @@ -223,8 +223,7 @@ TclpInitLibraryPath( TclGetProcessGlobalValue(&sourceLibraryDir)); *encodingPtr = NULL; - bytes = TclGetString(pathPtr); - *lengthPtr = pathPtr->length; + bytes = TclGetStringFromObj(pathPtr, lengthPtr); *valuePtr = Tcl_Alloc(*lengthPtr + 1); memcpy(*valuePtr, bytes, *lengthPtr + 1); Tcl_DecrRefCount(pathPtr); diff --git a/win/tclWinLoad.c b/win/tclWinLoad.c index 3d0b804..9d398d7 100644 --- a/win/tclWinLoad.c +++ b/win/tclWinLoad.c @@ -95,7 +95,7 @@ TclpDlopen( firstError = (nativeName == NULL) ? ERROR_MOD_NOT_FOUND : GetLastError(); - nativeName = Tcl_WinUtfToTChar(Tcl_GetString(pathPtr), -1, &ds); + nativeName = Tcl_WinUtfToTChar(TclGetString(pathPtr), -1, &ds); hInstance = LoadLibraryEx(nativeName, NULL, LOAD_WITH_ALTERED_SEARCH_PATH); Tcl_DStringFree(&ds); @@ -117,7 +117,7 @@ TclpDlopen( lastError = firstError; errMsg = Tcl_ObjPrintf("couldn't load library \"%s\": ", - Tcl_GetString(pathPtr)); + TclGetString(pathPtr)); /* * Check for possible DLL errors. This doesn't work quite right, diff --git a/win/tclWinPipe.c b/win/tclWinPipe.c index 4659021..bd97c6c 100644 --- a/win/tclWinPipe.c +++ b/win/tclWinPipe.c @@ -2217,7 +2217,7 @@ PipeOutputProc( infoPtr->writeBufLen = toWrite; infoPtr->writeBuf = Tcl_Alloc(toWrite); } - memcpy(infoPtr->writeBuf, buf, (size_t) toWrite); + memcpy(infoPtr->writeBuf, buf, toWrite); infoPtr->toWrite = toWrite; ResetEvent(infoPtr->writable); TclPipeThreadSignal(&infoPtr->writeTI); @@ -2672,7 +2672,7 @@ Tcl_PidObjCmd( if (objc == 1) { Tcl_SetObjResult(interp, Tcl_NewWideIntObj((unsigned) getpid())); } else { - chan = Tcl_GetChannel(interp, Tcl_GetString(objv[1]), + chan = Tcl_GetChannel(interp, TclGetString(objv[1]), NULL); if (chan == (Tcl_Channel) NULL) { return TCL_ERROR; @@ -3123,9 +3123,10 @@ TclpOpenTemporaryFile( } namePtr += length * sizeof(TCHAR); if (basenameObj) { - const char *string = Tcl_GetString(basenameObj); + size_t length; + const char *string = TclGetStringFromObj(basenameObj, &length); - Tcl_WinUtfToTChar(string, basenameObj->length, &buf); + Tcl_WinUtfToTChar(string, length, &buf); memcpy(namePtr, Tcl_DStringValue(&buf), Tcl_DStringLength(&buf)); namePtr += Tcl_DStringLength(&buf); Tcl_DStringFree(&buf); -- cgit v0.12 From 211f04efe783ccaf8e903dffad758d37bdff6348 Mon Sep 17 00:00:00 2001 From: dgp Date: Sat, 23 Feb 2019 01:04:44 +0000 Subject: Adapt the gratuitous macro that doubles the burden of core development. --- generic/tclInt.h | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/generic/tclInt.h b/generic/tclInt.h index 5ba5b94..b0ec11b 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -4392,9 +4392,9 @@ MODULE_SCOPE void TclDbInitNewObj(Tcl_Obj *objPtr, const char *file, *(lenPtr) = *((size_t *) (objPtr)->internalRep.twoPtrValue.ptr1), \ Tcl_GetUnicodeFromObj(objPtr, NULL)) #define TclGetByteArrayFromObj(objPtr, lenPtr) \ - (Tcl_GetByteArrayFromObj(objPtr, NULL), \ - *(lenPtr) = *((size_t *) (objPtr)->internalRep.twoPtrValue.ptr1), \ - (unsigned char *)(((size_t *) (objPtr)->internalRep.twoPtrValue.ptr1) + 2)) + (Tcl_GetByteArrayFromObj(objPtr, NULL) ? \ + (*(lenPtr) = *((size_t *) (objPtr)->internalRep.twoPtrValue.ptr1), \ + (unsigned char *)(((size_t *) (objPtr)->internalRep.twoPtrValue.ptr1) + 2)) : (*(lenPtr) = 0, NULL)) #endif /* -- cgit v0.12 From d43f6b9af5bfe8a22cfe5b922efc480e05f1fd47 Mon Sep 17 00:00:00 2001 From: dgp Date: Sat, 23 Feb 2019 01:21:15 +0000 Subject: Revise crashing test now that [binary encode] rejects bogus inputs. --- tests/binary.test | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/tests/binary.test b/tests/binary.test index aede659..b756717 100644 --- a/tests/binary.test +++ b/tests/binary.test @@ -2916,7 +2916,7 @@ test binary-78.1 {unicode (out of BMP) to byte-array conversion, bug-[bd94500678 binary encode hex \U0001f415 binary scan \U0001f415 a* v; set v set str {} -} -result {} +} -result * -match glob -returnCodes error # ---------------------------------------------------------------------- # cleanup -- cgit v0.12 From 810b6c7f3298a148dbfdd9e789e39cc338ea4525 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 19 Aug 2019 15:01:09 +0000 Subject: Further implementation of 2 new functions. --- generic/tcl.decls | 4 +-- generic/tcl.h | 21 ++++++++---- generic/tclDecls.h | 10 ------ generic/tclStubFindExecutable.c | 71 ++++++++++++++++++++++++++++++++++++++ generic/tclStubInitSubsystems.c | 70 +++++++++++++++++++++++++++++++++++++ generic/tclStubLibDl.c | 73 --------------------------------------- generic/tclStubSetPanicProc.c | 76 +++++++++++++++++++++++++++++++++++++++++ unix/Makefile.in | 18 +++++++--- unix/tclAppInit.c | 4 +-- win/Makefile.in | 16 ++++++--- win/makefile.vc | 12 +++++-- win/tcl.dsp | 26 +++++++++----- win/tclAppInit.c | 2 +- 13 files changed, 289 insertions(+), 114 deletions(-) create mode 100644 generic/tclStubFindExecutable.c create mode 100644 generic/tclStubInitSubsystems.c delete mode 100644 generic/tclStubLibDl.c create mode 100644 generic/tclStubSetPanicProc.c diff --git a/generic/tcl.decls b/generic/tcl.decls index 815183e..ec697f2 100644 --- a/generic/tcl.decls +++ b/generic/tcl.decls @@ -532,7 +532,7 @@ declare 143 { } # Removed in 9.0 (stub entry only) #declare 144 { -# void Tcl_FindExecutable(const char *argv0) +# const char *Tcl_FindExecutable(const char *argv0) #} declare 145 { Tcl_HashEntry *Tcl_FirstHashEntry(Tcl_HashTable *tablePtr, @@ -2502,7 +2502,7 @@ export { Tcl_ExitProc *Tcl_SetExitProc(TCL_NORETURN1 Tcl_ExitProc *proc) } export { - void Tcl_FindExecutable(const char *argv0) + const char *Tcl_FindExecutable(const char *argv0) } export { const char *Tcl_InitStubs(Tcl_Interp *interp, const char *version, diff --git a/generic/tcl.h b/generic/tcl.h index 6a9e818..0ace839 100644 --- a/generic/tcl.h +++ b/generic/tcl.h @@ -2225,21 +2225,16 @@ const char * TclInitStubTable(const char *version); */ #define Tcl_Main(argc, argv, proc) Tcl_MainEx(argc, argv, proc, \ - ((Tcl_SetPanicProc(Tcl_ConsolePanic), Tcl_CreateInterp)())) + ((Tcl_SetPanicProc(Tcl_ConsolePanic), Tcl_CreateInterp()))) EXTERN TCL_NORETURN void Tcl_MainEx(int argc, char **argv, Tcl_AppInitProc *appInitProc, Tcl_Interp *interp); EXTERN const char * Tcl_PkgInitStubsCheck(Tcl_Interp *interp, const char *version, int exact); EXTERN void Tcl_GetMemoryInfo(Tcl_DString *dsPtr); EXTERN const char * Tcl_FindExecutable(const char *argv0); +EXTERN const char * Tcl_InitSubsystems(void); EXTERN const char * Tcl_SetPanicProc( TCL_NORETURN1 Tcl_PanicProc *panicProc); -#ifdef USE_TCL_STUBS -#define Tcl_SetPanicProc(panicProc) \ - TclInitStubTable((Tcl_SetPanicProc)(panicProc)) -#define Tcl_FindExecutable(argv0) \ - TclInitStubTable((Tcl_FindExecutable)((const char *)argv0)) -#endif EXTERN void Tcl_StaticPackage(Tcl_Interp *interp, const char *pkgName, Tcl_PackageInitProc *initProc, @@ -2248,6 +2243,18 @@ EXTERN Tcl_ExitProc *Tcl_SetExitProc(TCL_NORETURN1 Tcl_ExitProc *proc); #ifndef _WIN32 EXTERN int TclZipfs_AppHook(int *argc, char ***argv); #endif +extern const char *TclStubFindExecutable(const char *argv0); +extern const char *TclStubInitSubsystems(void); +extern const char *TclStubSetPanicProc( + TCL_NORETURN1 Tcl_PanicProc *panicProc); +#ifdef USE_TCL_STUBS +#define Tcl_FindExecutable(argv0) \ + TclInitStubTable((TclStubFindExecutable)((const char *)argv0)) +#define Tcl_InitSubsystems() \ + TclInitStubTable((TclStubInitSubsystems)()) +#define Tcl_SetPanicProc(panicProc) \ + TclInitStubTable((TclStubSetPanicProc)(panicProc)) +#endif /* *---------------------------------------------------------------------------- diff --git a/generic/tclDecls.h b/generic/tclDecls.h index 71aa8b8..e28d724 100644 --- a/generic/tclDecls.h +++ b/generic/tclDecls.h @@ -3711,16 +3711,6 @@ extern const TclStubs *tclStubsPtr; /* !END!: Do not edit above this line. */ -#if defined(USE_TCL_STUBS) -# undef Tcl_CreateInterp -# undef Tcl_Init -# undef Tcl_ObjSetVar2 -# define Tcl_CreateInterp() (tclStubsPtr->tcl_CreateInterp()) -# define Tcl_Init(interp) (tclStubsPtr->tcl_Init(interp)) -# define Tcl_ObjSetVar2(interp, part1, part2, newValue, flags) \ - (tclStubsPtr->tcl_ObjSetVar2(interp, part1, part2, newValue, flags)) -#endif - #if defined(_WIN32) && defined(UNICODE) #ifndef USE_TCL_STUBS # define Tcl_FindExecutable(arg) ((Tcl_FindExecutable)((const char *)(arg))) diff --git a/generic/tclStubFindExecutable.c b/generic/tclStubFindExecutable.c new file mode 100644 index 0000000..17ee576 --- /dev/null +++ b/generic/tclStubFindExecutable.c @@ -0,0 +1,71 @@ +/* + * tclStubLibDl.c -- + * + * Stub object that will be statically linked into extensions that want + * to access Tcl. + * + * Copyright (c) 1998-1999 by Scriptics Corporation. + * Copyright (c) 1998 Paul Duffin. + * + * See the file "license.terms" for information on usage and redistribution of + * this file, and for a DISCLAIMER OF ALL WARRANTIES. + */ + +#include "tclInt.h" +#ifndef _WIN32 +# include +#else +# define dlopen(a,b) (void *)LoadLibrary(TEXT(a)) +# define dlsym(a,b) (void *)GetProcAddress((HANDLE)(a),b) +# define dlerror() "" +#endif + +/* + *---------------------------------------------------------------------- + * + * Tcl_FindExecutable -- + * + * Load the Tcl core dynamically, version "9.0" (or higher, in future versions) + * + * Results: + * Outputs the value of the "version" argument. + * + * Side effects: + * Sets the stub table pointers. + * + *---------------------------------------------------------------------- + */ + +static const char PROCNAME[] = "_Tcl_FindExecutable"; + +MODULE_SCOPE const char * +TclStubFindExecutable( + const char *argv0) +{ + static const char *(*findExecutable)(const char *argv0) = NULL; + static const char *version = NULL; + + if (!findExecutable) { + void *handle = dlopen(TCL_DLL_FILE, RTLD_NOW|RTLD_LOCAL); + if (!handle) { + fprintf(stderr, "Cannot find " TCL_DLL_FILE ": %s\n", dlerror()); + abort(); + } + findExecutable = dlsym(handle, PROCNAME + 1); + if (!findExecutable) { + findExecutable = dlsym(handle, PROCNAME); + } + if (findExecutable) { + version = findExecutable(argv0); + } + } + return version; +} + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ diff --git a/generic/tclStubInitSubsystems.c b/generic/tclStubInitSubsystems.c new file mode 100644 index 0000000..e683adf --- /dev/null +++ b/generic/tclStubInitSubsystems.c @@ -0,0 +1,70 @@ +/* + * tclStubLibDl.c -- + * + * Stub object that will be statically linked into extensions that want + * to access Tcl. + * + * Copyright (c) 1998-1999 by Scriptics Corporation. + * Copyright (c) 1998 Paul Duffin. + * + * See the file "license.terms" for information on usage and redistribution of + * this file, and for a DISCLAIMER OF ALL WARRANTIES. + */ + +#include "tclInt.h" +#ifndef _WIN32 +# include +#else +# define dlopen(a,b) (void *)LoadLibrary(TEXT(a)) +# define dlsym(a,b) (void *)GetProcAddress((HANDLE)(a),b) +# define dlerror() "" +#endif + +/* + *---------------------------------------------------------------------- + * + * Tcl_InitSubsystems -- + * + * Load the Tcl core dynamically, version "9.0" (or higher, in future versions) + * + * Results: + * Outputs the value of the "version" argument. + * + * Side effects: + * Sets the stub table pointers. + * + *---------------------------------------------------------------------- + */ + +static const char PROCNAME[] = "_Tcl_InitSubsystems"; + +MODULE_SCOPE const char * +TclStubInitSubsystems(void) +{ + static const char *(*initSubsystems)(void) = NULL; + static const char *version = NULL; + + if (!initSubsystems) { + void *handle = dlopen(TCL_DLL_FILE, RTLD_NOW|RTLD_LOCAL); + if (!handle) { + fprintf(stderr, "Cannot find " TCL_DLL_FILE ": %s\n", dlerror()); + abort(); + } + initSubsystems = dlsym(handle, PROCNAME + 1); + if (!initSubsystems) { + initSubsystems = dlsym(handle, PROCNAME); + } + if (initSubsystems) { + version = initSubsystems(); + } + } + return version; +} + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ diff --git a/generic/tclStubLibDl.c b/generic/tclStubLibDl.c deleted file mode 100644 index 67d9e7d..0000000 --- a/generic/tclStubLibDl.c +++ /dev/null @@ -1,73 +0,0 @@ -/* - * tclStubLibDl.c -- - * - * Stub object that will be statically linked into extensions that want - * to access Tcl. - * - * Copyright (c) 1998-1999 by Scriptics Corporation. - * Copyright (c) 1998 Paul Duffin. - * - * See the file "license.terms" for information on usage and redistribution of - * this file, and for a DISCLAIMER OF ALL WARRANTIES. - */ - -#include "tclInt.h" -#ifndef _WIN32 -# include -#else -# define dlopen(a,b) (void *)LoadLibrary(TEXT(a)) -# define dlsym(a,b) (void *)GetProcAddress((HANDLE)(a),b) -#endif - -/* - *---------------------------------------------------------------------- - * - * Tcl_SetPanicProc -- - * - * Load the Tcl core dynamically, version "9.0" (or higher, in future versions) - * - * Results: - * Outputs the value of the "version" argument. - * - * Side effects: - * Sets the stub table pointers. - * - *---------------------------------------------------------------------- - */ - -MODULE_SCOPE const char * -Tcl_SetPanicProc( - TCL_NORETURN1 Tcl_PanicProc *panicProc) -{ - static const char *(*setPanicProc)(TCL_NORETURN1 Tcl_PanicProc *) = NULL; - static const char *version = NULL; - - if (!setPanicProc) { - void *handle = dlopen(TCL_DLL_FILE, RTLD_NOW|RTLD_LOCAL); - if (!handle) { - if (panicProc) { - panicProc("Cannot find " TCL_DLL_FILE); - } else { - fprintf(stderr, "Cannot find " TCL_DLL_FILE); - abort(); - } - return NULL; - } - setPanicProc = dlsym(handle, "Tcl_SetPanicProc"); - if (!setPanicProc) { - setPanicProc = dlsym(handle, "_Tcl_SetPanicProc"); - } - if (setPanicProc) { - version = setPanicProc(panicProc); - } - } - return version; -} - -/* - * Local Variables: - * mode: c - * c-basic-offset: 4 - * fill-column: 78 - * End: - */ diff --git a/generic/tclStubSetPanicProc.c b/generic/tclStubSetPanicProc.c new file mode 100644 index 0000000..8742370 --- /dev/null +++ b/generic/tclStubSetPanicProc.c @@ -0,0 +1,76 @@ +/* + * tclStubLibDl.c -- + * + * Stub object that will be statically linked into extensions that want + * to access Tcl. + * + * Copyright (c) 1998-1999 by Scriptics Corporation. + * Copyright (c) 1998 Paul Duffin. + * + * See the file "license.terms" for information on usage and redistribution of + * this file, and for a DISCLAIMER OF ALL WARRANTIES. + */ + +#include "tclInt.h" +#ifndef _WIN32 +# include +#else +# define dlopen(a,b) (void *)LoadLibrary(TEXT(a)) +# define dlsym(a,b) (void *)GetProcAddress((HANDLE)(a),b) +# define dlerror() "" +#endif + +/* + *---------------------------------------------------------------------- + * + * Tcl_SetPanicProc -- + * + * Load the Tcl core dynamically, version "9.0" (or higher, in future versions) + * + * Results: + * Outputs the value of the "version" argument. + * + * Side effects: + * Sets the stub table pointers. + * + *---------------------------------------------------------------------- + */ + +static const char PROCNAME[] = "_Tcl_SetPanicProc"; + +MODULE_SCOPE const char * +TclStubSetPanicProc( + TCL_NORETURN1 Tcl_PanicProc *panicProc) +{ + static const char *(*setPanicProc)(TCL_NORETURN1 Tcl_PanicProc *) = NULL; + static const char *version = NULL; + + if (!setPanicProc) { + void *handle = dlopen(TCL_DLL_FILE, RTLD_NOW|RTLD_LOCAL); + if (!handle) { + if (panicProc) { + panicProc("Cannot find " TCL_DLL_FILE ": %s\n", dlerror()); + } else { + fprintf(stderr, "Cannot find " TCL_DLL_FILE ": %s\n", dlerror()); + abort(); + } + return NULL; + } + setPanicProc = dlsym(handle, PROCNAME + 1); + if (!setPanicProc) { + setPanicProc = dlsym(handle, PROCNAME); + } + if (setPanicProc) { + version = setPanicProc(panicProc); + } + } + return version; +} + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ diff --git a/unix/Makefile.in b/unix/Makefile.in index 3b24caf..5767db1 100644 --- a/unix/Makefile.in +++ b/unix/Makefile.in @@ -345,7 +345,9 @@ TOMMATH_OBJS = bn_reverse.o bn_fast_s_mp_mul_digs.o \ bn_s_mp_mul_digs.o bn_s_mp_sqr.o bn_s_mp_sub.o STUB_LIB_OBJS = tclStubLib.o \ - tclStubLibDl.o \ + tclStubFindExecutable.o \ + tclStubInitSubsystems.o \ + tclStubSetPanicProc.o \ tclStubLibTbl.o \ tclTomMathStubLib.o \ tclOOStubLib.o \ @@ -489,7 +491,9 @@ OO_SRCS = \ STUB_SRCS = \ $(GENERIC_DIR)/tclStubLib.c \ - $(GENERIC_DIR)/tclStubLibDl.c \ + $(GENERIC_DIR)/tclStubFindExecutable.c \ + $(GENERIC_DIR)/tclStubInitSubsystems.c \ + $(GENERIC_DIR)/tclStubSetPanicProc.c \ $(GENERIC_DIR)/tclStubLibTbl.c \ $(GENERIC_DIR)/tclTomMathStubLib.c \ $(GENERIC_DIR)/tclOOStubLib.c @@ -1825,8 +1829,14 @@ Zzutil.o: $(ZLIB_DIR)/zutil.c tclStubLib.o: $(GENERIC_DIR)/tclStubLib.c $(CC) -c $(STUB_CC_SWITCHES) -DSTATIC_BUILD $(GENERIC_DIR)/tclStubLib.c -tclStubLibDl.o: $(GENERIC_DIR)/tclStubLibDl.c - $(CC) -c $(STUB_CC_SWITCHES) -DSTATIC_BUILD -DTCL_DLL_FILE="\"$(TCL_LIB_FILE)\"" $(GENERIC_DIR)/tclStubLibDl.c +tclStubFindExecutable.o: $(GENERIC_DIR)/tclStubFindExecutable.c + $(CC) -c $(STUB_CC_SWITCHES) -DSTATIC_BUILD -DTCL_DLL_FILE="\"$(TCL_LIB_FILE)\"" $(GENERIC_DIR)/tclStubFindExecutable.c + +tclStubInitSubsystems.o: $(GENERIC_DIR)/tclStubInitSubsystems.c + $(CC) -c $(STUB_CC_SWITCHES) -DSTATIC_BUILD -DTCL_DLL_FILE="\"$(TCL_LIB_FILE)\"" $(GENERIC_DIR)/tclStubInitSubsystems.c + +tclStubSetPanicProc.o: $(GENERIC_DIR)/tclStubSetPanicProc.c + $(CC) -c $(STUB_CC_SWITCHES) -DSTATIC_BUILD -DTCL_DLL_FILE="\"$(TCL_LIB_FILE)\"" $(GENERIC_DIR)/tclStubSetPanicProc.c tclStubLibTbl.o: $(GENERIC_DIR)/tclStubLibTbl.c $(CC) -c $(STUB_CC_SWITCHES) -DSTATIC_BUILD $(GENERIC_DIR)/tclStubLibTbl.c diff --git a/unix/tclAppInit.c b/unix/tclAppInit.c index 3587f35..b791440 100644 --- a/unix/tclAppInit.c +++ b/unix/tclAppInit.c @@ -152,10 +152,10 @@ Tcl_AppInit( */ #ifdef DJGPP - (Tcl_ObjSetVar2)(interp, Tcl_NewStringObj("tcl_rcFileName", -1), NULL, + Tcl_ObjSetVar2(interp, Tcl_NewStringObj("tcl_rcFileName", -1), NULL, Tcl_NewStringObj("~/tclsh.rc", -1), TCL_GLOBAL_ONLY); #else - (Tcl_ObjSetVar2)(interp, Tcl_NewStringObj("tcl_rcFileName", -1), NULL, + Tcl_ObjSetVar2(interp, Tcl_NewStringObj("tcl_rcFileName", -1), NULL, Tcl_NewStringObj("~/.tclshrc", -1), TCL_GLOBAL_ONLY); #endif diff --git a/win/Makefile.in b/win/Makefile.in index 8bc34d5..13100af 100644 --- a/win/Makefile.in +++ b/win/Makefile.in @@ -455,7 +455,9 @@ REG_OBJS = tclWinReg.$(OBJEXT) STUB_OBJS = \ tclStubLib.$(OBJEXT) \ - tclStubLibDl.$(OBJEXT) \ + tclStubFindExecutable.$(OBJEXT) \ + tclStubInitSubsystems.$(OBJEXT) \ + tclStubSetPanicProc.$(OBJEXT) \ tclStubLibTbl.$(OBJEXT) \ tclTomMathStubLib.$(OBJEXT) \ tclOOStubLib.$(OBJEXT) \ @@ -622,8 +624,8 @@ tclWinInit.${OBJEXT}: tclWinInit.c tclWinPipe.${OBJEXT}: tclWinPipe.c $(CC) -c $(CC_SWITCHES) -DBUILD_tcl $(EXTFLAGS) @DEPARG@ $(CC_OBJNAME) -testMain.${OBJEXT}: tclAppInit.c - $(CC) -c $(CC_SWITCHES) -DTCL_TEST @DEPARG@ $(CC_OBJNAME) +tclAppInit.${OBJEXT}: tclAppInit.c + $(CC) -c $(CC_SWITCHES) -DBUILD_tcl @DEPARG@ $(CC_OBJNAME) tclMain2.${OBJEXT}: tclMain.c $(CC) -c $(CC_SWITCHES) -DBUILD_tcl -DTCL_ASCII_MAIN @DEPARG@ $(CC_OBJNAME) @@ -671,7 +673,13 @@ tclPkgConfig.${OBJEXT}: tclPkgConfig.c tclStubLib.${OBJEXT}: tclStubLib.c $(CC) -c $(CC_SWITCHES) -DSTATIC_BUILD @DEPARG@ $(CC_OBJNAME) -tclStubLibDl.${OBJEXT}: tclStubLibDl.c +tclStubFindExecutable.${OBJEXT}: tclStubFindExecutable.c + $(CC) -c $(CC_SWITCHES) -DSTATIC_BUILD -DTCL_DLL_FILE="\"$(TCL_DLL_FILE)\"" @DEPARG@ $(CC_OBJNAME) + +tclStubInitSubsystems.${OBJEXT}: tclStubInitSubsystems.c + $(CC) -c $(CC_SWITCHES) -DSTATIC_BUILD -DTCL_DLL_FILE="\"$(TCL_DLL_FILE)\"" @DEPARG@ $(CC_OBJNAME) + +tclStubSetPanicProc.${OBJEXT}: tclStubSetPanicProc.c $(CC) -c $(CC_SWITCHES) -DSTATIC_BUILD -DTCL_DLL_FILE="\"$(TCL_DLL_FILE)\"" @DEPARG@ $(CC_OBJNAME) tclStubLibTbl.${OBJEXT}: tclStubLibTbl.c diff --git a/win/makefile.vc b/win/makefile.vc index aafd9fb..ea15b0d 100644 --- a/win/makefile.vc +++ b/win/makefile.vc @@ -413,7 +413,9 @@ TCLOBJS = $(COREOBJS) $(ZLIBOBJS) $(TOMMATHOBJS) $(PLATFORMOBJS) TCLSTUBOBJS = \ $(TMP_DIR)\tclStubLib.obj \ - $(TMP_DIR)\tclStubLibDl.obj \ + $(TMP_DIR)\tclStubFindExecutable.obj \ + $(TMP_DIR)\tclStubInitSubsystems.obj \ + $(TMP_DIR)\tclStubSetPanicProc.obj \ $(TMP_DIR)\tclStubLibTbl.obj \ $(TMP_DIR)\tclTomMathStubLib.obj \ $(TMP_DIR)\tclOOStubLib.obj \ @@ -802,7 +804,13 @@ $(TMP_DIR)\tclWinDde.obj: $(WINDIR)\tclWinDde.c $(TMP_DIR)\tclStubLib.obj: $(GENERICDIR)\tclStubLib.c $(cc32) $(stubscflags) -Fo$@ $? -$(TMP_DIR)\tclStubLibDl.obj: $(GENERICDIR)\tclStubLibDl.c +$(TMP_DIR)\tclStubFindExecutable.obj: $(GENERICDIR)\tclStubFindExecutable.c + $(cc32) $(STUB_CFLAGS) -Zl -DSTATIC_BUILD -DTCL_DLL_FILE="\"tcl86.dll\"" $(TCL_INCLUDES) -Fo$@ $? + +$(TMP_DIR)\tclStubInitSubsystems.obj: $(GENERICDIR)\tclStubInitSubsystems.c + $(cc32) $(STUB_CFLAGS) -Zl -DSTATIC_BUILD -DTCL_DLL_FILE="\"tcl86.dll\"" $(TCL_INCLUDES) -Fo$@ $? + +$(TMP_DIR)\tclStubSetPanicProc.obj: $(GENERICDIR)\tclStubSetPanicProc.c $(cc32) $(STUB_CFLAGS) -Zl -DSTATIC_BUILD -DTCL_DLL_FILE="\"tcl86.dll\"" $(TCL_INCLUDES) -Fo$@ $? $(TMP_DIR)\tclStubLibTbl.obj: $(GENERICDIR)\tclStubLibTbl.c diff --git a/win/tcl.dsp b/win/tcl.dsp index a8e71d2..68a1612 100644 --- a/win/tcl.dsp +++ b/win/tcl.dsp @@ -7,21 +7,21 @@ CFG=tcl - Win32 Debug Static !MESSAGE This is not a valid makefile. To build this project using NMAKE, !MESSAGE use the Export Makefile command and run -!MESSAGE +!MESSAGE !MESSAGE NMAKE /f "tcl.mak". -!MESSAGE +!MESSAGE !MESSAGE You can specify a configuration when running NMAKE !MESSAGE by defining the macro CFG on the command line. For example: -!MESSAGE +!MESSAGE !MESSAGE NMAKE /f "tcl.mak" CFG="tcl - Win32 Debug Static" -!MESSAGE +!MESSAGE !MESSAGE Possible choices for configuration are: -!MESSAGE +!MESSAGE !MESSAGE "tcl - Win32 Release" (based on "Win32 (x86) External Target") !MESSAGE "tcl - Win32 Debug" (based on "Win32 (x86) External Target") !MESSAGE "tcl - Win32 Debug Static" (based on "Win32 (x86) External Target") !MESSAGE "tcl - Win32 Release Static" (based on "Win32 (x86) External Target") -!MESSAGE +!MESSAGE # Begin Project # PROP AllowPerConfigDependencies 0 @@ -112,7 +112,7 @@ CFG=tcl - Win32 Debug Static # PROP Bsc_Name "" # PROP Target_Dir "" -!ENDIF +!ENDIF # Begin Target @@ -129,7 +129,7 @@ CFG=tcl - Win32 Debug Static !ELSEIF "$(CFG)" == "tcl - Win32 Release Static" -!ENDIF +!ENDIF # Begin Group "compat" @@ -1288,7 +1288,15 @@ SOURCE=..\generic\tclStubLib.c # End Source File # Begin Source File -SOURCE=..\generic\tclStubLibDl.c +SOURCE=..\generic\tclStubFindExecutable.c +# End Source File +# Begin Source File + +SOURCE=..\generic\tclStubInitSubsystems.c +# End Source File +# Begin Source File + +SOURCE=..\generic\tclStubSetPanicProc.c # End Source File # Begin Source File diff --git a/win/tclAppInit.c b/win/tclAppInit.c index 3292335..5820723 100644 --- a/win/tclAppInit.c +++ b/win/tclAppInit.c @@ -205,7 +205,7 @@ Tcl_AppInit( * user-specific startup file will be run under any conditions. */ - (Tcl_ObjSetVar2)(interp, Tcl_NewStringObj("tcl_rcFileName", -1), NULL, + Tcl_ObjSetVar2(interp, Tcl_NewStringObj("tcl_rcFileName", -1), NULL, Tcl_NewStringObj("~/tclshrc.tcl", -1), TCL_GLOBAL_ONLY); return TCL_OK; } -- cgit v0.12 From 594b14d3e3b65d3dea5188a3af6b7a2bfcbeda19 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 1 Oct 2019 14:57:09 +0000 Subject: Fix handling of BUILD_STATIC --- generic/tcl.h | 2 +- unix/Makefile.in | 2 +- win/Makefile.in | 2 +- win/tclAppInit.c | 1 - 4 files changed, 3 insertions(+), 4 deletions(-) diff --git a/generic/tcl.h b/generic/tcl.h index 9598870..5af0a3d 100644 --- a/generic/tcl.h +++ b/generic/tcl.h @@ -2260,7 +2260,7 @@ extern const char *TclStubCall(int flags, void *arg1, void *arg2); EXTERN TCL_NORETURN void Tcl_MainExW(int argc, wchar_t **argv, Tcl_AppInitProc *appInitProc, Tcl_Interp *interp); #endif -#ifdef USE_TCL_STUBS +#if defined(USE_TCL_STUBS) && !defined(STATIC_BUILD) #define Tcl_InitSubsystems() \ TclInitStubTable(TclStubCall(0, NULL, NULL)) #define Tcl_FindExecutable(argv0) \ diff --git a/unix/Makefile.in b/unix/Makefile.in index 2fe0bd6..1b74aeb 100644 --- a/unix/Makefile.in +++ b/unix/Makefile.in @@ -1100,7 +1100,7 @@ tclTestInit.o: $(UNIX_DIR)/tclAppInit.c ${TCL_EXE} fi $(CC) -c $(APP_CC_SWITCHES) \ -DTCL_BUILDTIME_LIBRARY="\"${TCL_BUILDTIME_LIBRARY}\"" \ - -DTCL_TEST $(UNIX_DIR)/tclAppInit.c + -DTCL_TEST -DUSE_TCL_STUBS $(UNIX_DIR)/tclAppInit.c @rm -f tclTestInit.o mv tclAppInit.o tclTestInit.o @if test -f tclAppInit.sav ; then \ diff --git a/win/Makefile.in b/win/Makefile.in index 08f9e6a..f6bb954 100644 --- a/win/Makefile.in +++ b/win/Makefile.in @@ -625,7 +625,7 @@ ${ZLIB_DLL_FILE}: ${TCL_STUB_LIB_FILE} # Special case object targets tclTestMain.${OBJEXT}: tclAppInit.c - $(CC) -c $(CC_SWITCHES) -DTCL_TEST -DUNICODE -D_UNICODE $(EXTFLAGS) @DEPARG@ $(CC_OBJNAME) + $(CC) -c $(CC_SWITCHES) -DTCL_TEST -DUNICODE -D_UNICODE -DUSE_TCL_STUBS $(EXTFLAGS) @DEPARG@ $(CC_OBJNAME) tclWinInit.${OBJEXT}: tclWinInit.c $(CC) -c $(CC_SWITCHES) -DBUILD_tcl $(EXTFLAGS) @DEPARG@ $(CC_OBJNAME) diff --git a/win/tclAppInit.c b/win/tclAppInit.c index 6ba57de..5820723 100644 --- a/win/tclAppInit.c +++ b/win/tclAppInit.c @@ -14,7 +14,6 @@ * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ -#define USE_TCL_STUBS #include "tcl.h" #define WIN32_LEAN_AND_MEAN #define STRICT /* See MSDN Article Q83456 */ -- cgit v0.12 From 995453e1a0afa8b6b073e157677ffe6d89b3de6f Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 1 Oct 2019 15:04:38 +0000 Subject: further fix handling -DBUILD_STATIC --- generic/tclStubLibTbl.c | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/generic/tclStubLibTbl.c b/generic/tclStubLibTbl.c index 37b6856..cc1bb89 100644 --- a/generic/tclStubLibTbl.c +++ b/generic/tclStubLibTbl.c @@ -35,6 +35,12 @@ TclInitStubTable( structure variable. */ { if (version) { + if (tclStubsHandle == NULL) { + /* This can only happen with -DBUILD_STATIC, so simulate + * that the loading of Tcl succeeded, although we didn't + * actually loaded it dynamically */ + tclStubsHandle = (void *)1; + } tclStubsPtr = ((const TclStubs **) version)[-1]; if (tclStubsPtr->hooks) { -- cgit v0.12 From b556c1feccfb6f7985b80cc4fc906ab529ea6f01 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 6 Nov 2019 09:29:29 +0000 Subject: A few post-1.2.0 commits, extracted from support/1.x branch --- libtommath/appveyor.yml | 1 + libtommath/bn_mp_mul.c | 2 +- libtommath/bn_s_mp_mul_high_digs_fast.c | 4 +- libtommath/changes.txt | 2 +- libtommath/demo/shared.c | 42 + libtommath/demo/shared.h | 21 + libtommath/demo/test.c | 2522 +++++++++++++++++++++++++++++++ libtommath/helper.pl | 2 +- libtommath/makefile_include.mk | 8 +- libtommath/testme.sh | 394 +++++ libtommath/tommath.h | 15 +- 11 files changed, 3003 insertions(+), 10 deletions(-) create mode 100644 libtommath/demo/shared.c create mode 100644 libtommath/demo/shared.h create mode 100644 libtommath/demo/test.c create mode 100755 libtommath/testme.sh diff --git a/libtommath/appveyor.yml b/libtommath/appveyor.yml index 187a09a..08bb013 100644 --- a/libtommath/appveyor.yml +++ b/libtommath/appveyor.yml @@ -4,6 +4,7 @@ branches: - master - develop - /^release/ + - /^support/ - /^travis/ image: - Visual Studio 2019 diff --git a/libtommath/bn_mp_mul.c b/libtommath/bn_mp_mul.c index 561913a..91707cd 100644 --- a/libtommath/bn_mp_mul.c +++ b/libtommath/bn_mp_mul.c @@ -17,7 +17,7 @@ mp_err mp_mul(const mp_int *a, const mp_int *b, mp_int *c) * The bigger one needs to be at least about one MP_KARATSUBA_MUL_CUTOFF bigger * to make some sense, but it depends on architecture, OS, position of the * stars... so YMMV. - * Using it to cut the input into slices small enough for fast_s_mp_mul_digs + * Using it to cut the input into slices small enough for s_mp_mul_digs_fast * was actually slower on the author's machine, but YMMV. */ (min_len >= MP_KARATSUBA_MUL_CUTOFF) && diff --git a/libtommath/bn_s_mp_mul_high_digs_fast.c b/libtommath/bn_s_mp_mul_high_digs_fast.c index a2c4fb6..a0513b4 100644 --- a/libtommath/bn_s_mp_mul_high_digs_fast.c +++ b/libtommath/bn_s_mp_mul_high_digs_fast.c @@ -3,8 +3,8 @@ /* LibTomMath, multiple-precision integer library -- Tom St Denis */ /* SPDX-License-Identifier: Unlicense */ -/* this is a modified version of fast_s_mul_digs that only produces - * output digits *above* digs. See the comments for fast_s_mul_digs +/* this is a modified version of s_mp_mul_digs_fast that only produces + * output digits *above* digs. See the comments for s_mp_mul_digs_fast * to see how it works. * * This is used in the Barrett reduction since for one of the multiplications diff --git a/libtommath/changes.txt b/libtommath/changes.txt index ebf7382..1b3a7a3 100644 --- a/libtommath/changes.txt +++ b/libtommath/changes.txt @@ -1,4 +1,4 @@ -XXX XXth, 2019 +Oct 22nd, 2019 v1.2.0 -- A huge refactoring of the library happened - renaming, deprecating and replacing existing functions by improved API's. diff --git a/libtommath/demo/shared.c b/libtommath/demo/shared.c new file mode 100644 index 0000000..dc8e05a --- /dev/null +++ b/libtommath/demo/shared.c @@ -0,0 +1,42 @@ +#include "shared.h" + +void ndraw(mp_int *a, const char *name) +{ + char *buf = NULL; + int size; + + mp_radix_size(a, 10, &size); + buf = (char *)malloc((size_t) size); + if (buf == NULL) { + fprintf(stderr, "\nndraw: malloc(%d) failed\n", size); + exit(EXIT_FAILURE); + } + + printf("%s: ", name); + mp_to_decimal(a, buf, (size_t) size); + printf("%s\n", buf); + mp_to_hex(a, buf, (size_t) size); + printf("0x%s\n", buf); + + free(buf); +} + +void print_header(void) +{ +#ifdef MP_8BIT + printf("Digit size 8 Bit \n"); +#endif +#ifdef MP_16BIT + printf("Digit size 16 Bit \n"); +#endif +#ifdef MP_32BIT + printf("Digit size 32 Bit \n"); +#endif +#ifdef MP_64BIT + printf("Digit size 64 Bit \n"); +#endif + printf("Size of mp_digit: %u\n", (unsigned int)sizeof(mp_digit)); + printf("Size of mp_word: %u\n", (unsigned int)sizeof(mp_word)); + printf("MP_DIGIT_BIT: %d\n", MP_DIGIT_BIT); + printf("MP_PREC: %d\n", MP_PREC); +} diff --git a/libtommath/demo/shared.h b/libtommath/demo/shared.h new file mode 100644 index 0000000..4d5eb53 --- /dev/null +++ b/libtommath/demo/shared.h @@ -0,0 +1,21 @@ +#include +#include +#include + +/* + * Configuration + */ +#ifndef LTM_DEMO_TEST_REDUCE_2K_L +/* This test takes a moment so we disable it by default, but it can be: + * 0 to disable testing + * 1 to make the test with P = 2^1024 - 0x2A434 B9FDEC95 D8F9D550 FFFFFFFF FFFFFFFF + * 2 to make the test with P = 2^2048 - 0x1 00000000 00000000 00000000 00000000 4945DDBF 8EA2A91D 5776399B B83E188F + */ +#define LTM_DEMO_TEST_REDUCE_2K_L 0 +#endif + +#define MP_WUR /* TODO: result checks disabled for now */ +#include "tommath_private.h" + +extern void ndraw(mp_int* a, const char* name); +extern void print_header(void); diff --git a/libtommath/demo/test.c b/libtommath/demo/test.c new file mode 100644 index 0000000..7b29a4c --- /dev/null +++ b/libtommath/demo/test.c @@ -0,0 +1,2522 @@ +#include +#include "shared.h" + +static long rand_long(void) +{ + long x; + if (s_mp_rand_source(&x, sizeof(x)) != MP_OKAY) { + fprintf(stderr, "s_mp_rand_source failed\n"); + exit(EXIT_FAILURE); + } + return x; +} + +static int rand_int(void) +{ + int x; + if (s_mp_rand_source(&x, sizeof(x)) != MP_OKAY) { + fprintf(stderr, "s_mp_rand_source failed\n"); + exit(EXIT_FAILURE); + } + return x; +} + +static int32_t rand_int32(void) +{ + int32_t x; + if (s_mp_rand_source(&x, sizeof(x)) != MP_OKAY) { + fprintf(stderr, "s_mp_rand_source failed\n"); + exit(EXIT_FAILURE); + } + return x; +} + +static int64_t rand_int64(void) +{ + int64_t x; + if (s_mp_rand_source(&x, sizeof(x)) != MP_OKAY) { + fprintf(stderr, "s_mp_rand_source failed\n"); + exit(EXIT_FAILURE); + } + return x; +} + +static uint32_t uabs32(int32_t x) +{ + return x > 0 ? (uint32_t)x : -(uint32_t)x; +} + +static uint64_t uabs64(int64_t x) +{ + return x > 0 ? (uint64_t)x : -(uint64_t)x; +} + +/* This function prototype is needed + * to test dead code elimination + * which is used for feature detection. + * + * If the feature detection does not + * work as desired we will get a linker error. + */ +void does_not_exist(void); + +static int test_feature_detection(void) +{ +#define BN_TEST_FEATURE1_C + if (!MP_HAS(TEST_FEATURE1)) { + does_not_exist(); + return EXIT_FAILURE; + } + +#define BN_TEST_FEATURE2_C 1 + if (MP_HAS(TEST_FEATURE2)) { + does_not_exist(); + return EXIT_FAILURE; + } + +#define BN_TEST_FEATURE3_C 0 + if (MP_HAS(TEST_FEATURE3)) { + does_not_exist(); + return EXIT_FAILURE; + } + +#define BN_TEST_FEATURE4_C something + if (MP_HAS(TEST_FEATURE4)) { + does_not_exist(); + return EXIT_FAILURE; + } + + if (MP_HAS(TEST_FEATURE5)) { + does_not_exist(); + return EXIT_FAILURE; + } + + return EXIT_SUCCESS; +} + +static int test_trivial_stuff(void) +{ + mp_int a, b, c, d; + mp_err e; + if ((e = mp_init_multi(&a, &b, &c, &d, NULL)) != MP_OKAY) { + return EXIT_FAILURE; + } + (void)mp_error_to_string(e); + + /* a: 0->5 */ + mp_set(&a, 5u); + /* a: 5-> b: -5 */ + mp_neg(&a, &b); + if (mp_cmp(&a, &b) != MP_GT) { + goto LBL_ERR; + } + if (mp_cmp(&b, &a) != MP_LT) { + goto LBL_ERR; + } + /* a: 5-> a: -5 */ + mp_neg(&a, &a); + if (mp_cmp(&b, &a) != MP_EQ) { + goto LBL_ERR; + } + /* a: -5-> b: 5 */ + mp_abs(&a, &b); + if (mp_isneg(&b) != MP_NO) { + goto LBL_ERR; + } + /* a: -5-> b: -4 */ + mp_add_d(&a, 1uL, &b); + if (mp_isneg(&b) != MP_YES) { + goto LBL_ERR; + } + if (mp_get_i32(&b) != -4) { + goto LBL_ERR; + } + if (mp_get_u32(&b) != (uint32_t)-4) { + goto LBL_ERR; + } + if (mp_get_mag_u32(&b) != 4) { + goto LBL_ERR; + } + /* a: -5-> b: 1 */ + mp_add_d(&a, 6uL, &b); + if (mp_get_u32(&b) != 1) { + goto LBL_ERR; + } + /* a: -5-> a: 1 */ + mp_add_d(&a, 6uL, &a); + if (mp_get_u32(&a) != 1) { + goto LBL_ERR; + } + mp_zero(&a); + /* a: 0-> a: 6 */ + mp_add_d(&a, 6uL, &a); + if (mp_get_u32(&a) != 6) { + goto LBL_ERR; + } + + mp_set(&a, 42u); + mp_set(&b, 1u); + mp_neg(&b, &b); + mp_set(&c, 1u); + mp_exptmod(&a, &b, &c, &d); + + mp_set(&c, 7u); + mp_exptmod(&a, &b, &c, &d); + + if (mp_iseven(&a) == mp_isodd(&a)) { + goto LBL_ERR; + } + + mp_clear_multi(&a, &b, &c, &d, NULL); + return EXIT_SUCCESS; +LBL_ERR: + mp_clear_multi(&a, &b, &c, &d, NULL); + return EXIT_FAILURE; +} + +static int check_get_set_i32(mp_int *a, int32_t b) +{ + mp_clear(a); + if (mp_shrink(a) != MP_OKAY) return EXIT_FAILURE; + + mp_set_i32(a, b); + if (mp_shrink(a) != MP_OKAY) return EXIT_FAILURE; + if (mp_get_i32(a) != b) return EXIT_FAILURE; + if (mp_get_u32(a) != (uint32_t)b) return EXIT_FAILURE; + if (mp_get_mag_u32(a) != uabs32(b)) return EXIT_FAILURE; + + mp_set_u32(a, (uint32_t)b); + if (mp_get_u32(a) != (uint32_t)b) return EXIT_FAILURE; + if (mp_get_i32(a) != (int32_t)(uint32_t)b) return EXIT_FAILURE; + + return EXIT_SUCCESS; +} + +static int test_mp_get_set_i32(void) +{ + int i; + mp_int a; + + if (mp_init(&a) != MP_OKAY) { + return EXIT_FAILURE; + } + + check_get_set_i32(&a, 0); + check_get_set_i32(&a, -1); + check_get_set_i32(&a, 1); + check_get_set_i32(&a, INT32_MIN); + check_get_set_i32(&a, INT32_MAX); + + for (i = 0; i < 1000; ++i) { + int32_t b = rand_int32(); + if (check_get_set_i32(&a, b) != EXIT_SUCCESS) { + goto LBL_ERR; + } + } + + mp_clear(&a); + return EXIT_SUCCESS; +LBL_ERR: + mp_clear(&a); + return EXIT_FAILURE; +} + +static int check_get_set_i64(mp_int *a, int64_t b) +{ + mp_clear(a); + if (mp_shrink(a) != MP_OKAY) return EXIT_FAILURE; + + mp_set_i64(a, b); + if (mp_shrink(a) != MP_OKAY) return EXIT_FAILURE; + if (mp_get_i64(a) != b) return EXIT_FAILURE; + if (mp_get_u64(a) != (uint64_t)b) return EXIT_FAILURE; + if (mp_get_mag_u64(a) != uabs64(b)) return EXIT_FAILURE; + + mp_set_u64(a, (uint64_t)b); + if (mp_get_u64(a) != (uint64_t)b) return EXIT_FAILURE; + if (mp_get_i64(a) != (int64_t)(uint64_t)b) return EXIT_FAILURE; + + return EXIT_SUCCESS; +} + +static int test_mp_get_set_i64(void) +{ + int i; + mp_int a; + + if (mp_init(&a) != MP_OKAY) { + return EXIT_FAILURE; + } + + check_get_set_i64(&a, 0); + check_get_set_i64(&a, -1); + check_get_set_i64(&a, 1); + check_get_set_i64(&a, INT64_MIN); + check_get_set_i64(&a, INT64_MAX); + + for (i = 0; i < 1000; ++i) { + int64_t b = rand_int64(); + if (check_get_set_i64(&a, b) != EXIT_SUCCESS) { + goto LBL_ERR; + } + } + + mp_clear(&a); + return EXIT_SUCCESS; +LBL_ERR: + mp_clear(&a); + return EXIT_FAILURE; +} + +static int test_mp_fread_fwrite(void) +{ + mp_int a, b; + mp_err e; + FILE *tmp = NULL; + if ((e = mp_init_multi(&a, &b, NULL)) != MP_OKAY) { + return EXIT_FAILURE; + } + + mp_set_ul(&a, 123456uL); + tmp = tmpfile(); + if ((e = mp_fwrite(&a, 64, tmp)) != MP_OKAY) { + goto LBL_ERR; + } + rewind(tmp); + if ((e = mp_fread(&b, 64, tmp)) != MP_OKAY) { + goto LBL_ERR; + } + if (mp_get_u32(&b) != 123456uL) { + goto LBL_ERR; + } + fclose(tmp); + + mp_clear_multi(&a, &b, NULL); + return EXIT_SUCCESS; +LBL_ERR: + if (tmp != NULL) fclose(tmp); + mp_clear_multi(&a, &b, NULL); + return EXIT_FAILURE; +} + +static mp_err very_random_source(void *out, size_t size) +{ + memset(out, 0xff, size); + return MP_OKAY; +} + +static int test_mp_rand(void) +{ + mp_int a, b; + int n; + mp_err err; + if (mp_init_multi(&a, &b, NULL)!= MP_OKAY) { + return EXIT_FAILURE; + } + mp_rand_source(very_random_source); + for (n = 1; n < 1024; ++n) { + if ((err = mp_rand(&a, n)) != MP_OKAY) { + printf("Failed mp_rand() %s.\n", mp_error_to_string(err)); + break; + } + if ((err = mp_incr(&a)) != MP_OKAY) { + printf("Failed mp_incr() %s.\n", mp_error_to_string(err)); + break; + } + if ((err = mp_div_2d(&a, n * MP_DIGIT_BIT, &b, NULL)) != MP_OKAY) { + printf("Failed mp_div_2d() %s.\n", mp_error_to_string(err)); + break; + } + if (mp_cmp_d(&b, 1) != MP_EQ) { + ndraw(&a, "mp_rand() a"); + ndraw(&b, "mp_rand() b"); + err = MP_ERR; + break; + } + } + mp_rand_source(s_mp_rand_jenkins); + mp_clear_multi(&a, &b, NULL); + return err == MP_OKAY ? EXIT_SUCCESS : EXIT_FAILURE; +} + +static int test_mp_kronecker(void) +{ + struct mp_kronecker_st { + long n; + int c[21]; + }; + static struct mp_kronecker_st kronecker[] = { + /*-10, -9, -8, -7,-6, -5, -4, -3, -2, -1, 0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10*/ + { -10, { 0, -1, 0, -1, 0, 0, 0, 1, 0, -1, 0, 1, 0, -1, 0, 0, 0, 1, 0, 1, 0 } }, + { -9, { -1, 0, -1, 1, 0, -1, -1, 0, -1, -1, 0, 1, 1, 0, 1, 1, 0, -1, 1, 0, 1 } }, + { -8, { 0, -1, 0, 1, 0, 1, 0, -1, 0, -1, 0, 1, 0, 1, 0, -1, 0, -1, 0, 1, 0 } }, + { -7, { 1, -1, -1, 0, 1, 1, -1, 1, -1, -1, 0, 1, 1, -1, 1, -1, -1, 0, 1, 1, -1 } }, + { -6, { 0, 0, 0, -1, 0, -1, 0, 0, 0, -1, 0, 1, 0, 0, 0, 1, 0, 1, 0, 0, 0 } }, + { -5, { 0, -1, 1, -1, 1, 0, -1, -1, 1, -1, 0, 1, -1, 1, 1, 0, -1, 1, -1, 1, 0 } }, + { -4, { 0, -1, 0, 1, 0, -1, 0, 1, 0, -1, 0, 1, 0, -1, 0, 1, 0, -1, 0, 1, 0 } }, + { -3, { -1, 0, 1, -1, 0, 1, -1, 0, 1, -1, 0, 1, -1, 0, 1, -1, 0, 1, -1, 0, 1 } }, + { -2, { 0, -1, 0, 1, 0, 1, 0, -1, 0, -1, 0, 1, 0, 1, 0, -1, 0, -1, 0, 1, 0 } }, + { -1, { -1, -1, -1, 1, 1, -1, -1, 1, -1, -1, 1, 1, 1, -1, 1, 1, -1, -1, 1, 1, 1 } }, + { 0, { 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0 } }, + { 1, { 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1 } }, + { 2, { 0, 1, 0, 1, 0, -1, 0, -1, 0, 1, 0, 1, 0, -1, 0, -1, 0, 1, 0, 1, 0 } }, + { 3, { 1, 0, -1, -1, 0, -1, 1, 0, -1, 1, 0, 1, -1, 0, 1, -1, 0, -1, -1, 0, 1 } }, + { 4, { 0, 1, 0, 1, 0, 1, 0, 1, 0, 1, 0, 1, 0, 1, 0, 1, 0, 1, 0, 1, 0 } }, + { 5, { 0, 1, -1, -1, 1, 0, 1, -1, -1, 1, 0, 1, -1, -1, 1, 0, 1, -1, -1, 1, 0 } }, + { 6, { 0, 0, 0, -1, 0, 1, 0, 0, 0, 1, 0, 1, 0, 0, 0, 1, 0, -1, 0, 0, 0 } }, + { 7, { -1, 1, 1, 0, 1, -1, 1, 1, 1, 1, 0, 1, 1, 1, 1, -1, 1, 0, 1, 1, -1 } }, + { 8, { 0, 1, 0, 1, 0, -1, 0, -1, 0, 1, 0, 1, 0, -1, 0, -1, 0, 1, 0, 1, 0 } }, + { 9, { 1, 0, 1, 1, 0, 1, 1, 0, 1, 1, 0, 1, 1, 0, 1, 1, 0, 1, 1, 0, 1 } }, + { 10, { 0, 1, 0, -1, 0, 0, 0, 1, 0, 1, 0, 1, 0, 1, 0, 0, 0, -1, 0, 1, 0 } } + }; + + long k, m; + int i, cnt; + mp_err err; + mp_int a, b; + if (mp_init_multi(&a, &b, NULL)!= MP_OKAY) { + return EXIT_FAILURE; + } + + mp_set_ul(&a, 0uL); + mp_set_ul(&b, 1uL); + if ((err = mp_kronecker(&a, &b, &i)) != MP_OKAY) { + printf("Failed executing mp_kronecker(0 | 1) %s.\n", mp_error_to_string(err)); + goto LBL_ERR; + } + if (i != 1) { + printf("Failed trivial mp_kronecker(0 | 1) %d != 1\n", i); + goto LBL_ERR; + } + for (cnt = 0; cnt < (int)(sizeof(kronecker)/sizeof(kronecker[0])); ++cnt) { + k = kronecker[cnt].n; + mp_set_l(&a, k); + /* only test positive values of a */ + for (m = -10; m <= 10; m++) { + mp_set_l(&b, m); + if ((err = mp_kronecker(&a, &b, &i)) != MP_OKAY) { + printf("Failed executing mp_kronecker(%ld | %ld) %s.\n", kronecker[cnt].n, m, mp_error_to_string(err)); + goto LBL_ERR; + } + if ((err == MP_OKAY) && (i != kronecker[cnt].c[m + 10])) { + printf("Failed trivial mp_kronecker(%ld | %ld) %d != %d\n", kronecker[cnt].n, m, i, kronecker[cnt].c[m + 10]); + goto LBL_ERR; + } + } + } + + mp_clear_multi(&a, &b, NULL); + return EXIT_SUCCESS; +LBL_ERR: + mp_clear_multi(&a, &b, NULL); + return EXIT_FAILURE; +} + +static int test_mp_complement(void) +{ + int i; + + mp_int a, b, c; + if (mp_init_multi(&a, &b, &c, NULL)!= MP_OKAY) { + return EXIT_FAILURE; + } + + for (i = 0; i < 1000; ++i) { + long l = rand_long(); + mp_set_l(&a, l); + mp_complement(&a, &b); + + l = ~l; + mp_set_l(&c, l); + + if (mp_cmp(&b, &c) != MP_EQ) { + printf("\nmp_complement() bad result!"); + goto LBL_ERR; + } + } + + mp_clear_multi(&a, &b, &c, NULL); + return EXIT_SUCCESS; +LBL_ERR: + mp_clear_multi(&a, &b, &c, NULL); + return EXIT_FAILURE; +} + +static int test_mp_signed_rsh(void) +{ + int i; + + mp_int a, b, d; + if (mp_init_multi(&a, &b, &d, NULL)!= MP_OKAY) { + return EXIT_FAILURE; + } + + for (i = 0; i < 1000; ++i) { + long l; + int em; + + l = rand_long(); + mp_set_l(&a, l); + + em = abs(rand_int()) % 32; + + mp_set_l(&d, l >> em); + + mp_signed_rsh(&a, em, &b); + if (mp_cmp(&b, &d) != MP_EQ) { + printf("\nmp_signed_rsh() bad result!"); + goto LBL_ERR; + } + } + + mp_clear_multi(&a, &b, &d, NULL); + return EXIT_SUCCESS; +LBL_ERR: + mp_clear_multi(&a, &b, &d, NULL); + return EXIT_FAILURE; + +} + +static int test_mp_xor(void) +{ + int i; + + mp_int a, b, c, d; + if (mp_init_multi(&a, &b, &c, &d, NULL)!= MP_OKAY) { + return EXIT_FAILURE; + } + + for (i = 0; i < 1000; ++i) { + long l, em; + + l = rand_long(); + mp_set_l(&a,l); + + em = rand_long(); + mp_set_l(&b, em); + + mp_set_l(&d, l ^ em); + + mp_xor(&a, &b, &c); + if (mp_cmp(&c, &d) != MP_EQ) { + printf("\nmp_xor() bad result!"); + goto LBL_ERR; + } + } + + mp_clear_multi(&a, &b, &c, &d, NULL); + return EXIT_SUCCESS; +LBL_ERR: + mp_clear_multi(&a, &b, &c, &d, NULL); + return EXIT_FAILURE; + +} + +static int test_mp_or(void) +{ + int i; + + mp_int a, b, c, d; + if (mp_init_multi(&a, &b, &c, &d, NULL)!= MP_OKAY) { + return EXIT_FAILURE; + } + + for (i = 0; i < 1000; ++i) { + long l, em; + + l = rand_long(); + mp_set_l(&a, l); + + em = rand_long(); + mp_set_l(&b, em); + + mp_set_l(&d, l | em); + + mp_or(&a, &b, &c); + if (mp_cmp(&c, &d) != MP_EQ) { + printf("\nmp_or() bad result!"); + goto LBL_ERR; + } + } + + mp_clear_multi(&a, &b, &c, &d, NULL); + return EXIT_SUCCESS; +LBL_ERR: + mp_clear_multi(&a, &b, &c, &d, NULL); + return EXIT_FAILURE; +} + +static int test_mp_and(void) +{ + int i; + + mp_int a, b, c, d; + if (mp_init_multi(&a, &b, &c, &d, NULL)!= MP_OKAY) { + return EXIT_FAILURE; + } + + for (i = 0; i < 1000; ++i) { + long l, em; + + l = rand_long(); + mp_set_l(&a, l); + + em = rand_long(); + mp_set_l(&b, em); + + mp_set_l(&d, l & em); + + mp_and(&a, &b, &c); + if (mp_cmp(&c, &d) != MP_EQ) { + printf("\nmp_and() bad result!"); + goto LBL_ERR; + } + } + + mp_clear_multi(&a, &b, &c, &d, NULL); + return EXIT_SUCCESS; +LBL_ERR: + mp_clear_multi(&a, &b, &c, &d, NULL); + return EXIT_FAILURE; +} + +static int test_mp_invmod(void) +{ + mp_int a, b, c, d; + if (mp_init_multi(&a, &b, &c, &d, NULL)!= MP_OKAY) { + return EXIT_FAILURE; + } + + /* mp_invmod corner-case of https://github.com/libtom/libtommath/issues/118 */ + { + const char *a_ = "47182BB8DF0FFE9F61B1F269BACC066B48BA145D35137D426328DC3F88A5EA44"; + const char *b_ = "FFFFFFFEFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF00000000FFFFFFFFFFFFFFFF"; + const char *should_ = "0521A82E10376F8E4FDEF9A32A427AC2A0FFF686E00290D39E3E4B5522409596"; + + if (mp_read_radix(&a, a_, 16) != MP_OKAY) { + printf("\nmp_read_radix(a) failed!"); + goto LBL_ERR; + } + if (mp_read_radix(&b, b_, 16) != MP_OKAY) { + printf("\nmp_read_radix(b) failed!"); + goto LBL_ERR; + } + if (mp_read_radix(&c, should_, 16) != MP_OKAY) { + printf("\nmp_read_radix(should) failed!"); + goto LBL_ERR; + } + + if (mp_invmod(&a, &b, &d) != MP_OKAY) { + printf("\nmp_invmod() failed!"); + goto LBL_ERR; + } + + if (mp_cmp(&c, &d) != MP_EQ) { + printf("\nmp_invmod() bad result!"); + goto LBL_ERR; + } + } + + mp_clear_multi(&a, &b, &c, &d, NULL); + return EXIT_SUCCESS; +LBL_ERR: + mp_clear_multi(&a, &b, &c, &d, NULL); + return EXIT_FAILURE; + +} + +#if defined(__STDC_IEC_559__) || defined(__GCC_IEC_559) +static int test_mp_set_double(void) +{ + int i; + + mp_int a, b; + if (mp_init_multi(&a, &b, NULL)!= MP_OKAY) { + return EXIT_FAILURE; + } + + /* test mp_get_double/mp_set_double */ + if (mp_set_double(&a, +1.0/0.0) != MP_VAL) { + printf("\nmp_set_double should return MP_VAL for +inf"); + goto LBL_ERR; + } + if (mp_set_double(&a, -1.0/0.0) != MP_VAL) { + printf("\nmp_set_double should return MP_VAL for -inf"); + goto LBL_ERR; + } + if (mp_set_double(&a, +0.0/0.0) != MP_VAL) { + printf("\nmp_set_double should return MP_VAL for NaN"); + goto LBL_ERR; + } + if (mp_set_double(&a, -0.0/0.0) != MP_VAL) { + printf("\nmp_set_double should return MP_VAL for NaN"); + goto LBL_ERR; + } + + for (i = 0; i < 1000; ++i) { + int tmp = rand_int(); + double dbl = (double)tmp * rand_int() + 1; + if (mp_set_double(&a, dbl) != MP_OKAY) { + printf("\nmp_set_double() failed"); + goto LBL_ERR; + } + if (dbl != mp_get_double(&a)) { + printf("\nmp_get_double() bad result!"); + goto LBL_ERR; + } + if (mp_set_double(&a, -dbl) != MP_OKAY) { + printf("\nmp_set_double() failed"); + goto LBL_ERR; + } + if (-dbl != mp_get_double(&a)) { + printf("\nmp_get_double() bad result!"); + goto LBL_ERR; + } + } + + mp_clear_multi(&a, &b, NULL); + return EXIT_SUCCESS; +LBL_ERR: + mp_clear_multi(&a, &b, NULL); + return EXIT_FAILURE; + +} +#endif + +static int test_mp_get_u32(void) +{ + unsigned long t; + int i; + + mp_int a, b; + if (mp_init_multi(&a, &b, NULL)!= MP_OKAY) { + return EXIT_FAILURE; + } + + for (i = 0; i < 1000; ++i) { + t = (unsigned long)rand_long() & 0xFFFFFFFFuL; + mp_set_ul(&a, t); + if (t != mp_get_u32(&a)) { + printf("\nmp_get_u32() bad result!"); + goto LBL_ERR; + } + } + mp_set_ul(&a, 0uL); + if (mp_get_u32(&a) != 0) { + printf("\nmp_get_u32() bad result!"); + goto LBL_ERR; + } + mp_set_ul(&a, 0xFFFFFFFFuL); + if (mp_get_u32(&a) != 0xFFFFFFFFuL) { + printf("\nmp_get_u32() bad result!"); + goto LBL_ERR; + } + + mp_clear_multi(&a, &b, NULL); + return EXIT_SUCCESS; +LBL_ERR: + mp_clear_multi(&a, &b, NULL); + return EXIT_FAILURE; +} + +static int test_mp_get_ul(void) +{ + unsigned long s, t; + int i; + + mp_int a, b; + if (mp_init_multi(&a, &b, NULL)!= MP_OKAY) { + return EXIT_FAILURE; + } + + for (i = 0; i < ((int)MP_SIZEOF_BITS(unsigned long) - 1); ++i) { + t = (1UL << (i+1)) - 1; + if (!t) + t = ~0UL; + printf(" t = 0x%lx i = %d\r", t, i); + do { + mp_set_ul(&a, t); + s = mp_get_ul(&a); + if (s != t) { + printf("\nmp_get_ul() bad result! 0x%lx != 0x%lx", s, t); + goto LBL_ERR; + } + t <<= 1; + } while (t != 0uL); + } + + mp_clear_multi(&a, &b, NULL); + return EXIT_SUCCESS; +LBL_ERR: + mp_clear_multi(&a, &b, NULL); + return EXIT_FAILURE; +} + +static int test_mp_get_u64(void) +{ + unsigned long long q, r; + int i; + + mp_int a, b; + if (mp_init_multi(&a, &b, NULL)!= MP_OKAY) { + return EXIT_FAILURE; + } + + for (i = 0; i < (int)(MP_SIZEOF_BITS(unsigned long long) - 1); ++i) { + r = (1ULL << (i+1)) - 1; + if (!r) + r = ~0ULL; + printf(" r = 0x%llx i = %d\r", r, i); + do { + mp_set_u64(&a, r); + q = mp_get_u64(&a); + if (q != r) { + printf("\nmp_get_u64() bad result! 0x%llx != 0x%llx", q, r); + goto LBL_ERR; + } + r <<= 1; + } while (r != 0uLL); + } + + mp_clear_multi(&a, &b, NULL); + return EXIT_SUCCESS; +LBL_ERR: + mp_clear_multi(&a, &b, NULL); + return EXIT_FAILURE; + +} + +static int test_mp_sqrt(void) +{ + int i, n; + + mp_int a, b, c; + if (mp_init_multi(&a, &b, &c, NULL)!= MP_OKAY) { + return EXIT_FAILURE; + } + + for (i = 0; i < 1000; ++i) { + printf("%6d\r", i); + fflush(stdout); + n = (rand_int() & 15) + 1; + mp_rand(&a, n); + if (mp_sqrt(&a, &b) != MP_OKAY) { + printf("\nmp_sqrt() error!"); + goto LBL_ERR; + } + mp_root_u32(&a, 2uL, &c); + if (mp_cmp_mag(&b, &c) != MP_EQ) { + printf("mp_sqrt() bad result!\n"); + goto LBL_ERR; + } + } + + mp_clear_multi(&a, &b, &c, NULL); + return EXIT_SUCCESS; +LBL_ERR: + mp_clear_multi(&a, &b, &c, NULL); + return EXIT_FAILURE; +} + +static int test_mp_is_square(void) +{ + int i, n; + + mp_int a, b; + mp_bool res; + + if (mp_init_multi(&a, &b, NULL)!= MP_OKAY) { + return EXIT_FAILURE; + } + + for (i = 0; i < 1000; ++i) { + printf("%6d\r", i); + fflush(stdout); + + /* test mp_is_square false negatives */ + n = (rand_int() & 7) + 1; + mp_rand(&a, n); + mp_sqr(&a, &a); + if (mp_is_square(&a, &res) != MP_OKAY) { + printf("\nfn:mp_is_square() error!"); + goto LBL_ERR; + } + if (res == MP_NO) { + printf("\nfn:mp_is_square() bad result!"); + goto LBL_ERR; + } + + /* test for false positives */ + mp_add_d(&a, 1uL, &a); + if (mp_is_square(&a, &res) != MP_OKAY) { + printf("\nfp:mp_is_square() error!"); + goto LBL_ERR; + } + if (res == MP_YES) { + printf("\nfp:mp_is_square() bad result!"); + goto LBL_ERR; + } + + } + printf("\n\n"); + + mp_clear_multi(&a, &b, NULL); + return EXIT_SUCCESS; +LBL_ERR: + mp_clear_multi(&a, &b, NULL); + return EXIT_FAILURE; +} + +static int test_mp_sqrtmod_prime(void) +{ + struct mp_sqrtmod_prime_st { + unsigned long p; + unsigned long n; + mp_digit r; + }; + + static struct mp_sqrtmod_prime_st sqrtmod_prime[] = { + { 5, 14, 3 }, + { 7, 9, 4 }, + { 113, 2, 62 } + }; + int i; + + mp_int a, b, c; + if (mp_init_multi(&a, &b, &c, NULL)!= MP_OKAY) { + return EXIT_FAILURE; + } + + /* r^2 = n (mod p) */ + for (i = 0; i < (int)(sizeof(sqrtmod_prime)/sizeof(sqrtmod_prime[0])); ++i) { + mp_set_ul(&a, sqrtmod_prime[i].p); + mp_set_ul(&b, sqrtmod_prime[i].n); + if (mp_sqrtmod_prime(&b, &a, &c) != MP_OKAY) { + printf("Failed executing %d. mp_sqrtmod_prime\n", (i+1)); + goto LBL_ERR; + } + if (mp_cmp_d(&c, sqrtmod_prime[i].r) != MP_EQ) { + printf("Failed %d. trivial mp_sqrtmod_prime\n", (i+1)); + ndraw(&c, "r"); + goto LBL_ERR; + } + } + + mp_clear_multi(&a, &b, &c, NULL); + return EXIT_SUCCESS; +LBL_ERR: + mp_clear_multi(&a, &b, &c, NULL); + return EXIT_FAILURE; +} + +static int test_mp_prime_rand(void) +{ + int ix; + mp_err err; + mp_int a, b; + if (mp_init_multi(&a, &b, NULL)!= MP_OKAY) { + return EXIT_FAILURE; + } + + /* test for size */ + for (ix = 10; ix < 128; ix++) { + printf("Testing (not safe-prime): %9d bits \r", ix); + fflush(stdout); + err = mp_prime_rand(&a, 8, ix, (rand_int() & 1) ? 0 : MP_PRIME_2MSB_ON); + if (err != MP_OKAY) { + printf("\nfailed with error: %s\n", mp_error_to_string(err)); + goto LBL_ERR; + } + if (mp_count_bits(&a) != ix) { + printf("Prime is %d not %d bits!!!\n", mp_count_bits(&a), ix); + goto LBL_ERR; + } + } + printf("\n"); + + mp_clear_multi(&a, &b, NULL); + return EXIT_SUCCESS; +LBL_ERR: + mp_clear_multi(&a, &b, NULL); + return EXIT_FAILURE; +} + +static int test_mp_prime_is_prime(void) +{ + int ix; + mp_err err; + mp_bool cnt, fu; + + mp_int a, b; + if (mp_init_multi(&a, &b, NULL)!= MP_OKAY) { + return EXIT_FAILURE; + } + + /* strong Miller-Rabin pseudoprime to the first 200 primes (F. Arnault) */ + puts("Testing mp_prime_is_prime() with Arnault's pseudoprime 803...901 \n"); + mp_read_radix(&a, + "91xLNF3roobhzgTzoFIG6P13ZqhOVYSN60Fa7Cj2jVR1g0k89zdahO9/kAiRprpfO1VAp1aBHucLFV/qLKLFb+zonV7R2Vxp1K13ClwUXStpV0oxTNQVjwybmFb5NBEHImZ6V7P6+udRJuH8VbMEnS0H8/pSqQrg82OoQQ2fPpAk6G1hkjqoCv5s/Yr", + 64); + mp_prime_is_prime(&a, mp_prime_rabin_miller_trials(mp_count_bits(&a)), &cnt); + if (cnt == MP_YES) { + printf("Arnault's pseudoprime is not prime but mp_prime_is_prime says it is.\n"); + goto LBL_ERR; + } + /* About the same size as Arnault's pseudoprime */ + puts("Testing mp_prime_is_prime() with certified prime 2^1119 + 53\n"); + mp_set(&a, 1uL); + mp_mul_2d(&a,1119,&a); + mp_add_d(&a, 53uL, &a); + err = mp_prime_is_prime(&a, mp_prime_rabin_miller_trials(mp_count_bits(&a)), &cnt); + /* small problem */ + if (err != MP_OKAY) { + printf("\nfailed with error: %s\n", mp_error_to_string(err)); + } + /* large problem */ + if (cnt == MP_NO) { + printf("A certified prime is a prime but mp_prime_is_prime says it is not.\n"); + } + if ((err != MP_OKAY) || (cnt == MP_NO)) { + printf("prime tested was: 0x"); + mp_fwrite(&a,16,stdout); + putchar('\n'); + goto LBL_ERR; + } + for (ix = 16; ix < 128; ix++) { + printf("Testing ( safe-prime): %9d bits \r", ix); + fflush(stdout); + err = mp_prime_rand(&a, 8, ix, ((rand_int() & 1) ? 0 : MP_PRIME_2MSB_ON) | MP_PRIME_SAFE); + if (err != MP_OKAY) { + printf("\nfailed with error: %s\n", mp_error_to_string(err)); + goto LBL_ERR; + } + if (mp_count_bits(&a) != ix) { + printf("Prime is %d not %d bits!!!\n", mp_count_bits(&a), ix); + goto LBL_ERR; + } + /* let's see if it's really a safe prime */ + mp_sub_d(&a, 1uL, &b); + mp_div_2(&b, &b); + err = mp_prime_is_prime(&b, mp_prime_rabin_miller_trials(mp_count_bits(&b)), &cnt); + /* small problem */ + if (err != MP_OKAY) { + printf("\nfailed with error: %s\n", mp_error_to_string(err)); + } + /* large problem */ + if (cnt == MP_NO) { + printf("\nsub is not prime!\n"); + } + mp_prime_frobenius_underwood(&b, &fu); + if (fu == MP_NO) { + printf("\nfrobenius-underwood says sub is not prime!\n"); + } + if ((err != MP_OKAY) || (cnt == MP_NO)) { + printf("prime tested was: 0x"); + mp_fwrite(&a,16,stdout); + putchar('\n'); + printf("sub tested was: 0x"); + mp_fwrite(&b,16,stdout); + putchar('\n'); + goto LBL_ERR; + } + + } + /* Check regarding problem #143 */ +#ifndef MP_8BIT + mp_read_radix(&a, + "FFFFFFFFFFFFFFFFC90FDAA22168C234C4C6628B80DC1CD129024E088A67CC74020BBEA63B139B22514A08798E3404DDEF9519B3CD3A431B302B0A6DF25F14374FE1356D6D51C245E485B576625E7EC6F44C42E9A63A3620FFFFFFFFFFFFFFFF", + 16); + err = mp_prime_strong_lucas_selfridge(&a, &cnt); + /* small problem */ + if (err != MP_OKAY) { + printf("\nmp_prime_strong_lucas_selfridge failed with error: %s\n", mp_error_to_string(err)); + } + /* large problem */ + if (cnt == MP_NO) { + printf("\n\nissue #143 - mp_prime_strong_lucas_selfridge FAILED!\n"); + } + if ((err != MP_OKAY) || (cnt == MP_NO)) { + printf("prime tested was: 0x"); + mp_fwrite(&a,16,stdout); + putchar('\n'); + goto LBL_ERR; + } +#endif + + printf("\n\n"); + + mp_clear_multi(&a, &b, NULL); + return EXIT_SUCCESS; +LBL_ERR: + mp_clear_multi(&a, &b, NULL); + return EXIT_FAILURE; + +} + + +static int test_mp_prime_next_prime(void) +{ + mp_err err; + mp_int a, b, c; + + mp_init_multi(&a, &b, &c, NULL); + + + /* edge cases */ + mp_set(&a, 0u); + if ((err = mp_prime_next_prime(&a, 5, 0)) != MP_OKAY) { + goto LBL_ERR; + } + if (mp_cmp_d(&a, 2u) != MP_EQ) { + printf("mp_prime_next_prime: output should have been 2 but was: "); + mp_fwrite(&a,10,stdout); + putchar('\n'); + goto LBL_ERR; + } + + mp_set(&a, 0u); + if ((err = mp_prime_next_prime(&a, 5, 1)) != MP_OKAY) { + goto LBL_ERR; + } + if (mp_cmp_d(&a, 3u) != MP_EQ) { + printf("mp_prime_next_prime: output should have been 3 but was: "); + mp_fwrite(&a,10,stdout); + putchar('\n'); + goto LBL_ERR; + } + + mp_set(&a, 2u); + if ((err = mp_prime_next_prime(&a, 5, 0)) != MP_OKAY) { + goto LBL_ERR; + } + if (mp_cmp_d(&a, 3u) != MP_EQ) { + printf("mp_prime_next_prime: output should have been 3 but was: "); + mp_fwrite(&a,10,stdout); + putchar('\n'); + goto LBL_ERR; + } + + mp_set(&a, 2u); + if ((err = mp_prime_next_prime(&a, 5, 1)) != MP_OKAY) { + goto LBL_ERR; + } + if (mp_cmp_d(&a, 3u) != MP_EQ) { + printf("mp_prime_next_prime: output should have been 3 but was: "); + mp_fwrite(&a,10,stdout); + putchar('\n'); + goto LBL_ERR; + } + mp_set(&a, 8); + if ((err = mp_prime_next_prime(&a, 5, 1)) != MP_OKAY) { + goto LBL_ERR; + } + if (mp_cmp_d(&a, 11u) != MP_EQ) { + printf("mp_prime_next_prime: output should have been 11 but was: "); + mp_fwrite(&a,10,stdout); + putchar('\n'); + goto LBL_ERR; + } + /* 2^300 + 157 is a 300 bit large prime to guarantee a multi-limb bigint */ + if ((err = mp_2expt(&a, 300)) != MP_OKAY) { + goto LBL_ERR; + } + mp_set_u32(&b, 157); + if ((err = mp_add(&a, &b, &a)) != MP_OKAY) { + goto LBL_ERR; + } + if ((err = mp_copy(&a, &b)) != MP_OKAY) { + goto LBL_ERR; + } + + /* 2^300 + 385 is the next prime */ + mp_set_u32(&c, 228); + if ((err = mp_add(&b, &c, &b)) != MP_OKAY) { + goto LBL_ERR; + } + if ((err = mp_prime_next_prime(&a, 5, 0)) != MP_OKAY) { + goto LBL_ERR; + } + if (mp_cmp(&a, &b) != MP_EQ) { + printf("mp_prime_next_prime: output should have been\n"); + mp_fwrite(&b,10,stdout); + putchar('\n'); + printf("but was:\n"); + mp_fwrite(&a,10,stdout); + putchar('\n'); + goto LBL_ERR; + } + + /* Use another temporary variable or recompute? Mmh... */ + if ((err = mp_2expt(&a, 300)) != MP_OKAY) { + goto LBL_ERR; + } + mp_set_u32(&b, 157); + if ((err = mp_add(&a, &b, &a)) != MP_OKAY) { + goto LBL_ERR; + } + if ((err = mp_copy(&a, &b)) != MP_OKAY) { + goto LBL_ERR; + } + + /* 2^300 + 631 is the next prime congruent to 3 mod 4*/ + mp_set_u32(&c, 474); + if ((err = mp_add(&b, &c, &b)) != MP_OKAY) { + goto LBL_ERR; + } + if ((err = mp_prime_next_prime(&a, 5, 1)) != MP_OKAY) { + goto LBL_ERR; + } + if (mp_cmp(&a, &b) != MP_EQ) { + printf("mp_prime_next_prime (bbs): output should have been\n"); + mp_fwrite(&b,10,stdout); + putchar('\n'); + printf("but was:\n"); + mp_fwrite(&a,10,stdout); + putchar('\n'); + goto LBL_ERR; + } + + mp_clear_multi(&a, &b, &c, NULL); + return EXIT_SUCCESS; +LBL_ERR: + mp_clear_multi(&a, &b, &c, NULL); + return EXIT_FAILURE; +} + +static int test_mp_montgomery_reduce(void) +{ + mp_digit mp; + int ix, i, n; + char buf[4096]; + + /* size_t written; */ + + mp_int a, b, c, d, e; + if (mp_init_multi(&a, &b, &c, &d, &e, NULL)!= MP_OKAY) { + return EXIT_FAILURE; + } + + /* test montgomery */ + for (i = 1; i <= 10; i++) { + if (i == 10) + i = 1000; + printf(" digit size: %2d\r", i); + fflush(stdout); + for (n = 0; n < 1000; n++) { + mp_rand(&a, i); + a.dp[0] |= 1; + + /* let's see if R is right */ + mp_montgomery_calc_normalization(&b, &a); + mp_montgomery_setup(&a, &mp); + + /* now test a random reduction */ + for (ix = 0; ix < 100; ix++) { + mp_rand(&c, 1 + abs(rand_int()) % (2*i)); + mp_copy(&c, &d); + mp_copy(&c, &e); + + mp_mod(&d, &a, &d); + mp_montgomery_reduce(&c, &a, mp); + mp_mulmod(&c, &b, &a, &c); + + if (mp_cmp(&c, &d) != MP_EQ) { +/* *INDENT-OFF* */ + printf("d = e mod a, c = e MOD a\n"); + mp_to_decimal(&a, buf, sizeof(buf)); printf("a = %s\n", buf); + mp_to_decimal(&e, buf, sizeof(buf)); printf("e = %s\n", buf); + mp_to_decimal(&d, buf, sizeof(buf)); printf("d = %s\n", buf); + mp_to_decimal(&c, buf, sizeof(buf)); printf("c = %s\n", buf); + + printf("compare no compare!\n"); goto LBL_ERR; +/* *INDENT-ON* */ + } + /* only one big montgomery reduction */ + if (i > 10) { + n = 1000; + ix = 100; + } + } + } + } + + printf("\n\n"); + + mp_clear_multi(&a, &b, &c, &d, &e, NULL); + return EXIT_SUCCESS; +LBL_ERR: + mp_clear_multi(&a, &b, &c, &d, &e, NULL); + return EXIT_FAILURE; + +} + +static int test_mp_read_radix(void) +{ + char buf[4096]; + size_t written; + mp_err err; + + mp_int a; + if (mp_init_multi(&a, NULL)!= MP_OKAY) goto LTM_ERR; + + if ((err = mp_read_radix(&a, "123456", 10)) != MP_OKAY) goto LTM_ERR; + + if ((err = mp_to_radix(&a, buf, SIZE_MAX, &written, 10)) != MP_OKAY) goto LTM_ERR; + printf(" '123456' a == %s, length = %zu\n", buf, written); + + /* See comment in bn_mp_to_radix.c */ + /* + if( (err = mp_to_radix(&a, buf, 3u, &written, 10) ) != MP_OKAY) goto LTM_ERR; + printf(" '56' a == %s, length = %zu\n", buf, written); + + if( (err = mp_to_radix(&a, buf, 4u, &written, 10) ) != MP_OKAY) goto LTM_ERR; + printf(" '456' a == %s, length = %zu\n", buf, written); + if( (err = mp_to_radix(&a, buf, 30u, &written, 10) ) != MP_OKAY) goto LTM_ERR; + printf(" '123456' a == %s, length = %zu, error = %s\n", + buf, written, mp_error_to_string(err)); + */ + if ((err = mp_read_radix(&a, "-123456", 10)) != MP_OKAY) goto LTM_ERR; + if ((err = mp_to_radix(&a, buf, SIZE_MAX, &written, 10)) != MP_OKAY) goto LTM_ERR; + printf(" '-123456' a == %s, length = %zu\n", buf, written); + + if ((err = mp_read_radix(&a, "0", 10)) != MP_OKAY) goto LTM_ERR; + if ((err = mp_to_radix(&a, buf, SIZE_MAX, &written, 10)) != MP_OKAY) goto LTM_ERR; + printf(" '0' a == %s, length = %zu\n", buf, written); + + + + /* Although deprecated it needs to function as long as it isn't dropped */ + /* + printf("Testing deprecated mp_toradix_n\n"); + if( (err = mp_read_radix(&a, "-123456", 10) ) != MP_OKAY) goto LTM_ERR; + if( (err = mp_toradix_n(&a, buf, 10, 3) ) != MP_OKAY) goto LTM_ERR; + printf("a == %s\n", buf); + if( (err = mp_toradix_n(&a, buf, 10, 4) ) != MP_OKAY) goto LTM_ERR; + printf("a == %s\n", buf); + if( (err = mp_toradix_n(&a, buf, 10, 30) ) != MP_OKAY) goto LTM_ERR; + printf("a == %s\n", buf); + */ + + + while (0) { + char *s = fgets(buf, sizeof(buf), stdin); + if (s != buf) break; + mp_read_radix(&a, buf, 10); + mp_prime_next_prime(&a, 5, 1); + mp_to_radix(&a, buf, sizeof(buf), NULL, 10); + printf("%s, %lu\n", buf, (unsigned long)a.dp[0] & 3uL); + } + + mp_clear(&a); + return EXIT_SUCCESS; +LTM_ERR: + mp_clear(&a); + return EXIT_FAILURE; +} + +static int test_mp_cnt_lsb(void) +{ + int ix; + + mp_int a, b; + if (mp_init_multi(&a, &b, NULL)!= MP_OKAY) { + return EXIT_FAILURE; + } + + mp_set(&a, 1uL); + for (ix = 0; ix < 1024; ix++) { + if (mp_cnt_lsb(&a) != ix) { + printf("Failed at %d, %d\n", ix, mp_cnt_lsb(&a)); + goto LBL_ERR; + } + mp_mul_2(&a, &a); + } + + mp_clear_multi(&a, &b, NULL); + return EXIT_SUCCESS; +LBL_ERR: + mp_clear_multi(&a, &b, NULL); + return EXIT_FAILURE; + +} + +static int test_mp_reduce_2k(void) +{ + int ix, cnt; + + mp_int a, b, c, d; + if (mp_init_multi(&a, &b, &c, &d, NULL)!= MP_OKAY) { + return EXIT_FAILURE; + } + + /* test mp_reduce_2k */ + for (cnt = 3; cnt <= 128; ++cnt) { + mp_digit tmp; + + mp_2expt(&a, cnt); + mp_sub_d(&a, 2uL, &a); /* a = 2**cnt - 2 */ + + printf("\r %4d bits", cnt); + printf("(%d)", mp_reduce_is_2k(&a)); + mp_reduce_2k_setup(&a, &tmp); + printf("(%lu)", (unsigned long) tmp); + for (ix = 0; ix < 1000; ix++) { + if (!(ix & 127)) { + printf("."); + fflush(stdout); + } + mp_rand(&b, (cnt / MP_DIGIT_BIT + 1) * 2); + mp_copy(&c, &b); + mp_mod(&c, &a, &c); + mp_reduce_2k(&b, &a, 2uL); + if (mp_cmp(&c, &b) != MP_EQ) { + printf("FAILED\n"); + goto LBL_ERR; + } + } + } + + mp_clear_multi(&a, &b, &c, &d, NULL); + return EXIT_SUCCESS; +LBL_ERR: + mp_clear_multi(&a, &b, &c, &d, NULL); + return EXIT_FAILURE; +} + +static int test_mp_div_3(void) +{ + int cnt; + + mp_int a, b, c, d, e; + if (mp_init_multi(&a, &b, &c, &d, &e, NULL)!= MP_OKAY) { + return EXIT_FAILURE; + } + + /* test mp_div_3 */ + mp_set(&d, 3uL); + for (cnt = 0; cnt < 10000;) { + mp_digit r2; + + if (!(++cnt & 127)) { + printf("%9d\r", cnt); + fflush(stdout); + } + mp_rand(&a, abs(rand_int()) % 128 + 1); + mp_div(&a, &d, &b, &e); + mp_div_3(&a, &c, &r2); + + if (mp_cmp(&b, &c) || mp_cmp_d(&e, r2)) { + printf("\nmp_div_3 => Failure\n"); + goto LBL_ERR; + } + } + printf("\nPassed div_3 testing"); + + mp_clear_multi(&a, &b, &c, &d, &e, NULL); + return EXIT_SUCCESS; +LBL_ERR: + mp_clear_multi(&a, &b, &c, &d, &e, NULL); + return EXIT_FAILURE; +} + +static int test_mp_dr_reduce(void) +{ + mp_digit mp; + int cnt; + unsigned rr; + int ix; + + mp_int a, b, c; + if (mp_init_multi(&a, &b, &c, NULL)!= MP_OKAY) { + return EXIT_FAILURE; + } + + /* test the DR reduction */ + for (cnt = 2; cnt < 32; cnt++) { + printf("\r%d digit modulus", cnt); + mp_grow(&a, cnt); + mp_zero(&a); + for (ix = 1; ix < cnt; ix++) { + a.dp[ix] = MP_MASK; + } + a.used = cnt; + a.dp[0] = 3; + + mp_rand(&b, cnt - 1); + mp_copy(&b, &c); + + rr = 0; + do { + if (!(rr & 127)) { + printf("."); + fflush(stdout); + } + mp_sqr(&b, &b); + mp_add_d(&b, 1uL, &b); + mp_copy(&b, &c); + + mp_mod(&b, &a, &b); + mp_dr_setup(&a, &mp); + mp_dr_reduce(&c, &a, mp); + + if (mp_cmp(&b, &c) != MP_EQ) { + printf("Failed on trial %u\n", rr); + goto LBL_ERR; + } + } while (++rr < 500); + printf(" passed"); + fflush(stdout); + } + + mp_clear_multi(&a, &b, &c, NULL); + return EXIT_SUCCESS; +LBL_ERR: + mp_clear_multi(&a, &b, &c, NULL); + return EXIT_FAILURE; +} + +static int test_mp_reduce_2k_l(void) +{ +# if LTM_DEMO_TEST_REDUCE_2K_L + mp_int a, b, c, d; + int cnt; + char buf[4096]; + size_t length[1]; + if (mp_init_multi(&a, &b, NULL)!= MP_OKAY) { + return EXIT_FAILURE; + } + /* test the mp_reduce_2k_l code */ +# if LTM_DEMO_TEST_REDUCE_2K_L == 1 + /* first load P with 2^1024 - 0x2A434 B9FDEC95 D8F9D550 FFFFFFFF FFFFFFFF */ + mp_2expt(&a, 1024); + mp_read_radix(&b, "2A434B9FDEC95D8F9D550FFFFFFFFFFFFFFFF", 16); + mp_sub(&a, &b, &a); +# elif LTM_DEMO_TEST_REDUCE_2K_L == 2 + /* p = 2^2048 - 0x1 00000000 00000000 00000000 00000000 4945DDBF 8EA2A91D 5776399B B83E188F */ + mp_2expt(&a, 2048); + mp_read_radix(&b, + "1000000000000000000000000000000004945DDBF8EA2A91D5776399BB83E188F", + 16); + mp_sub(&a, &b, &a); +# else +# error oops +# endif + *length = sizeof(buf); + mp_to_radix(&a, buf, length, 10); + printf("\n\np==%s, length = %zu\n", buf, *length); + /* now mp_reduce_is_2k_l() should return */ + if (mp_reduce_is_2k_l(&a) != 1) { + printf("mp_reduce_is_2k_l() return 0, should be 1\n"); + goto LBL_ERR; + } + mp_reduce_2k_setup_l(&a, &d); + /* now do a million square+1 to see if it varies */ + mp_rand(&b, 64); + mp_mod(&b, &a, &b); + mp_copy(&b, &c); + printf("Testing: mp_reduce_2k_l..."); + fflush(stdout); + for (cnt = 0; cnt < (int)(1uL << 20); cnt++) { + mp_sqr(&b, &b); + mp_add_d(&b, 1uL, &b); + mp_reduce_2k_l(&b, &a, &d); + mp_sqr(&c, &c); + mp_add_d(&c, 1uL, &c); + mp_mod(&c, &a, &c); + if (mp_cmp(&b, &c) != MP_EQ) { + printf("mp_reduce_2k_l() failed at step %d\n", cnt); + mp_to_hex(&b, buf, sizeof(buf)); + printf("b == %s\n", buf); + mp_to_hex(&c, buf, sizeof(buf)); + printf("c == %s\n", buf); + goto LBL_ERR; + } + } + + mp_clear_multi(&a, &b, NULL); + return EXIT_SUCCESS; +LBL_ERR: + mp_clear_multi(&a, &b, NULL); + return EXIT_FAILURE; +#else + return EXIT_SUCCESS; +# endif /* LTM_DEMO_TEST_REDUCE_2K_L */ +} +/* stripped down version of mp_radix_size. The faster version can be off by up t +o +3 */ +/* TODO: This function should be removed, replaced by mp_radix_size, mp_radix_size_overestimate in 2.0 */ +static mp_err s_rs(const mp_int *a, int radix, uint32_t *size) +{ + mp_err res; + uint32_t digs = 0u; + mp_int t; + mp_digit d; + *size = 0u; + if (mp_iszero(a) == MP_YES) { + *size = 2u; + return MP_OKAY; + } + if (radix == 2) { + *size = (uint32_t)mp_count_bits(a) + 1u; + return MP_OKAY; + } + if ((res = mp_init_copy(&t, a)) != MP_OKAY) { + return res; + } + t.sign = MP_ZPOS; + while (mp_iszero(&t) == MP_NO) { + if ((res = mp_div_d(&t, (mp_digit)radix, &t, &d)) != MP_OKAY) { + mp_clear(&t); + return res; + } + ++digs; + } + mp_clear(&t); + *size = digs + 1; + return MP_OKAY; +} +static int test_mp_log_u32(void) +{ + mp_int a; + mp_digit d; + uint32_t base, lb, size; + const uint32_t max_base = MP_MIN(UINT32_MAX, MP_DIGIT_MAX); + + if (mp_init(&a) != MP_OKAY) { + goto LBL_ERR; + } + + /* + base a result + 0 x MP_VAL + 1 x MP_VAL + */ + mp_set(&a, 42uL); + base = 0u; + if (mp_log_u32(&a, base, &lb) != MP_VAL) { + goto LBL_ERR; + } + base = 1u; + if (mp_log_u32(&a, base, &lb) != MP_VAL) { + goto LBL_ERR; + } + /* + base a result + 2 0 MP_VAL + 2 1 0 + 2 2 1 + 2 3 1 + */ + base = 2u; + mp_zero(&a); + if (mp_log_u32(&a, base, &lb) != MP_VAL) { + goto LBL_ERR; + } + + for (d = 1; d < 4; d++) { + mp_set(&a, d); + if (mp_log_u32(&a, base, &lb) != MP_OKAY) { + goto LBL_ERR; + } + if (lb != ((d == 1)?0uL:1uL)) { + goto LBL_ERR; + } + } + /* + base a result + 3 0 MP_VAL + 3 1 0 + 3 2 0 + 3 3 1 + */ + base = 3u; + mp_zero(&a); + if (mp_log_u32(&a, base, &lb) != MP_VAL) { + goto LBL_ERR; + } + for (d = 1; d < 4; d++) { + mp_set(&a, d); + if (mp_log_u32(&a, base, &lb) != MP_OKAY) { + goto LBL_ERR; + } + if (lb != ((d < base)?0uL:1uL)) { + goto LBL_ERR; + } + } + + /* + bases 2..64 with "a" a random large constant. + The range of bases tested allows to check with + radix_size. + */ + if (mp_rand(&a, 10) != MP_OKAY) { + goto LBL_ERR; + } + for (base = 2u; base < 65u; base++) { + if (mp_log_u32(&a, base, &lb) != MP_OKAY) { + goto LBL_ERR; + } + if (s_rs(&a,(int)base, &size) != MP_OKAY) { + goto LBL_ERR; + } + /* radix_size includes the memory needed for '\0', too*/ + size -= 2; + if (lb != size) { + goto LBL_ERR; + } + } + + /* + bases 2..64 with "a" a random small constant to + test the part of mp_ilogb that uses native types. + */ + if (mp_rand(&a, 1) != MP_OKAY) { + goto LBL_ERR; + } + for (base = 2u; base < 65u; base++) { + if (mp_log_u32(&a, base, &lb) != MP_OKAY) { + goto LBL_ERR; + } + if (s_rs(&a,(int)base, &size) != MP_OKAY) { + goto LBL_ERR; + } + size -= 2; + if (lb != size) { + goto LBL_ERR; + } + } + + /*Test upper edgecase with base UINT32_MAX and number (UINT32_MAX/2)*UINT32_MAX^10 */ + mp_set(&a, max_base); + if (mp_expt_u32(&a, 10uL, &a) != MP_OKAY) { + goto LBL_ERR; + } + if (mp_add_d(&a, max_base / 2, &a) != MP_OKAY) { + goto LBL_ERR; + } + if (mp_log_u32(&a, max_base, &lb) != MP_OKAY) { + goto LBL_ERR; + } + if (lb != 10u) { + goto LBL_ERR; + } + + mp_clear(&a); + return EXIT_SUCCESS; +LBL_ERR: + mp_clear(&a); + return EXIT_FAILURE; +} + +static int test_mp_incr(void) +{ + mp_int a, b; + mp_err e = MP_OKAY; + + if ((e = mp_init_multi(&a, &b, NULL)) != MP_OKAY) { + goto LTM_ERR; + } + + /* Does it increment inside the limits of a MP_xBIT limb? */ + mp_set(&a, MP_MASK/2); + if ((e = mp_incr(&a)) != MP_OKAY) { + goto LTM_ERR; + } + if (mp_cmp_d(&a, (MP_MASK/2uL) + 1uL) != MP_EQ) { + goto LTM_ERR; + } + + /* Does it increment outside of the limits of a MP_xBIT limb? */ + mp_set(&a, MP_MASK); + mp_set(&b, MP_MASK); + if ((e = mp_incr(&a)) != MP_OKAY) { + goto LTM_ERR; + } + if ((e = mp_add_d(&b, 1uL, &b)) != MP_OKAY) { + goto LTM_ERR; + } + if (mp_cmp(&a, &b) != MP_EQ) { + goto LTM_ERR; + } + + /* Does it increment from -1 to 0? */ + mp_set(&a, 1uL); + a.sign = MP_NEG; + if ((e = mp_incr(&a)) != MP_OKAY) { + goto LTM_ERR; + } + if (mp_cmp_d(&a, 0uL) != MP_EQ) { + goto LTM_ERR; + } + + /* Does it increment from -(MP_MASK + 1) to -MP_MASK? */ + mp_set(&a, MP_MASK); + if ((e = mp_add_d(&a, 1uL, &a)) != MP_OKAY) { + goto LTM_ERR; + } + a.sign = MP_NEG; + if ((e = mp_incr(&a)) != MP_OKAY) { + goto LTM_ERR; + } + if (a.sign != MP_NEG) { + goto LTM_ERR; + } + a.sign = MP_ZPOS; + if (mp_cmp_d(&a, MP_MASK) != MP_EQ) { + goto LTM_ERR; + } + + mp_clear_multi(&a, &b, NULL); + return EXIT_SUCCESS; +LTM_ERR: + mp_clear_multi(&a, &b, NULL); + return EXIT_FAILURE; +} + +static int test_mp_decr(void) +{ + mp_int a, b; + mp_err e = MP_OKAY; + + if ((e = mp_init_multi(&a, &b, NULL)) != MP_OKAY) { + goto LTM_ERR; + } + + /* Does it decrement inside the limits of a MP_xBIT limb? */ + mp_set(&a, MP_MASK/2); + if ((e = mp_decr(&a)) != MP_OKAY) { + goto LTM_ERR; + } + if (mp_cmp_d(&a, (MP_MASK/2uL) - 1uL) != MP_EQ) { + goto LTM_ERR; + } + + /* Does it decrement outside of the limits of a MP_xBIT limb? */ + mp_set(&a, MP_MASK); + if ((e = mp_add_d(&a, 1uL, &a)) != MP_OKAY) { + goto LTM_ERR; + } + if ((e = mp_decr(&a)) != MP_OKAY) { + goto LTM_ERR; + } + if (mp_cmp_d(&a, MP_MASK) != MP_EQ) { + goto LTM_ERR; + } + + /* Does it decrement from 0 to -1? */ + mp_zero(&a); + if ((e = mp_decr(&a)) != MP_OKAY) { + goto LTM_ERR; + } + if (a.sign == MP_NEG) { + a.sign = MP_ZPOS; + if (mp_cmp_d(&a, 1uL) != MP_EQ) { + goto LTM_ERR; + } + } else { + goto LTM_ERR; + } + + + /* Does it decrement from -MP_MASK to -(MP_MASK + 1)? */ + mp_set(&a, MP_MASK); + a.sign = MP_NEG; + mp_set(&b, MP_MASK); + b.sign = MP_NEG; + if ((e = mp_sub_d(&b, 1uL, &b)) != MP_OKAY) { + goto LTM_ERR; + } + if ((e = mp_decr(&a)) != MP_OKAY) { + goto LTM_ERR; + } + if (mp_cmp(&a, &b) != MP_EQ) { + goto LTM_ERR; + } + + mp_clear_multi(&a, &b, NULL); + return EXIT_SUCCESS; +LTM_ERR: + mp_clear_multi(&a, &b, NULL); + return EXIT_FAILURE; +} + +/* + Cannot test mp_exp(_d) without mp_root and vice versa. + So one of the two has to be tested from scratch. + + Numbers generated by + for i in {1..10} + do + seed=$(head -c 10000 /dev/urandom | tr -dc '[:digit:]' | head -c 120); + echo $seed; + convertbase $seed 10 64; + done + + (The program "convertbase" uses libtommath's to/from_radix functions) + + Roots were precalculated with Pari/GP + + default(realprecision,1000); + for(n=3,100,r = floor(a^(1/n));printf("\"" r "\", ")) + + All numbers as strings to simplifiy things, especially for the + low-mp branch. +*/ + +static int test_mp_root_u32(void) +{ + mp_int a, c, r; + mp_err e; + int i, j; + + const char *input[] = { + "4n9cbk886QtLQmofprid3l2Q0GD8Yv979Lh8BdZkFE8g2pDUUSMBET/+M/YFyVZ3mBp", + "5NlgzHhmIX05O5YoW5yW5reAlVNtRAlIcN2dfoATnNdc1Cw5lHZUTwNthmK6/ZLKfY6", + "3gweiHDX+ji5utraSe46IJX+uuh7iggs63xIpMP5MriU4Np+LpHI5are8RzS9pKh9xP", + "5QOJUSKMrfe7LkeyJOlupS8h7bjT+TXmZkDzOjZtfj7mdA7cbg0lRX3CuafhjIrpK8S", + "4HtYFldVkyVbrlg/s7kmaA7j45PvLQm+1bbn6ehgP8tVoBmGbv2yDQI1iQQze4AlHyN", + "3bwCUx79NAR7c68OPSp5ZabhZ9aBEr7rWNTO2oMY7zhbbbw7p6shSMxqE9K9nrTNucf", + "4j5RGb78TfuYSzrXn0z6tiAoWiRI81hGY3el9AEa9S+gN4x/AmzotHT2Hvj6lyBpE7q", + "4lwg30SXqZhEHNsl5LIXdyu7UNt0VTWebP3m7+WUL+hsnFW9xJe7UnzYngZsvWh14IE", + "1+tcqFeRuGqjRADRoRUJ8gL4UUSFQVrVVoV6JpwVcKsuBq5G0pABn0dLcQQQMViiVRj", + "hXwxuFySNSFcmbrs/coz4FUAaUYaOEt+l4V5V8vY71KyBvQPxRq/6lsSrG2FHvWDax" + }; + /* roots 3-100 of the above */ + const char *root[10][100] = { + { + "9163694094944489658600517465135586130944", + "936597377180979771960755204040", "948947857956884030956907", + "95727185767390496595", "133844854039712620", "967779611885360", + "20926191452627", "974139547476", "79203891950", "9784027073", + "1667309744", "365848129", "98268452", "31109156", "11275351", + "4574515", "2040800", "986985", "511525", "281431", "163096", + "98914", "62437", "40832", "27556", "19127", "13614", "9913", + "7367", "5577", "4294", "3357", "2662", "2138", "1738", "1428", + "1185", "993", "839", "715", "613", "530", "461", "403", "355", + "314", "279", "249", "224", "202", "182", "166", "151", "138", + "126", "116", "107", "99", "92", "85", "79", "74", "69", "65", "61", + "57", "54", "51", "48", "46", "43", "41", "39", "37", "36", "34", + "32", "31", "30", "28", "27", "26", "25", "24", "23", "23", "22", + "21", "20", "20", "19", "18", "18", "17", "17", "16", "16", "15" + }, { + "9534798256755061606359588498764080011382", + "964902943621813525741417593772", "971822399862464674540423", + "97646291566833512831", "136141536090599560", "982294733581430", + "21204945933335", "985810529393", "80066084985", "9881613813", + "1682654547", "368973625", "99051783", "31341581", "11354620", + "4604882", "2053633", "992879", "514434", "282959", "163942", + "99406", "62736", "41020", "27678", "19208", "13670", "9952", + "7395", "5598", "4310", "3369", "2671", "2145", "1744", "1433", + "1189", "996", "842", "717", "615", "531", "462", "404", "356", + "315", "280", "250", "224", "202", "183", "166", "151", "138", + "127", "116", "107", "99", "92", "85", "80", "74", "70", "65", "61", + "58", "54", "51", "48", "46", "43", "41", "39", "37", "36", "34", + "32", "31", "30", "29", "27", "26", "25", "24", "23", "23", "22", + "21", "20", "20", "19", "18", "18", "17", "17", "16", "16", "15" + }, { + "8398539113202579297642815367509019445624", + "877309458945432597462853440936", "900579899458998599215071", + "91643543761699761637", "128935656335800903", "936647990947203", + "20326748623514", "948988882684", "77342677787", "9573063447", + "1634096832", "359076114", "96569670", "30604705", "11103188", + "4508519", "2012897", "974160", "505193", "278105", "161251", + "97842", "61788", "40423", "27291", "18949", "13492", "9826", + "7305", "5532", "4260", "3332", "2642", "2123", "1726", "1418", + "1177", "986", "834", "710", "610", "527", "458", "401", "353", + "312", "278", "248", "223", "201", "181", "165", "150", "137", + "126", "116", "107", "99", "91", "85", "79", "74", "69", "65", "61", + "57", "54", "51", "48", "46", "43", "41", "39", "37", "35", "34", + "32", "31", "30", "28", "27", "26", "25", "24", "23", "22", "22", + "21", "20", "20", "19", "18", "18", "17", "17", "16", "16", "15" + }, { + "9559098494021810340217797724866627755195", + "966746709063325235560830083787", "973307706084821682248292", + "97770642291138756434", "136290128605981259", "983232784778520", + "21222944848922", "986563584410", "80121684894", "9887903837", + "1683643206", "369174929", "99102220", "31356542", "11359721", + "4606836", "2054458", "993259", "514621", "283057", "163997", + "99437", "62755", "41032", "27686", "19213", "13674", "9955", + "7397", "5599", "4311", "3370", "2672", "2146", "1744", "1433", + "1189", "996", "842", "717", "615", "532", "462", "404", "356", + "315", "280", "250", "224", "202", "183", "166", "151", "138", + "127", "116", "107", "99", "92", "86", "80", "74", "70", "65", "61", + "58", "54", "51", "48", "46", "43", "41", "39", "37", "36", "34", + "32", "31", "30", "29", "27", "26", "25", "24", "23", "23", "22", + "21", "20", "20", "19", "18", "18", "17", "17", "16", "16", "15" + }, { + "8839202025813295923132694443541993309220", + "911611499784863252820288596270", "928640961450376817534853", + "94017030509441723821", "131792686685970629", "954783483196511", + "20676214073400", "963660189823", "78428929840", "9696237956", + "1653495486", "363032624", "97562430", "30899570", "11203842", + "4547110", "2029216", "981661", "508897", "280051", "162331", + "98469", "62168", "40663", "27446", "19053", "13563", "9877", + "7341", "5558", "4280", "3347", "2654", "2132", "1733", "1424", + "1182", "990", "837", "713", "612", "529", "460", "402", "354", + "313", "279", "249", "223", "201", "182", "165", "150", "138", + "126", "116", "107", "99", "92", "85", "79", "74", "69", "65", "61", + "57", "54", "51", "48", "46", "43", "41", "39", "37", "36", "34", + "32", "31", "30", "28", "27", "26", "25", "24", "23", "23", "22", + "21", "20", "20", "19", "18", "18", "17", "17", "16", "16", "15" + }, { + "8338442683973420410660145045849076963795", + "872596990706967613912664152945", "896707843885562730147307", + "91315073695274540969", "128539440806486007", "934129001105825", + "20278149285734", "946946589774", "77191347471", "9555892093", + "1631391010", "358523975", "96431070", "30563524", "11089126", + "4503126", "2010616", "973111", "504675", "277833", "161100", + "97754", "61734", "40390", "27269", "18934", "13482", "9819", + "7300", "5528", "4257", "3330", "2641", "2122", "1725", "1417", + "1177", "986", "833", "710", "609", "527", "458", "401", "353", + "312", "278", "248", "222", "200", "181", "165", "150", "137", + "126", "116", "107", "99", "91", "85", "79", "74", "69", "65", "61", + "57", "54", "51", "48", "46", "43", "41", "39", "37", "35", "34", + "32", "31", "30", "28", "27", "26", "25", "24", "23", "22", "22", + "21", "20", "20", "19", "18", "18", "17", "17", "16", "16", "15" + }, { + "9122818552483814953977703257848970704164", + "933462289569511464780529972314", "946405863353935713909178", + "95513446972056321834", "133588658082928446", + "966158521967027", "20895030642048", "972833934108", + "79107381638", "9773098125", "1665590516", "365497822", + "98180628", "31083090", "11266459", "4571108", "2039360", + "986323", "511198", "281260", "163001", "98858", + "62404", "40811", "27543", "19117", "13608", "9908", + "7363", "5575", "4292", "3356", "2661", "2138", + "1737", "1428", "1185", "993", "839", "714", "613", + "530", "461", "403", "355", "314", "279", "249", + "224", "202", "182", "165", "151", "138", "126", + "116", "107", "99", "92", "85", "79", "74", "69", + "65", "61", "57", "54", "51", "48", "46", "43", + "41", "39", "37", "36", "34", "32", "31", "30", + "28", "27", "26", "25", "24", "23", "23", "22", + "21", "20", "20", "19", "18", "18", "17", "17", + "16", "16", "15" + }, { + "9151329724083804100369546479681933027521", + "935649419557299174433860420387", "948179413831316112751907", + "95662582675170358900", "133767426788182384", + "967289728859610", "20916775466497", "973745045600", + "79174731802", "9780725058", "1666790321", "365742295", + "98241919", "31101281", "11272665", "4573486", "2040365", + "986785", "511426", "281380", "163067", "98897", + "62427", "40826", "27552", "19124", "13612", "9911", + "7366", "5576", "4294", "3357", "2662", "2138", + "1738", "1428", "1185", "993", "839", "715", "613", + "530", "461", "403", "355", "314", "279", "249", + "224", "202", "182", "165", "151", "138", "126", + "116", "107", "99", "92", "85", "79", "74", "69", + "65", "61", "57", "54", "51", "48", "46", "43", + "41", "39", "37", "36", "34", "32", "31", "30", + "28", "27", "26", "25", "24", "23", "23", "22", + "21", "20", "20", "19", "18", "18", "17", "17", + "16", "16", "15" + }, { + "6839396355168045468586008471269923213531", + "752078770083218822016981965090", "796178899357307807726034", + "82700643015444840424", "118072966296549115", + "867224751770392", "18981881485802", "892288574037", + "73130030771", "9093989389", "1558462688", "343617470", + "92683740", "29448679", "10708016", "4356820", "1948676", + "944610", "490587", "270425", "156989", "95362", + "60284", "39477", "26675", "18536", "13208", "9627", + "7161", "5426", "4181", "3272", "2596", "2087", + "1697", "1395", "1159", "971", "821", "700", "601", + "520", "452", "396", "348", "308", "274", "245", + "220", "198", "179", "163", "148", "136", "124", + "114", "106", "98", "91", "84", "78", "73", "68", + "64", "60", "57", "53", "50", "48", "45", "43", + "41", "39", "37", "35", "34", "32", "31", "29", + "28", "27", "26", "25", "24", "23", "22", "22", + "21", "20", "19", "19", "18", "18", "17", "17", + "16", "16", "15" + }, { + "4788090721380022347683138981782307670424", + "575601315594614059890185238256", "642831903229558719812840", + "69196031110028430211", "101340693763170691", + "758683936560287", "16854690815260", "801767985909", + "66353290503", "8318415180", "1435359033", "318340531", + "86304307", "27544217", "10054988", "4105446", "1841996", + "895414", "466223", "257591", "149855", "91205", + "57758", "37886", "25639", "17842", "12730", "9290", + "6918", "5248", "4048", "3170", "2518", "2026", + "1649", "1357", "1128", "946", "800", "682", "586", + "507", "441", "387", "341", "302", "268", "240", + "215", "194", "176", "160", "146", "133", "122", + "112", "104", "96", "89", "83", "77", "72", "67", + "63", "59", "56", "53", "50", "47", "45", "42", + "40", "38", "36", "35", "33", "32", "30", "29", + "28", "27", "26", "25", "24", "23", "22", "21", + "21", "20", "19", "19", "18", "17", "17", "16", + "16", "15", "15" + } + }; + + if ((e = mp_init_multi(&a, &c, &r, NULL)) != MP_OKAY) { + return EXIT_FAILURE; + } +#ifdef MP_8BIT + for (i = 0; i < 1; i++) { +#else + for (i = 0; i < 10; i++) { +#endif + mp_read_radix(&a, input[i], 64); +#ifdef MP_8BIT + for (j = 3; j < 10; j++) { +#else + for (j = 3; j < 100; j++) { +#endif + mp_root_u32(&a, (uint32_t)j, &c); + mp_read_radix(&r, root[i][j-3], 10); + if (mp_cmp(&r, &c) != MP_EQ) { + fprintf(stderr, "mp_root_u32 failed at input #%d, root #%d\n", i, j); + goto LTM_ERR; + } + } + } + mp_clear_multi(&a, &c, &r, NULL); + return EXIT_SUCCESS; +LTM_ERR: + mp_clear_multi(&a, &c, &r, NULL); + return EXIT_FAILURE; +} + +static int test_s_mp_balance_mul(void) +{ + mp_int a, b, c; + mp_err e = MP_OKAY; + + const char *na = + "4b0I5uMTujCysw+1OOuOyH2FX2WymrHUqi8BBDb7XpkV/4i7vXTbEYUy/kdIfCKu5jT5JEqYkdmnn3jAYo8XShPzNLxZx9yoLjxYRyptSuOI2B1DspvbIVYXY12sxPZ4/HCJ4Usm2MU5lO/006KnDMxuxiv1rm6YZJZ0eZU"; + const char *nb = "3x9vs0yVi4hIq7poAeVcggC3WoRt0zRLKO"; + const char *nc = + "HzrSq9WVt1jDTVlwUxSKqxctu2GVD+N8+SVGaPFRqdxyld6IxDBbj27BPJzYUdR96k3sWpkO8XnDBvupGPnehpQe4KlO/KmN1PjFov/UTZYM+LYzkFcBPyV6hkkL8ePC1rlFLAHzgJMBCXVp4mRqtkQrDsZXXlcqlbTFu69wF6zDEysiX2cAtn/kP9ldblJiwYPCD8hG"; + + if ((e = mp_init_multi(&a, &b, &c, NULL)) != MP_OKAY) { + goto LTM_ERR; + } + + if ((e = mp_read_radix(&a, na, 64)) != MP_OKAY) { + goto LTM_ERR; + } + if ((e = mp_read_radix(&b, nb, 64)) != MP_OKAY) { + goto LTM_ERR; + } + + if ((e = s_mp_balance_mul(&a, &b, &c)) != MP_OKAY) { + goto LTM_ERR; + } + + if ((e = mp_read_radix(&b, nc, 64)) != MP_OKAY) { + goto LTM_ERR; + } + + if (mp_cmp(&b, &c) != MP_EQ) { + goto LTM_ERR; + } + + mp_clear_multi(&a, &b, &c, NULL); + return EXIT_SUCCESS; +LTM_ERR: + mp_clear_multi(&a, &b, &c, NULL); + return EXIT_FAILURE; +} + +#define s_mp_mul(a, b, c) s_mp_mul_digs(a, b, c, (a)->used + (b)->used + 1) +static int test_s_mp_karatsuba_mul(void) +{ + mp_int a, b, c, d; + int size, err; + + if ((err = mp_init_multi(&a, &b, &c, &d, NULL)) != MP_OKAY) { + goto LTM_ERR; + } + for (size = MP_KARATSUBA_MUL_CUTOFF; size < MP_KARATSUBA_MUL_CUTOFF + 20; size++) { + if ((err = mp_rand(&a, size)) != MP_OKAY) { + goto LTM_ERR; + } + if ((err = mp_rand(&b, size)) != MP_OKAY) { + goto LTM_ERR; + } + if ((err = s_mp_karatsuba_mul(&a, &b, &c)) != MP_OKAY) { + goto LTM_ERR; + } + if ((err = s_mp_mul(&a,&b,&d)) != MP_OKAY) { + goto LTM_ERR; + } + if (mp_cmp(&c, &d) != MP_EQ) { + fprintf(stderr, "Karatsuba multiplication failed at size %d\n", size); + goto LTM_ERR; + } + } + + mp_clear_multi(&a, &b, &c, &d, NULL); + return EXIT_SUCCESS; +LTM_ERR: + mp_clear_multi(&a, &b, &c, &d, NULL); + return EXIT_FAILURE; +} + +static int test_s_mp_karatsuba_sqr(void) +{ + mp_int a, b, c; + int size, err; + + if ((err = mp_init_multi(&a, &b, &c, NULL)) != MP_OKAY) { + goto LTM_ERR; + } + for (size = MP_KARATSUBA_SQR_CUTOFF; size < MP_KARATSUBA_SQR_CUTOFF + 20; size++) { + if ((err = mp_rand(&a, size)) != MP_OKAY) { + goto LTM_ERR; + } + if ((err = s_mp_karatsuba_sqr(&a, &b)) != MP_OKAY) { + goto LTM_ERR; + } + if ((err = s_mp_sqr(&a, &c)) != MP_OKAY) { + goto LTM_ERR; + } + if (mp_cmp(&b, &c) != MP_EQ) { + fprintf(stderr, "Karatsuba squaring failed at size %d\n", size); + goto LTM_ERR; + } + } + + mp_clear_multi(&a, &b, &c, NULL); + return EXIT_SUCCESS; +LTM_ERR: + mp_clear_multi(&a, &b, &c, NULL); + return EXIT_FAILURE; +} + +static int test_s_mp_toom_mul(void) +{ + mp_int a, b, c, d; + int size, err; + +#if (MP_DIGIT_BIT == 60) + int tc_cutoff; +#endif + + if ((err = mp_init_multi(&a, &b, &c, &d, NULL)) != MP_OKAY) { + goto LTM_ERR; + } + /* This number construction is limb-size specific */ +#if (MP_DIGIT_BIT == 60) + if ((err = mp_rand(&a, 1196)) != MP_OKAY) { + goto LTM_ERR; + } + if ((err = mp_mul_2d(&a,71787 - mp_count_bits(&a), &a)) != MP_OKAY) { + goto LTM_ERR; + } + + if ((err = mp_rand(&b, 1338)) != MP_OKAY) { + goto LTM_ERR; + } + if ((err = mp_mul_2d(&b, 80318 - mp_count_bits(&b), &b)) != MP_OKAY) { + goto LTM_ERR; + } + if ((err = mp_mul_2d(&b, 6310, &b)) != MP_OKAY) { + goto LTM_ERR; + } + if ((err = mp_2expt(&c, 99000 - 1000)) != MP_OKAY) { + goto LTM_ERR; + } + if ((err = mp_add(&b, &c, &b)) != MP_OKAY) { + goto LTM_ERR; + } + + tc_cutoff = TOOM_MUL_CUTOFF; + TOOM_MUL_CUTOFF = INT_MAX; + if ((err = mp_mul(&a, &b, &c)) != MP_OKAY) { + goto LTM_ERR; + } + TOOM_MUL_CUTOFF = tc_cutoff; + if ((err = mp_mul(&a, &b, &d)) != MP_OKAY) { + goto LTM_ERR; + } + if (mp_cmp(&c, &d) != MP_EQ) { + fprintf(stderr, "Toom-Cook 3-way multiplication failed for edgecase f1 * f2\n"); + goto LTM_ERR; + } +#endif + + for (size = MP_TOOM_MUL_CUTOFF; size < MP_TOOM_MUL_CUTOFF + 20; size++) { + if ((err = mp_rand(&a, size)) != MP_OKAY) { + goto LTM_ERR; + } + if ((err = mp_rand(&b, size)) != MP_OKAY) { + goto LTM_ERR; + } + if ((err = s_mp_toom_mul(&a, &b, &c)) != MP_OKAY) { + goto LTM_ERR; + } + if ((err = s_mp_mul(&a,&b,&d)) != MP_OKAY) { + goto LTM_ERR; + } + if (mp_cmp(&c, &d) != MP_EQ) { + fprintf(stderr, "Toom-Cook 3-way multiplication failed at size %d\n", size); + goto LTM_ERR; + } + } + + mp_clear_multi(&a, &b, &c, &d, NULL); + return EXIT_SUCCESS; +LTM_ERR: + mp_clear_multi(&a, &b, &c, &d, NULL); + return EXIT_FAILURE; +} + +static int test_s_mp_toom_sqr(void) +{ + mp_int a, b, c; + int size, err; + + if ((err = mp_init_multi(&a, &b, &c, NULL)) != MP_OKAY) { + goto LTM_ERR; + } + for (size = MP_TOOM_SQR_CUTOFF; size < MP_TOOM_SQR_CUTOFF + 20; size++) { + if ((err = mp_rand(&a, size)) != MP_OKAY) { + goto LTM_ERR; + } + if ((err = s_mp_toom_sqr(&a, &b)) != MP_OKAY) { + goto LTM_ERR; + } + if ((err = s_mp_sqr(&a, &c)) != MP_OKAY) { + goto LTM_ERR; + } + if (mp_cmp(&b, &c) != MP_EQ) { + fprintf(stderr, "Toom-Cook 3-way squaring failed at size %d\n", size); + goto LTM_ERR; + } + } + + mp_clear_multi(&a, &b, &c, NULL); + return EXIT_SUCCESS; +LTM_ERR: + mp_clear_multi(&a, &b, &c, NULL); + return EXIT_FAILURE; +} + +static int test_mp_read_write_ubin(void) +{ + mp_int a, b, c; + int err; + size_t size, len; + unsigned char *buf = NULL; + + if ((err = mp_init_multi(&a, &b, &c, NULL)) != MP_OKAY) { + goto LTM_ERR; + } + + if ((err = mp_rand(&a, 15)) != MP_OKAY) goto LTM_ERR; + if ((err = mp_neg(&a, &b)) != MP_OKAY) goto LTM_ERR; + + size = mp_ubin_size(&a); + printf("mp_to_ubin_size %zu\n", size); + buf = malloc(sizeof(*buf) * size); + if (buf == NULL) { + fprintf(stderr, "test_read_write_binaries (u) failed to allocate %zu bytes\n", + sizeof(*buf) * size); + goto LTM_ERR; + } + + if ((err = mp_to_ubin(&a, buf, size, &len)) != MP_OKAY) goto LTM_ERR; + printf("mp_to_ubin len = %zu\n", len); + + if ((err = mp_from_ubin(&c, buf, len)) != MP_OKAY) goto LTM_ERR; + + if (mp_cmp(&a, &c) != MP_EQ) { + fprintf(stderr, "to/from ubin cycle failed\n"); + goto LTM_ERR; + } + free(buf); + mp_clear_multi(&a, &b, &c, NULL); + return EXIT_SUCCESS; +LTM_ERR: + free(buf); + mp_clear_multi(&a, &b, &c, NULL); + return EXIT_FAILURE; +} + +static int test_mp_read_write_sbin(void) +{ + mp_int a, b, c; + int err; + size_t size, len; + unsigned char *buf = NULL; + + if ((err = mp_init_multi(&a, &b, &c, NULL)) != MP_OKAY) { + goto LTM_ERR; + } + + if ((err = mp_rand(&a, 15)) != MP_OKAY) goto LTM_ERR; + if ((err = mp_neg(&a, &b)) != MP_OKAY) goto LTM_ERR; + + size = mp_sbin_size(&a); + printf("mp_to_sbin_size %zu\n", size); + buf = malloc(sizeof(*buf) * size); + if (buf == NULL) { + fprintf(stderr, "test_read_write_binaries (s) failed to allocate %zu bytes\n", + sizeof(*buf) * size); + goto LTM_ERR; + } + + if ((err = mp_to_sbin(&b, buf, size, &len)) != MP_OKAY) goto LTM_ERR; + printf("mp_to_sbin len = %zu\n", len); + + if ((err = mp_from_sbin(&c, buf, len)) != MP_OKAY) goto LTM_ERR; + + if (mp_cmp(&b, &c) != MP_EQ) { + fprintf(stderr, "to/from ubin cycle failed\n"); + goto LTM_ERR; + } + + free(buf); + mp_clear_multi(&a, &b, &c, NULL); + return EXIT_SUCCESS; +LTM_ERR: + free(buf); + mp_clear_multi(&a, &b, &c, NULL); + return EXIT_FAILURE; +} + +static int test_mp_pack_unpack(void) +{ + mp_int a, b; + int err; + size_t written, count; + unsigned char *buf = NULL; + + mp_order order = MP_LSB_FIRST; + mp_endian endianess = MP_NATIVE_ENDIAN; + + if ((err = mp_init_multi(&a, &b, NULL)) != MP_OKAY) goto LTM_ERR; + if ((err = mp_rand(&a, 15)) != MP_OKAY) goto LTM_ERR; + + count = mp_pack_count(&a, 0, 1); + + buf = malloc(count); + if (buf == NULL) { + fprintf(stderr, "test_pack_unpack failed to allocate\n"); + goto LTM_ERR; + } + + if ((err = mp_pack((void *)buf, count, &written, order, 1, + endianess, 0, &a)) != MP_OKAY) goto LTM_ERR; + if ((err = mp_unpack(&b, count, order, 1, + endianess, 0, (const void *)buf)) != MP_OKAY) goto LTM_ERR; + + if (mp_cmp(&a, &b) != MP_EQ) { + fprintf(stderr, "pack/unpack cycle failed\n"); + goto LTM_ERR; + } + + free(buf); + mp_clear_multi(&a, &b, NULL); + return EXIT_SUCCESS; +LTM_ERR: + free(buf); + mp_clear_multi(&a, &b, NULL); + return EXIT_FAILURE; +} + +static int unit_tests(int argc, char **argv) +{ + static const struct { + const char *name; + int (*fn)(void); + } test[] = { +#define T0(n) { #n, test_##n } +#define T1(n, o) { #n, MP_HAS(o) ? test_##n : NULL } +#define T2(n, o1, o2) { #n, MP_HAS(o1) && MP_HAS(o2) ? test_##n : NULL } + T0(feature_detection), + T0(trivial_stuff), + T2(mp_get_set_i32, MP_GET_I32, MP_GET_MAG_U32), + T2(mp_get_set_i64, MP_GET_I64, MP_GET_MAG_U64), + T1(mp_and, MP_AND), + T1(mp_cnt_lsb, MP_CNT_LSB), + T1(mp_complement, MP_COMPLEMENT), + T1(mp_decr, MP_DECR), + T1(mp_div_3, MP_DIV_3), + T1(mp_dr_reduce, MP_DR_REDUCE), + T2(mp_pack_unpack,MP_PACK, MP_UNPACK), + T2(mp_fread_fwrite, MP_FREAD, MP_FWRITE), + T1(mp_get_u32, MP_GET_I32), + T1(mp_get_u64, MP_GET_I64), + T1(mp_get_ul, MP_GET_L), + T1(mp_log_u32, MP_LOG_U32), + T1(mp_incr, MP_INCR), + T1(mp_invmod, MP_INVMOD), + T1(mp_is_square, MP_IS_SQUARE), + T1(mp_kronecker, MP_KRONECKER), + T1(mp_montgomery_reduce, MP_MONTGOMERY_REDUCE), + T1(mp_root_u32, MP_ROOT_U32), + T1(mp_or, MP_OR), + T1(mp_prime_is_prime, MP_PRIME_IS_PRIME), + T1(mp_prime_next_prime, MP_PRIME_NEXT_PRIME), + T1(mp_prime_rand, MP_PRIME_RAND), + T1(mp_rand, MP_RAND), + T1(mp_read_radix, MP_READ_RADIX), + T1(mp_read_write_ubin, MP_TO_UBIN), + T1(mp_read_write_sbin, MP_TO_SBIN), + T1(mp_reduce_2k, MP_REDUCE_2K), + T1(mp_reduce_2k_l, MP_REDUCE_2K_L), +#if defined(__STDC_IEC_559__) || defined(__GCC_IEC_559) + T1(mp_set_double, MP_SET_DOUBLE), +#endif + T1(mp_signed_rsh, MP_SIGNED_RSH), + T1(mp_sqrt, MP_SQRT), + T1(mp_sqrtmod_prime, MP_SQRTMOD_PRIME), + T1(mp_xor, MP_XOR), + T1(s_mp_balance_mul, S_MP_BALANCE_MUL), + T1(s_mp_karatsuba_mul, S_MP_KARATSUBA_MUL), + T1(s_mp_karatsuba_sqr, S_MP_KARATSUBA_SQR), + T1(s_mp_toom_mul, S_MP_TOOM_MUL), + T1(s_mp_toom_sqr, S_MP_TOOM_SQR) +#undef T2 +#undef T1 + }; + unsigned long i, ok, fail, nop; + uint64_t t; + int j; + + ok = fail = nop = 0; + + t = (uint64_t)time(NULL); + printf("SEED: 0x%"PRIx64"\n\n", t); + s_mp_rand_jenkins_init(t); + mp_rand_source(s_mp_rand_jenkins); + + for (i = 0; i < sizeof(test) / sizeof(test[0]); ++i) { + if (argc > 1) { + for (j = 1; j < argc; ++j) { + if (strstr(test[i].name, argv[j]) != NULL) { + break; + } + } + if (j == argc) continue; + } + printf("TEST %s\n\n", test[i].name); + if (test[i].fn == NULL) { + nop++; + printf("NOP %s\n\n", test[i].name); + } else if (test[i].fn() == EXIT_SUCCESS) { + ok++; + printf("\n\n"); + } else { + fail++; + printf("\n\nFAIL %s\n\n", test[i].name); + } + } + printf("Tests OK/NOP/FAIL: %lu/%lu/%lu\n", ok, nop, fail); + + if (fail != 0) return EXIT_FAILURE; + else return EXIT_SUCCESS; +} + +int main(int argc, char **argv) +{ + print_header(); + + return unit_tests(argc, argv); +} diff --git a/libtommath/helper.pl b/libtommath/helper.pl index e60c1a7..c624b7c 100755 --- a/libtommath/helper.pl +++ b/libtommath/helper.pl @@ -51,7 +51,7 @@ sub check_source { push @{$troubles->{tab}}, $lineno if $l =~ /\t/ && basename($file) !~ /^makefile/i; push @{$troubles->{non_ascii_char}}, $lineno if $l =~ /[^[:ascii:]]/; push @{$troubles->{cpp_comment}}, $lineno if $file =~ /\.(c|h)$/ && ($l =~ /\s\/\// || $l =~ /\/\/\s/); - # we prefer using XMALLOC, XFREE, XREALLOC, XCALLOC ... + # we prefer using MP_MALLOC, MP_FREE, MP_REALLOC, MP_CALLOC ... push @{$troubles->{unwanted_malloc}}, $lineno if $file =~ /^[^\/]+\.c$/ && $l =~ /\bmalloc\s*\(/; push @{$troubles->{unwanted_realloc}}, $lineno if $file =~ /^[^\/]+\.c$/ && $l =~ /\brealloc\s*\(/; push @{$troubles->{unwanted_calloc}}, $lineno if $file =~ /^[^\/]+\.c$/ && $l =~ /\bcalloc\s*\(/; diff --git a/libtommath/makefile_include.mk b/libtommath/makefile_include.mk index 7b025e8..452d37d 100644 --- a/libtommath/makefile_include.mk +++ b/libtommath/makefile_include.mk @@ -116,10 +116,10 @@ endif # adjust coverage set ifneq ($(filter $(_ARCH), i386 i686 x86_64 amd64 ia64),) - COVERAGE = test_standalone timing + COVERAGE = test timing COVERAGE_APP = ./test && ./timing else - COVERAGE = test_standalone + COVERAGE = test COVERAGE_APP = ./test endif @@ -135,6 +135,10 @@ LIBPATH ?= $(PREFIX)/lib INCPATH ?= $(PREFIX)/include DATAPATH ?= $(PREFIX)/share/doc/libtommath/pdf +# build & run test-suite +check: test + ./test + #make the code coverage of the library # coverage: LTM_CFLAGS += -fprofile-arcs -ftest-coverage -DTIMING_NO_LOGS diff --git a/libtommath/testme.sh b/libtommath/testme.sh new file mode 100755 index 0000000..40fa32d --- /dev/null +++ b/libtommath/testme.sh @@ -0,0 +1,394 @@ +#!/bin/bash +# +# return values of this script are: +# 0 success +# 128 a test failed +# >0 the number of timed-out tests +# 255 parsing of parameters failed + +set -e + +if [ -f /proc/cpuinfo ] +then + MAKE_JOBS=$(( ($(cat /proc/cpuinfo | grep -E '^processor[[:space:]]*:' | tail -n -1 | cut -d':' -f2) + 1) * 2 + 1 )) +else + MAKE_JOBS=8 +fi + +ret=0 +TEST_CFLAGS="" + +_help() +{ + echo "Usage options for $(basename $0) [--with-cc=arg [other options]]" + echo + echo "Executing this script without any parameter will only run the default" + echo "configuration that has automatically been determined for the" + echo "architecture you're running." + echo + echo " --with-cc=* The compiler(s) to use for the tests" + echo " This is an option that will be iterated." + echo + echo " --test-vs-mtest=* Run test vs. mtest for '*' operations." + echo " Only the first of each options will be" + echo " taken into account." + echo + echo "To be able to specify options a compiler has to be given with" + echo "the option --with-cc=compilername" + echo "All other options will be tested with all MP_xBIT configurations." + echo + echo " --with-{m64,m32,mx32} The architecture(s) to build and test" + echo " for, e.g. --with-mx32." + echo " This is an option that will be iterated," + echo " multiple selections are possible." + echo " The mx32 architecture is not supported" + echo " by clang and will not be executed." + echo + echo " --cflags=* Give an option to the compiler," + echo " e.g. --cflags=-g" + echo " This is an option that will always be" + echo " passed as parameter to CC." + echo + echo " --make-option=* Give an option to make," + echo " e.g. --make-option=\"-f makefile.shared\"" + echo " This is an option that will always be" + echo " passed as parameter to make." + echo + echo " --with-low-mp Also build&run tests with -DMP_{8,16,32}BIT." + echo + echo " --mtest-real-rand Use real random data when running mtest." + echo + echo " --with-valgrind" + echo " --with-valgrind=* Run in valgrind (slow!)." + echo + echo " --with-travis-valgrind Run with valgrind on Travis on specific branches." + echo + echo " --valgrind-options Additional Valgrind options" + echo " Some of the options like e.g.:" + echo " --track-origins=yes add a lot of extra" + echo " runtime and may trigger the 30 minutes" + echo " timeout." + echo + echo "Godmode:" + echo + echo " --all Choose all architectures and gcc and clang" + echo " as compilers but does not run valgrind." + echo + echo " --format Runs the various source-code formatters" + echo " and generators and checks if the sources" + echo " are clean." + echo + echo " -h" + echo " --help This message" + echo + echo " -v" + echo " --version Prints the version. It is just the number" + echo " of git commits to this file, no deeper" + echo " meaning attached" + exit 0 +} + +_die() +{ + echo "error $2 while $1" + if [ "$2" != "124" ] + then + exit 128 + else + echo "assuming timeout while running test - continue" + local _tail="" + which tail >/dev/null && _tail="tail -n 1 test_${suffix}.log" && \ + echo "last line of test_"${suffix}".log was:" && $_tail && echo "" + ret=$(( $ret + 1 )) + fi +} + +_make() +{ + echo -ne " Compile $1 $2" + suffix=$(echo ${1}${2} | tr ' ' '_') + CC="$1" CFLAGS="$2 $TEST_CFLAGS" make -j$MAKE_JOBS $3 $MAKE_OPTIONS > /dev/null 2>gcc_errors_${suffix}.log + errcnt=$(wc -l < gcc_errors_${suffix}.log) + if [[ ${errcnt} -gt 1 ]]; then + echo " failed" + cat gcc_errors_${suffix}.log + exit 128 + fi +} + + +_runtest() +{ + make clean > /dev/null + local _timeout="" + which timeout >/dev/null && _timeout="timeout --foreground 90" + if [[ "$MAKE_OPTIONS" =~ "tune" ]] + then + # "make tune" will run "tune_it.sh" automatically, hence "autotune", but it cannot + # get switched off without some effort, so we just let it run twice for testing purposes + echo -e "\rRun autotune $1 $2" + _make "$1" "$2" "" + $_timeout $TUNE_CMD > test_${suffix}.log || _die "running autotune" $? + else + _make "$1" "$2" "test" + echo -e "\rRun test $1 $2" + $_timeout ./test > test_${suffix}.log || _die "running tests" $? + fi +} + +# This is not much more of a C&P of _runtest with a different timeout +# and the additional valgrind call. +# TODO: merge +_runvalgrind() +{ + make clean > /dev/null + local _timeout="" + # 30 minutes? Yes. Had it at 20 minutes and the Valgrind run needed over 25 minutes. + # A bit too close for comfort. + which timeout >/dev/null && _timeout="timeout --foreground 1800" +echo "MAKE_OPTIONS = \"$MAKE_OPTIONS\"" + if [[ "$MAKE_OPTIONS" =~ "tune" ]] + then +echo "autotune branch" + _make "$1" "$2" "" + # The shell used for /bin/sh is DASH 0.5.7-4ubuntu1 on the author's machine which fails valgrind, so + # we just run on instance of etc/tune with the same options as in etc/tune_it.sh + echo -e "\rRun etc/tune $1 $2 once inside valgrind" + $_timeout $VALGRIND_BIN $VALGRIND_OPTS $TUNE_CMD > test_${suffix}.log || _die "running etc/tune" $? + else + _make "$1" "$2" "test" + echo -e "\rRun test $1 $2 inside valgrind" + $_timeout $VALGRIND_BIN $VALGRIND_OPTS ./test > test_${suffix}.log || _die "running tests" $? + fi +} + + +_banner() +{ + echo "uname="$(uname -a) + [[ "$#" != "0" ]] && (echo $1=$($1 -dumpversion)) || true +} + +_exit() +{ + if [ "$ret" == "0" ] + then + echo "Tests successful" + else + echo "$ret tests timed out" + fi + + exit $ret +} + +ARCHFLAGS="" +COMPILERS="" +CFLAGS="" +WITH_LOW_MP="" +TEST_VS_MTEST="" +MTEST_RAND="" +# timed with an AMD A8-6600K +# 25 minutes +#VALGRIND_OPTS=" --track-origins=yes --leak-check=full --show-leak-kinds=all --error-exitcode=1 " +# 9 minutes (14 minutes with --test-vs-mtest=333333 --mtest-real-rand) +VALGRIND_OPTS=" --leak-check=full --show-leak-kinds=all --error-exitcode=1 " +#VALGRIND_OPTS="" +VALGRIND_BIN="" +CHECK_FORMAT="" +TUNE_CMD="./etc/tune -t -r 10 -L 3" + +alive_pid=0 + +function kill_alive() { + disown $alive_pid || true + kill $alive_pid 2>/dev/null +} + +function start_alive_printing() { + [ "$alive_pid" == "0" ] || return 0; + for i in `seq 1 10` ; do sleep 300 && echo "Tests still in Progress..."; done & + alive_pid=$! + trap kill_alive EXIT +} + +while [ $# -gt 0 ]; +do + case $1 in + "--with-m64" | "--with-m32" | "--with-mx32") + ARCHFLAGS="$ARCHFLAGS ${1:6}" + ;; + --with-cc=*) + COMPILERS="$COMPILERS ${1#*=}" + ;; + --cflags=*) + CFLAGS="$CFLAGS ${1#*=}" + ;; + --valgrind-options=*) + VALGRIND_OPTS="$VALGRIND_OPTS ${1#*=}" + ;; + --with-valgrind*) + if [[ ${1#*d} != "" ]] + then + VALGRIND_BIN="${1#*=}" + else + VALGRIND_BIN="valgrind" + fi + start_alive_printing + ;; + --with-travis-valgrind*) + if [[ ("$TRAVIS_BRANCH" == "develop" && "$TRAVIS_PULL_REQUEST" == "false") || "$TRAVIS_BRANCH" == *"valgrind"* || "$TRAVIS_COMMIT_MESSAGE" == *"valgrind"* ]] + then + if [[ ${1#*d} != "" ]] + then + VALGRIND_BIN="${1#*=}" + else + VALGRIND_BIN="valgrind" + fi + start_alive_printing + fi + ;; + --make-option=*) + MAKE_OPTIONS="$MAKE_OPTIONS ${1#*=}" + ;; + --with-low-mp) + WITH_LOW_MP="1" + ;; + --test-vs-mtest=*) + TEST_VS_MTEST="${1#*=}" + if ! [ "$TEST_VS_MTEST" -eq "$TEST_VS_MTEST" ] 2> /dev/null + then + echo "--test-vs-mtest Parameter has to be int" + exit 255 + fi + start_alive_printing + ;; + --mtest-real-rand) + MTEST_RAND="-DLTM_MTEST_REAL_RAND" + ;; + --format) + CHECK_FORMAT="1" + ;; + --all) + COMPILERS="gcc clang" + ARCHFLAGS="-m64 -m32 -mx32" + ;; + --help | -h) + _help + ;; + --version | -v) + echo $(git rev-list HEAD --count -- testme.sh) || echo "Unknown. Please run in original libtommath git repository." + exit 0 + ;; + *) + echo "Ignoring option ${1}" + ;; + esac + shift +done + +function _check_git() { + git update-index --refresh >/dev/null || true + git diff-index --quiet HEAD -- . || ( echo "FAILURE: $*" && exit 1 ) +} + +if [[ "$CHECK_FORMAT" == "1" ]] +then + make astyle + _check_git "make astyle" + perl helper.pl --update-files + _check_git "helper.pl --update-files" + perl helper.pl --check-all + _check_git "helper.pl --check-all" + exit $? +fi + +[[ "$VALGRIND_BIN" == "" ]] && VALGRIND_OPTS="" + +# default to CC environment variable if no compiler is defined but some other options +if [[ "$COMPILERS" == "" ]] && [[ "$ARCHFLAGS$MAKE_OPTIONS$CFLAGS" != "" ]] +then + COMPILERS="$CC" +# default to CC environment variable and run only default config if no option is given +elif [[ "$COMPILERS" == "" ]] +then + _banner "$CC" + if [[ "$VALGRIND_BIN" != "" ]] + then + _runvalgrind "$CC" "" + else + _runtest "$CC" "" + fi + _exit +fi + + +archflags=( $ARCHFLAGS ) +compilers=( $COMPILERS ) + +# choosing a compiler without specifying an architecture will use the default architecture +if [ "${#archflags[@]}" == "0" ] +then + archflags[0]=" " +fi + +_banner + +if [[ "$TEST_VS_MTEST" != "" ]] +then + make clean > /dev/null + _make "${compilers[0]} ${archflags[0]}" "$CFLAGS" "mtest_opponent" + echo + _make "gcc" "$MTEST_RAND" "mtest" + echo + echo "Run test vs. mtest for $TEST_VS_MTEST iterations" + _timeout="" + which timeout >/dev/null && _timeout="timeout --foreground 1800" + $_timeout ./mtest/mtest $TEST_VS_MTEST | $VALGRIND_BIN $VALGRIND_OPTS ./mtest_opponent > valgrind_test.log 2> test_vs_mtest_err.log + retval=$? + head -n 5 valgrind_test.log + tail -n 2 valgrind_test.log + exit $retval +fi + +for i in "${compilers[@]}" +do + if [ -z "$(which $i)" ] + then + echo "Skipped compiler $i, file not found" + continue + fi + compiler_version=$(echo "$i="$($i -dumpversion)) + if [ "$compiler_version" == "clang=4.2.1" ] + then + # one of my versions of clang complains about some stuff in stdio.h and stdarg.h ... + TEST_CFLAGS="-Wno-typedef-redefinition" + else + TEST_CFLAGS="" + fi + echo $compiler_version + + for a in "${archflags[@]}" + do + if [[ $(expr "$i" : "clang") -ne 0 && "$a" == "-mx32" ]] + then + echo "clang -mx32 tests skipped" + continue + fi + if [[ "$VALGRIND_BIN" != "" ]] + then + _runvalgrind "$i $a" "$CFLAGS" + [ "$WITH_LOW_MP" != "1" ] && continue + _runvalgrind "$i $a" "-DMP_8BIT $CFLAGS" + _runvalgrind "$i $a" "-DMP_16BIT $CFLAGS" + _runvalgrind "$i $a" "-DMP_32BIT $CFLAGS" + else + _runtest "$i $a" "$CFLAGS" + [ "$WITH_LOW_MP" != "1" ] && continue + _runtest "$i $a" "-DMP_8BIT $CFLAGS" + _runtest "$i $a" "-DMP_16BIT $CFLAGS" + _runtest "$i $a" "-DMP_32BIT $CFLAGS" + fi + done +done + +_exit diff --git a/libtommath/tommath.h b/libtommath/tommath.h index e87bb08..2c4023c 100644 --- a/libtommath/tommath.h +++ b/libtommath/tommath.h @@ -234,13 +234,22 @@ TOOM_SQR_CUTOFF; #if defined(__GNUC__) && (__GNUC__ * 100 + __GNUC_MINOR__ >= 405) # define MP_DEPRECATED(x) __attribute__((deprecated("replaced by " #x))) +#elif defined(_MSC_VER) && _MSC_VER >= 1500 +# define MP_DEPRECATED(x) __declspec(deprecated("replaced by " #x)) +#else +# define MP_DEPRECATED(x) +#endif + +#ifndef MP_NO_DEPRECATED_PRAGMA +#if defined(__GNUC__) && (__GNUC__ * 100 + __GNUC_MINOR__ >= 301) # define PRIVATE_MP_DEPRECATED_PRAGMA(s) _Pragma(#s) # define MP_DEPRECATED_PRAGMA(s) PRIVATE_MP_DEPRECATED_PRAGMA(GCC warning s) #elif defined(_MSC_VER) && _MSC_VER >= 1500 -# define MP_DEPRECATED(x) __declspec(deprecated("replaced by " #x)) # define MP_DEPRECATED_PRAGMA(s) __pragma(message(s)) -#else -# define MP_DEPRECATED(s) +#endif +#endif + +#ifndef MP_DEPRECATED_PRAGMA # define MP_DEPRECATED_PRAGMA(s) #endif -- cgit v0.12 From 0ff0a94010dcb27842e2f78515d4cfd9ae70ed26 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 22 Nov 2019 12:38:13 +0000 Subject: Take over recent commmits on the support/1.x branch --- libtommath/bn_mp_log_u32.c | 8 ++++---- libtommath/bn_mp_set_double.c | 4 ++-- libtommath/bn_s_mp_rand_jenkins.c | 4 ++-- libtommath/demo/test.c | 22 +++++++++++----------- libtommath/tommath.h | 2 +- 5 files changed, 20 insertions(+), 20 deletions(-) diff --git a/libtommath/bn_mp_log_u32.c b/libtommath/bn_mp_log_u32.c index f7bca01..b86d789 100644 --- a/libtommath/bn_mp_log_u32.c +++ b/libtommath/bn_mp_log_u32.c @@ -6,7 +6,7 @@ /* Compute log_{base}(a) */ static mp_word s_pow(mp_word base, mp_word exponent) { - mp_word result = 1uLL; + mp_word result = 1u; while (exponent != 0u) { if ((exponent & 1u) == 1u) { result *= base; @@ -20,8 +20,8 @@ static mp_word s_pow(mp_word base, mp_word exponent) static mp_digit s_digit_ilogb(mp_digit base, mp_digit n) { - mp_word bracket_low = 1uLL, bracket_mid, bracket_high, N; - mp_digit ret, high = 1uL, low = 0uL, mid; + mp_word bracket_low = 1u, bracket_mid, bracket_high, N; + mp_digit ret, high = 1u, low = 0uL, mid; if (n < base) { return 0uL; @@ -40,7 +40,7 @@ static mp_digit s_digit_ilogb(mp_digit base, mp_digit n) bracket_high *= bracket_high; } - while (((mp_digit)(high - low)) > 1uL) { + while (((mp_digit)(high - low)) > 1u) { mid = (low + high) >> 1; bracket_mid = bracket_low * s_pow(base, (mp_word)(mid - low)); diff --git a/libtommath/bn_mp_set_double.c b/libtommath/bn_mp_set_double.c index a42fc70..7f1ab75 100644 --- a/libtommath/bn_mp_set_double.c +++ b/libtommath/bn_mp_set_double.c @@ -16,7 +16,7 @@ mp_err mp_set_double(mp_int *a, double b) cast.dbl = b; exp = (int)((unsigned)(cast.bits >> 52) & 0x7FFu); - frac = (cast.bits & ((1uLL << 52) - 1uLL)) | (1uLL << 52); + frac = (cast.bits & (((uint64_t)1 << 52) - (uint64_t)1)) | ((uint64_t)1 << 52); if (exp == 0x7FF) { /* +-inf, NaN */ return MP_VAL; @@ -30,7 +30,7 @@ mp_err mp_set_double(mp_int *a, double b) return err; } - if (((cast.bits >> 63) != 0uLL) && !MP_IS_ZERO(a)) { + if (((cast.bits >> 63) != 0u) && !MP_IS_ZERO(a)) { a->sign = MP_NEG; } diff --git a/libtommath/bn_s_mp_rand_jenkins.c b/libtommath/bn_s_mp_rand_jenkins.c index da0771c..c64afac 100644 --- a/libtommath/bn_s_mp_rand_jenkins.c +++ b/libtommath/bn_s_mp_rand_jenkins.c @@ -27,10 +27,10 @@ static uint64_t s_rand_jenkins_val(void) void s_mp_rand_jenkins_init(uint64_t seed) { - uint64_t i; + int i; jenkins_x.a = 0xf1ea5eedULL; jenkins_x.b = jenkins_x.c = jenkins_x.d = seed; - for (i = 0uLL; i < 20uLL; ++i) { + for (i = 0; i < 20; ++i) { (void)s_rand_jenkins_val(); } } diff --git a/libtommath/demo/test.c b/libtommath/demo/test.c index 7b29a4c..14b0c58 100644 --- a/libtommath/demo/test.c +++ b/libtommath/demo/test.c @@ -754,7 +754,7 @@ LBL_ERR: static int test_mp_get_u64(void) { - unsigned long long q, r; + uint64_t q, r; int i; mp_int a, b; @@ -762,20 +762,20 @@ static int test_mp_get_u64(void) return EXIT_FAILURE; } - for (i = 0; i < (int)(MP_SIZEOF_BITS(unsigned long long) - 1); ++i) { - r = (1ULL << (i+1)) - 1; + for (i = 0; i < (int)(MP_SIZEOF_BITS(uint64_t) - 1); ++i) { + r = ((uint64_t)1 << (i+1)) - 1; if (!r) - r = ~0ULL; - printf(" r = 0x%llx i = %d\r", r, i); + r = UINT64_MAX; + printf(" r = 0x%" PRIx64 " i = %d\r", r, i); do { mp_set_u64(&a, r); q = mp_get_u64(&a); if (q != r) { - printf("\nmp_get_u64() bad result! 0x%llx != 0x%llx", q, r); + printf("\nmp_get_u64() bad result! 0x%" PRIx64 " != 0x%" PRIx64, q, r); goto LBL_ERR; } r <<= 1; - } while (r != 0uLL); + } while (r != 0u); } mp_clear_multi(&a, &b, NULL); @@ -2313,7 +2313,7 @@ static int test_mp_read_write_ubin(void) size = mp_ubin_size(&a); printf("mp_to_ubin_size %zu\n", size); - buf = malloc(sizeof(*buf) * size); + buf = (unsigned char *)malloc(sizeof(*buf) * size); if (buf == NULL) { fprintf(stderr, "test_read_write_binaries (u) failed to allocate %zu bytes\n", sizeof(*buf) * size); @@ -2354,7 +2354,7 @@ static int test_mp_read_write_sbin(void) size = mp_sbin_size(&a); printf("mp_to_sbin_size %zu\n", size); - buf = malloc(sizeof(*buf) * size); + buf = (unsigned char *)malloc(sizeof(*buf) * size); if (buf == NULL) { fprintf(stderr, "test_read_write_binaries (s) failed to allocate %zu bytes\n", sizeof(*buf) * size); @@ -2395,7 +2395,7 @@ static int test_mp_pack_unpack(void) count = mp_pack_count(&a, 0, 1); - buf = malloc(count); + buf = (unsigned char *)malloc(count); if (buf == NULL) { fprintf(stderr, "test_pack_unpack failed to allocate\n"); goto LTM_ERR; @@ -2483,7 +2483,7 @@ static int unit_tests(int argc, char **argv) ok = fail = nop = 0; t = (uint64_t)time(NULL); - printf("SEED: 0x%"PRIx64"\n\n", t); + printf("SEED: 0x%" PRIx64 "\n\n", t); s_mp_rand_jenkins_init(t); mp_rand_source(s_mp_rand_jenkins); diff --git a/libtommath/tommath.h b/libtommath/tommath.h index 2c4023c..fd28894 100644 --- a/libtommath/tommath.h +++ b/libtommath/tommath.h @@ -200,7 +200,7 @@ TOOM_SQR_CUTOFF; #endif /* size of comba arrays, should be at least 2 * 2**(BITS_PER_WORD - BITS_PER_DIGIT*2) */ -#define PRIVATE_MP_WARRAY (int)(1uLL << (((CHAR_BIT * sizeof(private_mp_word)) - (2 * MP_DIGIT_BIT)) + 1)) +#define PRIVATE_MP_WARRAY (int)(1 << (((CHAR_BIT * (int)sizeof(private_mp_word)) - (2 * MP_DIGIT_BIT)) + 1)) #define MP_WARRAY (MP_DEPRECATED_PRAGMA("MP_WARRAY is an internal macro") PRIVATE_MP_WARRAY) #if defined(__GNUC__) && __GNUC__ >= 4 -- cgit v0.12 From 188942001c88da55dd9a9bc5868470d8273b985b Mon Sep 17 00:00:00 2001 From: dgp Date: Mon, 9 Mar 2020 16:39:03 +0000 Subject: Record some ideas in the comments. --- generic/tclBinary.c | 7 +++++++ 1 file changed, 7 insertions(+) diff --git a/generic/tclBinary.c b/generic/tclBinary.c index 828a373..9984139 100644 --- a/generic/tclBinary.c +++ b/generic/tclBinary.c @@ -434,6 +434,8 @@ Tcl_GetByteArrayFromObj( if (irPtr == NULL) { if (TCL_ERROR == SetByteArrayFromAny(NULL, objPtr)) { + + /* TODO: Reconsider claiming a length for failed conversion. */ if (lengthPtr != NULL) { *lengthPtr = 0; } @@ -488,6 +490,8 @@ Tcl_SetByteArrayLength( if (length == 0) { Tcl_SetByteArrayObj(objPtr, NULL, 0); } else if (TCL_ERROR == SetByteArrayFromAny(NULL, objPtr)) { + + /* TODO: Consider a length limit on conversion attempt. */ return NULL; } irPtr = TclFetchIntRep(objPtr, &properByteArrayType); @@ -511,6 +515,8 @@ Tcl_SetByteArrayLength( * * Generate the ByteArray internal rep from the string rep. * + * TODO: Consider length limit on conversion. + * * Results: * The return value is always TCL_OK. * @@ -580,6 +586,7 @@ SetByteArrayFromAny( Tcl_ObjIntRep ir; (void)dummy; + /* TODO: Consider imposing this check on callers. */ if (TclHasIntRep(objPtr, &properByteArrayType)) { return TCL_OK; } -- cgit v0.12 From 04cd73a528530bb02e4b94162006f34751cbdd13 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 10 Mar 2020 15:58:27 +0000 Subject: re-generate configure scripts --- unix/configure | 14 +------------- win/configure | 14 +------------- 2 files changed, 2 insertions(+), 26 deletions(-) diff --git a/unix/configure b/unix/configure index c81cef3..8fa6e42 100755 --- a/unix/configure +++ b/unix/configure @@ -744,7 +744,6 @@ infodir docdir oldincludedir includedir -runstatedir localstatedir sharedstatedir sysconfdir @@ -834,7 +833,6 @@ datadir='${datarootdir}' sysconfdir='${prefix}/etc' sharedstatedir='${prefix}/com' localstatedir='${prefix}/var' -runstatedir='${localstatedir}/run' includedir='${prefix}/include' oldincludedir='/usr/include' docdir='${datarootdir}/doc/${PACKAGE_TARNAME}' @@ -1087,15 +1085,6 @@ do | -silent | --silent | --silen | --sile | --sil) silent=yes ;; - -runstatedir | --runstatedir | --runstatedi | --runstated \ - | --runstate | --runstat | --runsta | --runst | --runs \ - | --run | --ru | --r) - ac_prev=runstatedir ;; - -runstatedir=* | --runstatedir=* | --runstatedi=* | --runstated=* \ - | --runstate=* | --runstat=* | --runsta=* | --runst=* | --runs=* \ - | --run=* | --ru=* | --r=*) - runstatedir=$ac_optarg ;; - -sbindir | --sbindir | --sbindi | --sbind | --sbin | --sbi | --sb) ac_prev=sbindir ;; -sbindir=* | --sbindir=* | --sbindi=* | --sbind=* | --sbin=* \ @@ -1233,7 +1222,7 @@ fi for ac_var in exec_prefix prefix bindir sbindir libexecdir datarootdir \ datadir sysconfdir sharedstatedir localstatedir includedir \ oldincludedir docdir infodir htmldir dvidir pdfdir psdir \ - libdir localedir mandir runstatedir + libdir localedir mandir do eval ac_val=\$$ac_var # Remove trailing slashes. @@ -1386,7 +1375,6 @@ Fine tuning of the installation directories: --sysconfdir=DIR read-only single-machine data [PREFIX/etc] --sharedstatedir=DIR modifiable architecture-independent data [PREFIX/com] --localstatedir=DIR modifiable single-machine data [PREFIX/var] - --runstatedir=DIR modifiable per-process data [LOCALSTATEDIR/run] --libdir=DIR object code libraries [EPREFIX/lib] --includedir=DIR C header files [PREFIX/include] --oldincludedir=DIR C header files for non-gcc [/usr/include] diff --git a/win/configure b/win/configure index 00ec899..6ceae65 100755 --- a/win/configure +++ b/win/configure @@ -756,7 +756,6 @@ infodir docdir oldincludedir includedir -runstatedir localstatedir sharedstatedir sysconfdir @@ -834,7 +833,6 @@ datadir='${datarootdir}' sysconfdir='${prefix}/etc' sharedstatedir='${prefix}/com' localstatedir='${prefix}/var' -runstatedir='${localstatedir}/run' includedir='${prefix}/include' oldincludedir='/usr/include' docdir='${datarootdir}/doc/${PACKAGE}' @@ -1087,15 +1085,6 @@ do | -silent | --silent | --silen | --sile | --sil) silent=yes ;; - -runstatedir | --runstatedir | --runstatedi | --runstated \ - | --runstate | --runstat | --runsta | --runst | --runs \ - | --run | --ru | --r) - ac_prev=runstatedir ;; - -runstatedir=* | --runstatedir=* | --runstatedi=* | --runstated=* \ - | --runstate=* | --runstat=* | --runsta=* | --runst=* | --runs=* \ - | --run=* | --ru=* | --r=*) - runstatedir=$ac_optarg ;; - -sbindir | --sbindir | --sbindi | --sbind | --sbin | --sbi | --sb) ac_prev=sbindir ;; -sbindir=* | --sbindir=* | --sbindi=* | --sbind=* | --sbin=* \ @@ -1233,7 +1222,7 @@ fi for ac_var in exec_prefix prefix bindir sbindir libexecdir datarootdir \ datadir sysconfdir sharedstatedir localstatedir includedir \ oldincludedir docdir infodir htmldir dvidir pdfdir psdir \ - libdir localedir mandir runstatedir + libdir localedir mandir do eval ac_val=\$$ac_var # Remove trailing slashes. @@ -1386,7 +1375,6 @@ Fine tuning of the installation directories: --sysconfdir=DIR read-only single-machine data [PREFIX/etc] --sharedstatedir=DIR modifiable architecture-independent data [PREFIX/com] --localstatedir=DIR modifiable single-machine data [PREFIX/var] - --runstatedir=DIR modifiable per-process data [LOCALSTATEDIR/run] --libdir=DIR object code libraries [EPREFIX/lib] --includedir=DIR C header files [PREFIX/include] --oldincludedir=DIR C header files for non-gcc [/usr/include] -- cgit v0.12 From 6cced94fed2226a3d61858a780f2c6fe07070fc6 Mon Sep 17 00:00:00 2001 From: dgp Date: Fri, 13 Mar 2020 15:11:29 +0000 Subject: Fix mistaken merge. --- generic/tclBinary.c | 2 -- generic/tclTest.c | 5 ++++- tests/binary.test | 4 ++-- 3 files changed, 6 insertions(+), 5 deletions(-) diff --git a/generic/tclBinary.c b/generic/tclBinary.c index c1e5fba..5d1ce03 100644 --- a/generic/tclBinary.c +++ b/generic/tclBinary.c @@ -512,7 +512,6 @@ Tcl_SetByteArrayLength( SET_BYTEARRAY(irPtr, byteArrayPtr); } TclInvalidateStringRep(objPtr); - objPtr->typePtr = &properByteArrayType; byteArrayPtr->used = length; return byteArrayPtr->bytes; } @@ -827,7 +826,6 @@ TclAppendBytesToByteArray( } byteArrayPtr->used += len; TclInvalidateStringRep(objPtr); - objPtr->typePtr = &properByteArrayType; } /* diff --git a/generic/tclTest.c b/generic/tclTest.c index 211e654..94c130f 100644 --- a/generic/tclTest.c +++ b/generic/tclTest.c @@ -5047,7 +5047,10 @@ TestsetbytearraylengthObjCmd( } else { obj = objv[1]; } - Tcl_SetByteArrayLength(obj, n); + if (NULL == Tcl_SetByteArrayLength(obj, n)) { + Tcl_SetResult(interp, "expected bytes", TCL_STATIC); + return TCL_ERROR; + } Tcl_SetObjResult(interp, obj); return TCL_OK; } diff --git a/tests/binary.test b/tests/binary.test index 4e0944b..e7d5114 100644 --- a/tests/binary.test +++ b/tests/binary.test @@ -2925,9 +2925,9 @@ testConstraint testsetbytearraylength \ test binary-79.1 {Tcl_SetByteArrayLength} testsetbytearraylength { testsetbytearraylength [string cat A B C] 1 } A -test binary-79.2 {Tcl_SetByteArrayLength} testsetbytearraylength { +test binary-79.2 {Tcl_SetByteArrayLength} -body { testsetbytearraylength [string cat \u0141 B C] 1 -} A +} -constraints testsetbytearraylength -returnCodes error -match glob -result * # ---------------------------------------------------------------------- -- cgit v0.12 From e8904ca052835753145f2421336a01ce4ef30c70 Mon Sep 17 00:00:00 2001 From: dgp Date: Fri, 20 Mar 2020 20:23:00 +0000 Subject: Rework TIP 568 implementation for improved standard error message/code --- generic/tclBinary.c | 141 +++++++++++++++++++++++++++++++--------------------- generic/tclCmdAH.c | 3 +- generic/tclInt.h | 2 +- 3 files changed, 86 insertions(+), 60 deletions(-) diff --git a/generic/tclBinary.c b/generic/tclBinary.c index 00b5e4e..b4f9b22 100644 --- a/generic/tclBinary.c +++ b/generic/tclBinary.c @@ -434,23 +434,17 @@ unsigned char * TclGetBytesFromObj( Tcl_Interp *interp, /* For error reporting */ Tcl_Obj *objPtr, /* Value to extract from */ - int *lengthPtr) /* If non-NULL, filled with length of the + size_t *lengthPtr) /* If non-NULL, filled with length of the * array of bytes in the ByteArray object. */ { ByteArray *baPtr; const Tcl_ObjIntRep *irPtr = TclFetchIntRep(objPtr, &properByteArrayType); if (irPtr == NULL) { - SetByteArrayFromAny(NULL, objPtr); - irPtr = TclFetchIntRep(objPtr, &properByteArrayType); - if (irPtr == NULL) { - if (interp) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "expected bytes but got non-byte character")); - Tcl_SetErrorCode(interp, "TCL", "VALUE", "BYTES", NULL); - } + if (TCL_ERROR == SetByteArrayFromAny(interp, objPtr)) { return NULL; } + irPtr = TclFetchIntRep(objPtr, &properByteArrayType); } baPtr = GET_BYTEARRAY(irPtr); @@ -484,17 +478,24 @@ Tcl_GetByteArrayFromObj( int *lengthPtr) /* If non-NULL, filled with length of the * array of bytes in the ByteArray object. */ { - unsigned char *result = TclGetBytesFromObj(NULL, objPtr, lengthPtr); - - if (result == NULL) { - - /* TODO: Reconsider claiming a length for failed conversion. */ - if (lengthPtr != NULL) { + size_t numBytes = 0; + unsigned char *bytes = TclGetBytesFromObj(NULL, objPtr, &numBytes); + + /* Macro TclGetByteArrayFromObj passes NULL for lengthPtr as + * a trick to get around changing size. */ + if (lengthPtr) { + if (numBytes > INT_MAX) { + /* Caller asked for an int length, but true length is outside + * the int range. This case will be developed out of existence + * in Tcl 9. As interim measure, fail. */ + *lengthPtr = 0; + return NULL; + } else { + *lengthPtr = (int) numBytes; } - return NULL; } - return result; + return bytes; } /* @@ -557,44 +558,64 @@ Tcl_SetByteArrayLength( /* *---------------------------------------------------------------------- * - * SetByteArrayFromAny -- - * - * Generate the ByteArray internal rep from the string rep. + * MakeByteArray -- * - * TODO: Consider length limit on conversion. + * Generate a ByteArray internal rep from the string rep of objPtr. + * The generated byte sequence may have no more than limit bytes. The + * value of TCL_INDEX_NONE for limit indicates no limit imposed. If + * boolean argument demandProper is true, then no byte sequence should + * be output to the caller (write NULL instead). When no bytes sequence + * is output and interp is not NULL, leave an error message and error + * code in interp explaining why a proper byte sequence could not be + * made. * * Results: - * The return value is always TCL_OK. - * - * Side effects: - * A ByteArray object is stored as the internal rep of objPtr. + * Returns a boolean indicating whether the bytes generated (up to + * limit bytes) are a proper representation of (a limited prefix of) + * the string. Writes a pointer to the generated ByteArray to + * *byteArrayPtrPtr. If not NULL it needs to be released with Tcl_Free(). * *---------------------------------------------------------------------- */ static int MakeByteArray( + Tcl_Interp *interp, Tcl_Obj *objPtr, - int earlyOut, + size_t limit, + int demandProper, ByteArray **byteArrayPtrPtr) { - int length, proper = 1; - unsigned char *dst; + size_t length; const char *src = TclGetStringFromObj(objPtr, &length); - ByteArray *byteArrayPtr = (ByteArray *)Tcl_Alloc(BYTEARRAY_SIZE(length)); + size_t numBytes + = (limit != TCL_INDEX_NONE && limit < length) ? limit : length; + ByteArray *byteArrayPtr = (ByteArray *)Tcl_Alloc(BYTEARRAY_SIZE(numBytes)); + unsigned char *dst = byteArrayPtr->bytes; + unsigned char *dstEnd = dst + numBytes; const char *srcEnd = src + length; - Tcl_UniChar ch = 0; + int proper = 1; + + for (; src < srcEnd && dst < dstEnd; ) { + Tcl_UniChar ch; + int count = TclUtfToUniChar(src, &ch); - for (dst = byteArrayPtr->bytes; src < srcEnd; ) { - src += TclUtfToUniChar(src, &ch); if (ch > 255) { - proper = 0; - if (earlyOut) { - Tcl_Free(byteArrayPtr); - *byteArrayPtrPtr = NULL; - return proper; - } + proper = 0; + if (demandProper) { + if (interp) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "expected byte sequence but character %zu " + "was '%1s' (U+%06X)", dst - byteArrayPtr->bytes, + src, ch)); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "BYTES", NULL); + } + Tcl_Free(byteArrayPtr); + *byteArrayPtrPtr = NULL; + return proper; + } } + src += count; *dst++ = UCHAR(ch); } byteArrayPtr->used = dst - byteArrayPtr->bytes; @@ -612,7 +633,7 @@ TclNarrowToBytes( Tcl_ObjIntRep ir; ByteArray *byteArrayPtr; - if (0 == MakeByteArray(objPtr, 0, &byteArrayPtr)) { + if (0 == MakeByteArray(NULL, objPtr, TCL_INDEX_NONE, 0, &byteArrayPtr)) { objPtr = Tcl_NewObj(); TclInvalidateStringRep(objPtr); } @@ -623,20 +644,32 @@ TclNarrowToBytes( return objPtr; } + +/* + *---------------------------------------------------------------------- + * + * SetByteArrayFromAny -- + * + * Generate the ByteArray internal rep from the string rep. + * + * Results: + * Tcl return code indicating OK or ERROR. + * + * Side effects: + * A ByteArray struct may be stored as the internal rep of objPtr. + * + *---------------------------------------------------------------------- + */ + static int SetByteArrayFromAny( - TCL_UNUSED(Tcl_Interp *), + Tcl_Interp *interp, /* For error reporting. */ Tcl_Obj *objPtr) /* The object to convert to type ByteArray. */ { ByteArray *byteArrayPtr; Tcl_ObjIntRep ir; - /* TODO: Consider imposing this check on callers. */ - if (TclHasIntRep(objPtr, &properByteArrayType)) { - return TCL_OK; - } - - if (0 == MakeByteArray(objPtr, 1, &byteArrayPtr)) { + if (0 == MakeByteArray(interp, objPtr, TCL_INDEX_NONE, 1, &byteArrayPtr)) { return TCL_ERROR; } @@ -1453,9 +1486,8 @@ BinaryScanCmd( "value formatString ?varName ...?"); return TCL_ERROR; } - buffer = TclGetByteArrayFromObj(objv[1], &length); + buffer = TclGetBytesFromObj(interp, objv[1], &length); if (buffer == NULL) { - Tcl_AppendResult(interp, "binary scan expects bytes", NULL); return TCL_ERROR; } numberCachePtr = &numberCacheHash; @@ -2510,9 +2542,8 @@ BinaryEncodeHex( return TCL_ERROR; } - data = TclGetByteArrayFromObj(objv[1], &count); + data = TclGetBytesFromObj(interp, objv[1], &count); if (data == NULL) { - Tcl_AppendResult(interp, "binary encode expects bytes", NULL); return TCL_ERROR; } @@ -2711,9 +2742,8 @@ BinaryEncode64( } } - data = TclGetByteArrayFromObj(objv[objc - 1], &count); + data = TclGetBytesFromObj(interp, objv[objc - 1], &count); if (data == NULL) { - Tcl_AppendResult(interp, "binary encode expects bytes", NULL); return TCL_ERROR; } resultObj = Tcl_NewObj(); @@ -2815,10 +2845,8 @@ BinaryEncodeUu( } break; case OPT_WRAPCHAR: - wrapchar = TclGetByteArrayFromObj(objv[i + 1], &wrapcharlen); + wrapchar = TclGetBytesFromObj(interp, objv[i + 1], &wrapcharlen); if (wrapchar == NULL) { - Tcl_AppendResult(interp, - "binary encode -wrapchar expects bytes", NULL); return TCL_ERROR; } break; @@ -2831,9 +2859,8 @@ BinaryEncodeUu( */ offset = 0; - data = TclGetByteArrayFromObj(objv[objc - 1], &count); + data = TclGetBytesFromObj(interp, objv[objc - 1], &count); if (data == NULL) { - Tcl_AppendResult(interp, "binary encode expects bytes", NULL); return TCL_ERROR; } resultObj = Tcl_NewObj(); diff --git a/generic/tclCmdAH.c b/generic/tclCmdAH.c index 1f8a9d5..3e9b294 100644 --- a/generic/tclCmdAH.c +++ b/generic/tclCmdAH.c @@ -431,9 +431,8 @@ EncodingConvertfromObjCmd( /* * Convert the string into a byte array in 'ds' */ - bytesPtr = (char *) TclGetByteArrayFromObj(data, &length); + bytesPtr = (char *) TclGetBytesFromObj(interp, data, &length); if (bytesPtr == NULL) { - Tcl_AppendResult(interp, "encoding conversion expects bytes", NULL); Tcl_FreeEncoding(encoding); return TCL_ERROR; } diff --git a/generic/tclInt.h b/generic/tclInt.h index 592a03f..48bf2fd 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -2957,7 +2957,7 @@ MODULE_SCOPE void TclFSUnloadTempFile(Tcl_LoadHandle loadHandle); MODULE_SCOPE int * TclGetAsyncReadyPtr(void); MODULE_SCOPE Tcl_Obj * TclGetBgErrorHandler(Tcl_Interp *interp); MODULE_SCOPE unsigned char * TclGetBytesFromObj(Tcl_Interp *interp, - Tcl_Obj *objPtr, int *lengthPtr); + Tcl_Obj *objPtr, size_t *lengthPtr); MODULE_SCOPE int TclGetChannelFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr, Tcl_Channel *chanPtr, int *modePtr, int flags); -- cgit v0.12 From 780b1d457f63640ebbddfc144e8567c4ac7b7f88 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 25 Mar 2020 10:11:50 +0000 Subject: Simplify platform/internal stubs. Not to be merged soon, still highly experimental!!!! --- generic/tcl.decls | 8 +- generic/tclInt.decls | 219 +++++-------------------------- generic/tclIntPlatDecls.h | 319 +++------------------------------------------- generic/tclPlatDecls.h | 6 - generic/tclStubInit.c | 89 ++----------- win/tclWin32Dll.c | 2 +- win/tclWinError.c | 6 +- win/tclWinInit.c | 4 +- win/tclWinNotify.c | 6 +- win/tclWinSock.c | 4 +- 10 files changed, 75 insertions(+), 588 deletions(-) diff --git a/generic/tcl.decls b/generic/tcl.decls index 301d9ef..8555f72 100644 --- a/generic/tcl.decls +++ b/generic/tcl.decls @@ -2483,10 +2483,10 @@ interface tclPlat # Added in Tcl 8.1, Removed in Tcl 9.0 (converted to macro) -#declare 0 win { +#declare 0 { # TCHAR *Tcl_WinUtfToTChar(const char *str, size_t len, Tcl_DString *dsPtr) #} -#declare 1 win { +#declare 1 { # char *Tcl_WinTCharToUtf(const TCHAR *str, size_t len, Tcl_DString *dsPtr) #} @@ -2494,12 +2494,12 @@ interface tclPlat # Mac OS X specific functions # Removed in 9.0 -#declare 0 macosx { +#declare 0 { # int Tcl_MacOSXOpenBundleResources(Tcl_Interp *interp, # const char *bundleName, int hasResourceFile, # size_t maxPathLen, char *libraryPath) #} -declare 1 macosx { +declare 1 { int Tcl_MacOSXOpenVersionedBundleResources(Tcl_Interp *interp, const char *bundleName, const char *bundleVersion, int hasResourceFile, size_t maxPathLen, char *libraryPath) diff --git a/generic/tclInt.decls b/generic/tclInt.decls index fd3eed5..11bd196 100644 --- a/generic/tclInt.decls +++ b/generic/tclInt.decls @@ -1078,253 +1078,92 @@ declare 259 { interface tclIntPlat -################################ -# Windows specific functions - -declare 0 win { - void TclWinConvertError(DWORD errCode) +declare 0 { + void TclWinConvertError(int errCode) } -# Removed in 9.0: -#declare 1 win { -# void TclWinConvertWSAError(DWORD errCode) -#} -# Removed in 9.0: -#declare 2 win { -# struct servent *TclWinGetServByName(const char *nm, -# const char *proto) -#} -# Removed in 9.0: -#declare 3 win { -# int TclWinGetSockOpt(SOCKET s, int level, int optname, -# char *optval, int *optlen) -#} -declare 4 win { - HINSTANCE TclWinGetTclInstance(void) +declare 4 { + void *TclWinGetTclInstance(void) } -# new for 8.4.20+/8.5.12+ Cygwin only -declare 5 win { +declare 5 { int TclUnixWaitForFile(int fd, int mask, int timeout) } -# Removed in 8.1: -# declare 5 win { -# HINSTANCE TclWinLoadLibrary(char *name) -# } -# Removed in 9.0: -#declare 6 win { -# unsigned short TclWinNToHS(unsigned short ns) -#} -# Removed in 9.0: -#declare 7 win { -# int TclWinSetSockOpt(SOCKET s, int level, int optname, -# const char *optval, int optlen) -#} -declare 8 win { +declare 8 { size_t TclpGetPid(Tcl_Pid pid) } -# Removed in 9.0: -#declare 9 win { -# int TclWinGetPlatformId(void) -#} -# Removed in 9.0: -#declare 10 win { -# Tcl_DirEntry *TclpReaddir(TclDIR *dir) -#} -# Removed in 8.3.1 (for Win32s only): -#declare 10 win { -# int TclWinSynchSpawn(void *args, int type, void **trans, Tcl_Pid *pidPtr) -#} - -# Pipe channel functions - -declare 11 win { +declare 11 { void TclGetAndDetachPids(Tcl_Interp *interp, Tcl_Channel chan) } -declare 12 win { +declare 12 { int TclpCloseFile(TclFile file) } -declare 13 win { +declare 13 { Tcl_Channel TclpCreateCommandChannel(TclFile readFile, TclFile writeFile, TclFile errorFile, int numPids, Tcl_Pid *pidPtr) } -declare 14 win { +declare 14 { int TclpCreatePipe(TclFile *readPipe, TclFile *writePipe) } -declare 15 win { +declare 15 { int TclpCreateProcess(Tcl_Interp *interp, int argc, const char **argv, TclFile inputFile, TclFile outputFile, TclFile errorFile, Tcl_Pid *pidPtr) } -# new for 8.4.20+/8.5.12+ Cygwin only -declare 16 win { +declare 16 { int TclpIsAtty(int fd) } -# Signature changed in 8.1: -# declare 16 win { -# TclFile TclpCreateTempFile(char *contents, Tcl_DString *namePtr) -# } -# declare 17 win { -# char *TclpGetTZName(void) -# } -# new for 8.5.12+ Cygwin only -declare 17 win { +declare 17 { int TclUnixCopyFile(const char *src, const char *dst, const Tcl_StatBuf *statBufPtr, int dontCopyAtts) } -declare 18 win { +declare 18 { TclFile TclpMakeFile(Tcl_Channel channel, int direction) } -declare 19 win { +declare 19 { TclFile TclpOpenFile(const char *fname, int mode) } -declare 20 win { +declare 20 { void TclWinAddProcess(HANDLE hProcess, size_t id) } -# Removed in 9.0: -#declare 21 win { -# char *TclpInetNtoa(struct in_addr addr) -#} -# removed permanently for 8.4 -#declare 21 win { -# void TclpAsyncMark(Tcl_AsyncHandler async) -#} - -# Added in 8.1: -declare 22 win { +declare 22 { TclFile TclpCreateTempFile(const char *contents) } -# Removed in 8.6: -#declare 23 win { -# char *TclpGetTZName(int isdst) -#} -declare 24 win { +declare 24 { char *TclWinNoBackslash(char *path) } -# replaced by generic TclGetPlatform -#declare 25 win { -# TclPlatformType *TclWinGetPlatform(void) -#} -# Removed in 9.0: -#declare 26 win { -# void TclWinSetInterfaces(int wide) -#} - -# Added in Tcl 8.3.3 / 8.4 - -declare 27 win { +declare 27 { void TclWinFlushDirtyChannels(void) } - -# Added in 8.4.2 - -# Removed in 9.0: -#declare 28 win { -# void TclWinResetInterfaces(void) -#} - -################################ -# Unix specific functions - -# Pipe channel functions - -declare 0 unix { - void TclGetAndDetachPids(Tcl_Interp *interp, Tcl_Channel chan) -} -declare 1 unix { - int TclpCloseFile(TclFile file) -} -declare 2 unix { - Tcl_Channel TclpCreateCommandChannel(TclFile readFile, - TclFile writeFile, TclFile errorFile, int numPids, Tcl_Pid *pidPtr) -} -declare 3 unix { - int TclpCreatePipe(TclFile *readPipe, TclFile *writePipe) -} -declare 4 unix { - int TclpCreateProcess(Tcl_Interp *interp, int argc, - const char **argv, TclFile inputFile, TclFile outputFile, - TclFile errorFile, Tcl_Pid *pidPtr) -} -# Signature changed in 8.1: -# declare 5 unix { -# TclFile TclpCreateTempFile(char *contents, Tcl_DString *namePtr) -# } -declare 6 unix { - TclFile TclpMakeFile(Tcl_Channel channel, int direction) -} -declare 7 unix { - TclFile TclpOpenFile(const char *fname, int mode) -} -declare 8 unix { - int TclUnixWaitForFile(int fd, int mask, int timeout) -} - -# Added in 8.1: - -declare 9 unix { - TclFile TclpCreateTempFile(const char *contents) +declare 29 { + int TclWinCPUID(int index, int *regs) } - -# Added in 8.4: - -# Removed in 9.0: -#declare 10 unix { -# Tcl_DirEntry *TclpReaddir(TclDIR *dir) -#} -# Removed in 9.0: -#declare 11 unix { -# struct tm *TclpLocaltime_unix(const time_t *clock) -#} -# Removed in 9.0: -#declare 12 unix { -# struct tm *TclpGmtime_unix(const time_t *clock) -#} -# Removed in 9.0: -#declare 13 unix { -# char *TclpInetNtoa(struct in_addr addr) -#} - -# Added in 8.5: - -declare 14 unix { - int TclUnixCopyFile(const char *src, const char *dst, - const Tcl_StatBuf *statBufPtr, int dontCopyAtts) +declare 30 { + int TclUnixOpenTemporaryFile(Tcl_Obj *dirObj, Tcl_Obj *basenameObj, + Tcl_Obj *extensionObj, Tcl_Obj *resultingNameObj) } ################################ # Mac OS X specific functions -declare 15 {unix macosx} { +declare 31 { int TclMacOSXGetFileAttribute(Tcl_Interp *interp, int objIndex, Tcl_Obj *fileName, Tcl_Obj **attributePtrPtr) } -declare 16 {unix macosx} { +declare 32 { int TclMacOSXSetFileAttribute(Tcl_Interp *interp, int objIndex, Tcl_Obj *fileName, Tcl_Obj *attributePtr) } -declare 17 {unix macosx} { +declare 33 { int TclMacOSXCopyFileAttributes(const char *src, const char *dst, const Tcl_StatBuf *statBufPtr) } -declare 18 {unix macosx} { +declare 34 { int TclMacOSXMatchType(Tcl_Interp *interp, const char *pathName, const char *fileName, Tcl_StatBuf *statBufPtr, Tcl_GlobTypeData *types) } -declare 19 {unix macosx} { +declare 35 { void TclMacOSXNotifierAddRunLoopMode(const void *runLoopMode) } -declare 22 {unix macosx} { - TclFile TclpCreateTempFile_(const char *contents) -} - -declare 29 {win unix} { - int TclWinCPUID(int index, int *regs) -} -# Added in 8.6; core of TclpOpenTemporaryFile -declare 30 {win unix} { - int TclUnixOpenTemporaryFile(Tcl_Obj *dirObj, Tcl_Obj *basenameObj, - Tcl_Obj *extensionObj, Tcl_Obj *resultingNameObj) -} # Local Variables: # mode: tcl diff --git a/generic/tclIntPlatDecls.h b/generic/tclIntPlatDecls.h index 726032b..ee2155e 100644 --- a/generic/tclIntPlatDecls.h +++ b/generic/tclIntPlatDecls.h @@ -40,85 +40,13 @@ extern "C" { * Exported function declarations: */ -#if !defined(_WIN32) && !defined(__CYGWIN__) && !defined(MAC_OSX_TCL) /* UNIX */ /* 0 */ -EXTERN void TclGetAndDetachPids(Tcl_Interp *interp, - Tcl_Channel chan); -/* 1 */ -EXTERN int TclpCloseFile(TclFile file); -/* 2 */ -EXTERN Tcl_Channel TclpCreateCommandChannel(TclFile readFile, - TclFile writeFile, TclFile errorFile, - int numPids, Tcl_Pid *pidPtr); -/* 3 */ -EXTERN int TclpCreatePipe(TclFile *readPipe, TclFile *writePipe); -/* 4 */ -EXTERN int TclpCreateProcess(Tcl_Interp *interp, int argc, - const char **argv, TclFile inputFile, - TclFile outputFile, TclFile errorFile, - Tcl_Pid *pidPtr); -/* Slot 5 is reserved */ -/* 6 */ -EXTERN TclFile TclpMakeFile(Tcl_Channel channel, int direction); -/* 7 */ -EXTERN TclFile TclpOpenFile(const char *fname, int mode); -/* 8 */ -EXTERN int TclUnixWaitForFile(int fd, int mask, int timeout); -/* 9 */ -EXTERN TclFile TclpCreateTempFile(const char *contents); -/* Slot 10 is reserved */ -/* Slot 11 is reserved */ -/* Slot 12 is reserved */ -/* Slot 13 is reserved */ -/* 14 */ -EXTERN int TclUnixCopyFile(const char *src, const char *dst, - const Tcl_StatBuf *statBufPtr, - int dontCopyAtts); -/* 15 */ -EXTERN int TclMacOSXGetFileAttribute(Tcl_Interp *interp, - int objIndex, Tcl_Obj *fileName, - Tcl_Obj **attributePtrPtr); -/* 16 */ -EXTERN int TclMacOSXSetFileAttribute(Tcl_Interp *interp, - int objIndex, Tcl_Obj *fileName, - Tcl_Obj *attributePtr); -/* 17 */ -EXTERN int TclMacOSXCopyFileAttributes(const char *src, - const char *dst, - const Tcl_StatBuf *statBufPtr); -/* 18 */ -EXTERN int TclMacOSXMatchType(Tcl_Interp *interp, - const char *pathName, const char *fileName, - Tcl_StatBuf *statBufPtr, - Tcl_GlobTypeData *types); -/* 19 */ -EXTERN void TclMacOSXNotifierAddRunLoopMode( - const void *runLoopMode); -/* Slot 20 is reserved */ -/* Slot 21 is reserved */ -/* 22 */ -EXTERN TclFile TclpCreateTempFile_(const char *contents); -/* Slot 23 is reserved */ -/* Slot 24 is reserved */ -/* Slot 25 is reserved */ -/* Slot 26 is reserved */ -/* Slot 27 is reserved */ -/* Slot 28 is reserved */ -/* 29 */ -EXTERN int TclWinCPUID(int index, int *regs); -/* 30 */ -EXTERN int TclUnixOpenTemporaryFile(Tcl_Obj *dirObj, - Tcl_Obj *basenameObj, Tcl_Obj *extensionObj, - Tcl_Obj *resultingNameObj); -#endif /* UNIX */ -#if defined(_WIN32) || defined(__CYGWIN__) /* WIN */ -/* 0 */ -EXTERN void TclWinConvertError(DWORD errCode); +EXTERN void TclWinConvertError(int errCode); /* Slot 1 is reserved */ /* Slot 2 is reserved */ /* Slot 3 is reserved */ /* 4 */ -EXTERN HINSTANCE TclWinGetTclInstance(void); +EXTERN void * TclWinGetTclInstance(void); /* 5 */ EXTERN int TclUnixWaitForFile(int fd, int mask, int timeout); /* Slot 6 is reserved */ @@ -172,122 +100,36 @@ EXTERN int TclWinCPUID(int index, int *regs); EXTERN int TclUnixOpenTemporaryFile(Tcl_Obj *dirObj, Tcl_Obj *basenameObj, Tcl_Obj *extensionObj, Tcl_Obj *resultingNameObj); -#endif /* WIN */ -#ifdef MAC_OSX_TCL /* MACOSX */ -/* 0 */ -EXTERN void TclGetAndDetachPids(Tcl_Interp *interp, - Tcl_Channel chan); -/* 1 */ -EXTERN int TclpCloseFile(TclFile file); -/* 2 */ -EXTERN Tcl_Channel TclpCreateCommandChannel(TclFile readFile, - TclFile writeFile, TclFile errorFile, - int numPids, Tcl_Pid *pidPtr); -/* 3 */ -EXTERN int TclpCreatePipe(TclFile *readPipe, TclFile *writePipe); -/* 4 */ -EXTERN int TclpCreateProcess(Tcl_Interp *interp, int argc, - const char **argv, TclFile inputFile, - TclFile outputFile, TclFile errorFile, - Tcl_Pid *pidPtr); -/* Slot 5 is reserved */ -/* 6 */ -EXTERN TclFile TclpMakeFile(Tcl_Channel channel, int direction); -/* 7 */ -EXTERN TclFile TclpOpenFile(const char *fname, int mode); -/* 8 */ -EXTERN int TclUnixWaitForFile(int fd, int mask, int timeout); -/* 9 */ -EXTERN TclFile TclpCreateTempFile(const char *contents); -/* Slot 10 is reserved */ -/* Slot 11 is reserved */ -/* Slot 12 is reserved */ -/* Slot 13 is reserved */ -/* 14 */ -EXTERN int TclUnixCopyFile(const char *src, const char *dst, - const Tcl_StatBuf *statBufPtr, - int dontCopyAtts); -/* 15 */ +/* 31 */ EXTERN int TclMacOSXGetFileAttribute(Tcl_Interp *interp, int objIndex, Tcl_Obj *fileName, Tcl_Obj **attributePtrPtr); -/* 16 */ +/* 32 */ EXTERN int TclMacOSXSetFileAttribute(Tcl_Interp *interp, int objIndex, Tcl_Obj *fileName, Tcl_Obj *attributePtr); -/* 17 */ +/* 33 */ EXTERN int TclMacOSXCopyFileAttributes(const char *src, const char *dst, const Tcl_StatBuf *statBufPtr); -/* 18 */ +/* 34 */ EXTERN int TclMacOSXMatchType(Tcl_Interp *interp, const char *pathName, const char *fileName, Tcl_StatBuf *statBufPtr, Tcl_GlobTypeData *types); -/* 19 */ +/* 35 */ EXTERN void TclMacOSXNotifierAddRunLoopMode( const void *runLoopMode); -/* Slot 20 is reserved */ -/* Slot 21 is reserved */ -/* 22 */ -EXTERN TclFile TclpCreateTempFile_(const char *contents); -/* Slot 23 is reserved */ -/* Slot 24 is reserved */ -/* Slot 25 is reserved */ -/* Slot 26 is reserved */ -/* Slot 27 is reserved */ -/* Slot 28 is reserved */ -/* 29 */ -EXTERN int TclWinCPUID(int index, int *regs); -/* 30 */ -EXTERN int TclUnixOpenTemporaryFile(Tcl_Obj *dirObj, - Tcl_Obj *basenameObj, Tcl_Obj *extensionObj, - Tcl_Obj *resultingNameObj); -#endif /* MACOSX */ typedef struct TclIntPlatStubs { int magic; void *hooks; -#if !defined(_WIN32) && !defined(__CYGWIN__) && !defined(MAC_OSX_TCL) /* UNIX */ - void (*tclGetAndDetachPids) (Tcl_Interp *interp, Tcl_Channel chan); /* 0 */ - int (*tclpCloseFile) (TclFile file); /* 1 */ - Tcl_Channel (*tclpCreateCommandChannel) (TclFile readFile, TclFile writeFile, TclFile errorFile, int numPids, Tcl_Pid *pidPtr); /* 2 */ - int (*tclpCreatePipe) (TclFile *readPipe, TclFile *writePipe); /* 3 */ - int (*tclpCreateProcess) (Tcl_Interp *interp, int argc, const char **argv, TclFile inputFile, TclFile outputFile, TclFile errorFile, Tcl_Pid *pidPtr); /* 4 */ - void (*reserved5)(void); - TclFile (*tclpMakeFile) (Tcl_Channel channel, int direction); /* 6 */ - TclFile (*tclpOpenFile) (const char *fname, int mode); /* 7 */ - int (*tclUnixWaitForFile) (int fd, int mask, int timeout); /* 8 */ - TclFile (*tclpCreateTempFile) (const char *contents); /* 9 */ - void (*reserved10)(void); - void (*reserved11)(void); - void (*reserved12)(void); - void (*reserved13)(void); - int (*tclUnixCopyFile) (const char *src, const char *dst, const Tcl_StatBuf *statBufPtr, int dontCopyAtts); /* 14 */ - int (*tclMacOSXGetFileAttribute) (Tcl_Interp *interp, int objIndex, Tcl_Obj *fileName, Tcl_Obj **attributePtrPtr); /* 15 */ - int (*tclMacOSXSetFileAttribute) (Tcl_Interp *interp, int objIndex, Tcl_Obj *fileName, Tcl_Obj *attributePtr); /* 16 */ - int (*tclMacOSXCopyFileAttributes) (const char *src, const char *dst, const Tcl_StatBuf *statBufPtr); /* 17 */ - int (*tclMacOSXMatchType) (Tcl_Interp *interp, const char *pathName, const char *fileName, Tcl_StatBuf *statBufPtr, Tcl_GlobTypeData *types); /* 18 */ - void (*tclMacOSXNotifierAddRunLoopMode) (const void *runLoopMode); /* 19 */ - void (*reserved20)(void); - void (*reserved21)(void); - TclFile (*tclpCreateTempFile_) (const char *contents); /* 22 */ - void (*reserved23)(void); - void (*reserved24)(void); - void (*reserved25)(void); - void (*reserved26)(void); - void (*reserved27)(void); - void (*reserved28)(void); - int (*tclWinCPUID) (int index, int *regs); /* 29 */ - int (*tclUnixOpenTemporaryFile) (Tcl_Obj *dirObj, Tcl_Obj *basenameObj, Tcl_Obj *extensionObj, Tcl_Obj *resultingNameObj); /* 30 */ -#endif /* UNIX */ -#if defined(_WIN32) || defined(__CYGWIN__) /* WIN */ - void (*tclWinConvertError) (DWORD errCode); /* 0 */ + void (*tclWinConvertError) (int errCode); /* 0 */ void (*reserved1)(void); void (*reserved2)(void); void (*reserved3)(void); - HINSTANCE (*tclWinGetTclInstance) (void); /* 4 */ + void * (*tclWinGetTclInstance) (void); /* 4 */ int (*tclUnixWaitForFile) (int fd, int mask, int timeout); /* 5 */ void (*reserved6)(void); void (*reserved7)(void); @@ -314,40 +156,11 @@ typedef struct TclIntPlatStubs { void (*reserved28)(void); int (*tclWinCPUID) (int index, int *regs); /* 29 */ int (*tclUnixOpenTemporaryFile) (Tcl_Obj *dirObj, Tcl_Obj *basenameObj, Tcl_Obj *extensionObj, Tcl_Obj *resultingNameObj); /* 30 */ -#endif /* WIN */ -#ifdef MAC_OSX_TCL /* MACOSX */ - void (*tclGetAndDetachPids) (Tcl_Interp *interp, Tcl_Channel chan); /* 0 */ - int (*tclpCloseFile) (TclFile file); /* 1 */ - Tcl_Channel (*tclpCreateCommandChannel) (TclFile readFile, TclFile writeFile, TclFile errorFile, int numPids, Tcl_Pid *pidPtr); /* 2 */ - int (*tclpCreatePipe) (TclFile *readPipe, TclFile *writePipe); /* 3 */ - int (*tclpCreateProcess) (Tcl_Interp *interp, int argc, const char **argv, TclFile inputFile, TclFile outputFile, TclFile errorFile, Tcl_Pid *pidPtr); /* 4 */ - void (*reserved5)(void); - TclFile (*tclpMakeFile) (Tcl_Channel channel, int direction); /* 6 */ - TclFile (*tclpOpenFile) (const char *fname, int mode); /* 7 */ - int (*tclUnixWaitForFile) (int fd, int mask, int timeout); /* 8 */ - TclFile (*tclpCreateTempFile) (const char *contents); /* 9 */ - void (*reserved10)(void); - void (*reserved11)(void); - void (*reserved12)(void); - void (*reserved13)(void); - int (*tclUnixCopyFile) (const char *src, const char *dst, const Tcl_StatBuf *statBufPtr, int dontCopyAtts); /* 14 */ - int (*tclMacOSXGetFileAttribute) (Tcl_Interp *interp, int objIndex, Tcl_Obj *fileName, Tcl_Obj **attributePtrPtr); /* 15 */ - int (*tclMacOSXSetFileAttribute) (Tcl_Interp *interp, int objIndex, Tcl_Obj *fileName, Tcl_Obj *attributePtr); /* 16 */ - int (*tclMacOSXCopyFileAttributes) (const char *src, const char *dst, const Tcl_StatBuf *statBufPtr); /* 17 */ - int (*tclMacOSXMatchType) (Tcl_Interp *interp, const char *pathName, const char *fileName, Tcl_StatBuf *statBufPtr, Tcl_GlobTypeData *types); /* 18 */ - void (*tclMacOSXNotifierAddRunLoopMode) (const void *runLoopMode); /* 19 */ - void (*reserved20)(void); - void (*reserved21)(void); - TclFile (*tclpCreateTempFile_) (const char *contents); /* 22 */ - void (*reserved23)(void); - void (*reserved24)(void); - void (*reserved25)(void); - void (*reserved26)(void); - void (*reserved27)(void); - void (*reserved28)(void); - int (*tclWinCPUID) (int index, int *regs); /* 29 */ - int (*tclUnixOpenTemporaryFile) (Tcl_Obj *dirObj, Tcl_Obj *basenameObj, Tcl_Obj *extensionObj, Tcl_Obj *resultingNameObj); /* 30 */ -#endif /* MACOSX */ + int (*tclMacOSXGetFileAttribute) (Tcl_Interp *interp, int objIndex, Tcl_Obj *fileName, Tcl_Obj **attributePtrPtr); /* 31 */ + int (*tclMacOSXSetFileAttribute) (Tcl_Interp *interp, int objIndex, Tcl_Obj *fileName, Tcl_Obj *attributePtr); /* 32 */ + int (*tclMacOSXCopyFileAttributes) (const char *src, const char *dst, const Tcl_StatBuf *statBufPtr); /* 33 */ + int (*tclMacOSXMatchType) (Tcl_Interp *interp, const char *pathName, const char *fileName, Tcl_StatBuf *statBufPtr, Tcl_GlobTypeData *types); /* 34 */ + void (*tclMacOSXNotifierAddRunLoopMode) (const void *runLoopMode); /* 35 */ } TclIntPlatStubs; extern const TclIntPlatStubs *tclIntPlatStubsPtr; @@ -362,58 +175,6 @@ extern const TclIntPlatStubs *tclIntPlatStubsPtr; * Inline function declarations: */ -#if !defined(_WIN32) && !defined(__CYGWIN__) && !defined(MAC_OSX_TCL) /* UNIX */ -#define TclGetAndDetachPids \ - (tclIntPlatStubsPtr->tclGetAndDetachPids) /* 0 */ -#define TclpCloseFile \ - (tclIntPlatStubsPtr->tclpCloseFile) /* 1 */ -#define TclpCreateCommandChannel \ - (tclIntPlatStubsPtr->tclpCreateCommandChannel) /* 2 */ -#define TclpCreatePipe \ - (tclIntPlatStubsPtr->tclpCreatePipe) /* 3 */ -#define TclpCreateProcess \ - (tclIntPlatStubsPtr->tclpCreateProcess) /* 4 */ -/* Slot 5 is reserved */ -#define TclpMakeFile \ - (tclIntPlatStubsPtr->tclpMakeFile) /* 6 */ -#define TclpOpenFile \ - (tclIntPlatStubsPtr->tclpOpenFile) /* 7 */ -#define TclUnixWaitForFile \ - (tclIntPlatStubsPtr->tclUnixWaitForFile) /* 8 */ -#define TclpCreateTempFile \ - (tclIntPlatStubsPtr->tclpCreateTempFile) /* 9 */ -/* Slot 10 is reserved */ -/* Slot 11 is reserved */ -/* Slot 12 is reserved */ -/* Slot 13 is reserved */ -#define TclUnixCopyFile \ - (tclIntPlatStubsPtr->tclUnixCopyFile) /* 14 */ -#define TclMacOSXGetFileAttribute \ - (tclIntPlatStubsPtr->tclMacOSXGetFileAttribute) /* 15 */ -#define TclMacOSXSetFileAttribute \ - (tclIntPlatStubsPtr->tclMacOSXSetFileAttribute) /* 16 */ -#define TclMacOSXCopyFileAttributes \ - (tclIntPlatStubsPtr->tclMacOSXCopyFileAttributes) /* 17 */ -#define TclMacOSXMatchType \ - (tclIntPlatStubsPtr->tclMacOSXMatchType) /* 18 */ -#define TclMacOSXNotifierAddRunLoopMode \ - (tclIntPlatStubsPtr->tclMacOSXNotifierAddRunLoopMode) /* 19 */ -/* Slot 20 is reserved */ -/* Slot 21 is reserved */ -#define TclpCreateTempFile_ \ - (tclIntPlatStubsPtr->tclpCreateTempFile_) /* 22 */ -/* Slot 23 is reserved */ -/* Slot 24 is reserved */ -/* Slot 25 is reserved */ -/* Slot 26 is reserved */ -/* Slot 27 is reserved */ -/* Slot 28 is reserved */ -#define TclWinCPUID \ - (tclIntPlatStubsPtr->tclWinCPUID) /* 29 */ -#define TclUnixOpenTemporaryFile \ - (tclIntPlatStubsPtr->tclUnixOpenTemporaryFile) /* 30 */ -#endif /* UNIX */ -#if defined(_WIN32) || defined(__CYGWIN__) /* WIN */ #define TclWinConvertError \ (tclIntPlatStubsPtr->tclWinConvertError) /* 0 */ /* Slot 1 is reserved */ @@ -464,58 +225,16 @@ extern const TclIntPlatStubs *tclIntPlatStubsPtr; (tclIntPlatStubsPtr->tclWinCPUID) /* 29 */ #define TclUnixOpenTemporaryFile \ (tclIntPlatStubsPtr->tclUnixOpenTemporaryFile) /* 30 */ -#endif /* WIN */ -#ifdef MAC_OSX_TCL /* MACOSX */ -#define TclGetAndDetachPids \ - (tclIntPlatStubsPtr->tclGetAndDetachPids) /* 0 */ -#define TclpCloseFile \ - (tclIntPlatStubsPtr->tclpCloseFile) /* 1 */ -#define TclpCreateCommandChannel \ - (tclIntPlatStubsPtr->tclpCreateCommandChannel) /* 2 */ -#define TclpCreatePipe \ - (tclIntPlatStubsPtr->tclpCreatePipe) /* 3 */ -#define TclpCreateProcess \ - (tclIntPlatStubsPtr->tclpCreateProcess) /* 4 */ -/* Slot 5 is reserved */ -#define TclpMakeFile \ - (tclIntPlatStubsPtr->tclpMakeFile) /* 6 */ -#define TclpOpenFile \ - (tclIntPlatStubsPtr->tclpOpenFile) /* 7 */ -#define TclUnixWaitForFile \ - (tclIntPlatStubsPtr->tclUnixWaitForFile) /* 8 */ -#define TclpCreateTempFile \ - (tclIntPlatStubsPtr->tclpCreateTempFile) /* 9 */ -/* Slot 10 is reserved */ -/* Slot 11 is reserved */ -/* Slot 12 is reserved */ -/* Slot 13 is reserved */ -#define TclUnixCopyFile \ - (tclIntPlatStubsPtr->tclUnixCopyFile) /* 14 */ #define TclMacOSXGetFileAttribute \ - (tclIntPlatStubsPtr->tclMacOSXGetFileAttribute) /* 15 */ + (tclIntPlatStubsPtr->tclMacOSXGetFileAttribute) /* 31 */ #define TclMacOSXSetFileAttribute \ - (tclIntPlatStubsPtr->tclMacOSXSetFileAttribute) /* 16 */ + (tclIntPlatStubsPtr->tclMacOSXSetFileAttribute) /* 32 */ #define TclMacOSXCopyFileAttributes \ - (tclIntPlatStubsPtr->tclMacOSXCopyFileAttributes) /* 17 */ + (tclIntPlatStubsPtr->tclMacOSXCopyFileAttributes) /* 33 */ #define TclMacOSXMatchType \ - (tclIntPlatStubsPtr->tclMacOSXMatchType) /* 18 */ + (tclIntPlatStubsPtr->tclMacOSXMatchType) /* 34 */ #define TclMacOSXNotifierAddRunLoopMode \ - (tclIntPlatStubsPtr->tclMacOSXNotifierAddRunLoopMode) /* 19 */ -/* Slot 20 is reserved */ -/* Slot 21 is reserved */ -#define TclpCreateTempFile_ \ - (tclIntPlatStubsPtr->tclpCreateTempFile_) /* 22 */ -/* Slot 23 is reserved */ -/* Slot 24 is reserved */ -/* Slot 25 is reserved */ -/* Slot 26 is reserved */ -/* Slot 27 is reserved */ -/* Slot 28 is reserved */ -#define TclWinCPUID \ - (tclIntPlatStubsPtr->tclWinCPUID) /* 29 */ -#define TclUnixOpenTemporaryFile \ - (tclIntPlatStubsPtr->tclUnixOpenTemporaryFile) /* 30 */ -#endif /* MACOSX */ + (tclIntPlatStubsPtr->tclMacOSXNotifierAddRunLoopMode) /* 35 */ #endif /* defined(USE_TCL_STUBS) */ diff --git a/generic/tclPlatDecls.h b/generic/tclPlatDecls.h index fb46271..4c07148 100644 --- a/generic/tclPlatDecls.h +++ b/generic/tclPlatDecls.h @@ -50,7 +50,6 @@ extern "C" { * Exported function declarations: */ -#ifdef MAC_OSX_TCL /* MACOSX */ /* Slot 0 is reserved */ /* 1 */ EXTERN int Tcl_MacOSXOpenVersionedBundleResources( @@ -58,16 +57,13 @@ EXTERN int Tcl_MacOSXOpenVersionedBundleResources( const char *bundleVersion, int hasResourceFile, size_t maxPathLen, char *libraryPath); -#endif /* MACOSX */ typedef struct TclPlatStubs { int magic; void *hooks; -#ifdef MAC_OSX_TCL /* MACOSX */ void (*reserved0)(void); int (*tcl_MacOSXOpenVersionedBundleResources) (Tcl_Interp *interp, const char *bundleName, const char *bundleVersion, int hasResourceFile, size_t maxPathLen, char *libraryPath); /* 1 */ -#endif /* MACOSX */ } TclPlatStubs; extern const TclPlatStubs *tclPlatStubsPtr; @@ -82,11 +78,9 @@ extern const TclPlatStubs *tclPlatStubsPtr; * Inline function declarations: */ -#ifdef MAC_OSX_TCL /* MACOSX */ /* Slot 0 is reserved */ #define Tcl_MacOSXOpenVersionedBundleResources \ (tclPlatStubsPtr->tcl_MacOSXOpenVersionedBundleResources) /* 1 */ -#endif /* MACOSX */ #endif /* defined(USE_TCL_STUBS) */ diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c index fac9286..ba3c58f 100644 --- a/generic/tclStubInit.c +++ b/generic/tclStubInit.c @@ -143,13 +143,13 @@ static void uniCodePanic() { #define TclBN_mp_toom_mul s_mp_toom_mul #define TclBN_mp_toom_sqr s_mp_toom_sqr -#define TclpCreateTempFile_ TclpCreateTempFile -#ifndef MAC_OSX_TCL /* On UNIX, fill with other stub entries */ -#define TclMacOSXGetFileAttribute (int (*)(Tcl_Interp *, int, Tcl_Obj *, Tcl_Obj **))(void *)TclpCreateProcess -#define TclMacOSXSetFileAttribute (int (*)(Tcl_Interp *, int, Tcl_Obj *, Tcl_Obj *))(void *)isatty -#define TclMacOSXCopyFileAttributes (int (*)(const char *, const char *, const Tcl_StatBuf *))(void *)TclUnixCopyFile -#define TclMacOSXMatchType (int (*)(Tcl_Interp *, const char *, const char *, Tcl_StatBuf *, Tcl_GlobTypeData *))(void *)TclpMakeFile -#define TclMacOSXNotifierAddRunLoopMode (void (*)(const void *))TclpOpenFile +#ifndef MAC_OSX_TCL +# define Tcl_MacOSXOpenVersionedBundleResources 0 +# define TclMacOSXGetFileAttribute 0 +# define TclMacOSXSetFileAttribute 0 +# define TclMacOSXCopyFileAttributes 0 +# define TclMacOSXMatchType 0 +# define TclMacOSXNotifierAddRunLoopMode 0 #endif #ifdef _WIN32 @@ -541,40 +541,6 @@ static const TclIntStubs tclIntStubs = { static const TclIntPlatStubs tclIntPlatStubs = { TCL_STUB_MAGIC, 0, -#if !defined(_WIN32) && !defined(__CYGWIN__) && !defined(MAC_OSX_TCL) /* UNIX */ - TclGetAndDetachPids, /* 0 */ - TclpCloseFile, /* 1 */ - TclpCreateCommandChannel, /* 2 */ - TclpCreatePipe, /* 3 */ - TclpCreateProcess, /* 4 */ - 0, /* 5 */ - TclpMakeFile, /* 6 */ - TclpOpenFile, /* 7 */ - TclUnixWaitForFile, /* 8 */ - TclpCreateTempFile, /* 9 */ - 0, /* 10 */ - 0, /* 11 */ - 0, /* 12 */ - 0, /* 13 */ - TclUnixCopyFile, /* 14 */ - TclMacOSXGetFileAttribute, /* 15 */ - TclMacOSXSetFileAttribute, /* 16 */ - TclMacOSXCopyFileAttributes, /* 17 */ - TclMacOSXMatchType, /* 18 */ - TclMacOSXNotifierAddRunLoopMode, /* 19 */ - 0, /* 20 */ - 0, /* 21 */ - TclpCreateTempFile_, /* 22 */ - 0, /* 23 */ - 0, /* 24 */ - 0, /* 25 */ - 0, /* 26 */ - 0, /* 27 */ - 0, /* 28 */ - TclWinCPUID, /* 29 */ - TclUnixOpenTemporaryFile, /* 30 */ -#endif /* UNIX */ -#if defined(_WIN32) || defined(__CYGWIN__) /* WIN */ TclWinConvertError, /* 0 */ 0, /* 1 */ 0, /* 2 */ @@ -606,49 +572,18 @@ static const TclIntPlatStubs tclIntPlatStubs = { 0, /* 28 */ TclWinCPUID, /* 29 */ TclUnixOpenTemporaryFile, /* 30 */ -#endif /* WIN */ -#ifdef MAC_OSX_TCL /* MACOSX */ - TclGetAndDetachPids, /* 0 */ - TclpCloseFile, /* 1 */ - TclpCreateCommandChannel, /* 2 */ - TclpCreatePipe, /* 3 */ - TclpCreateProcess, /* 4 */ - 0, /* 5 */ - TclpMakeFile, /* 6 */ - TclpOpenFile, /* 7 */ - TclUnixWaitForFile, /* 8 */ - TclpCreateTempFile, /* 9 */ - 0, /* 10 */ - 0, /* 11 */ - 0, /* 12 */ - 0, /* 13 */ - TclUnixCopyFile, /* 14 */ - TclMacOSXGetFileAttribute, /* 15 */ - TclMacOSXSetFileAttribute, /* 16 */ - TclMacOSXCopyFileAttributes, /* 17 */ - TclMacOSXMatchType, /* 18 */ - TclMacOSXNotifierAddRunLoopMode, /* 19 */ - 0, /* 20 */ - 0, /* 21 */ - TclpCreateTempFile_, /* 22 */ - 0, /* 23 */ - 0, /* 24 */ - 0, /* 25 */ - 0, /* 26 */ - 0, /* 27 */ - 0, /* 28 */ - TclWinCPUID, /* 29 */ - TclUnixOpenTemporaryFile, /* 30 */ -#endif /* MACOSX */ + TclMacOSXGetFileAttribute, /* 31 */ + TclMacOSXSetFileAttribute, /* 32 */ + TclMacOSXCopyFileAttributes, /* 33 */ + TclMacOSXMatchType, /* 34 */ + TclMacOSXNotifierAddRunLoopMode, /* 35 */ }; static const TclPlatStubs tclPlatStubs = { TCL_STUB_MAGIC, 0, -#ifdef MAC_OSX_TCL /* MACOSX */ 0, /* 0 */ Tcl_MacOSXOpenVersionedBundleResources, /* 1 */ -#endif /* MACOSX */ }; const TclTomMathStubs tclTomMathStubs = { diff --git a/win/tclWin32Dll.c b/win/tclWin32Dll.c index de0ddad..737567b 100644 --- a/win/tclWin32Dll.c +++ b/win/tclWin32Dll.c @@ -152,7 +152,7 @@ DllMain( *---------------------------------------------------------------------- */ -HINSTANCE +void * TclWinGetTclInstance(void) { return hInstance; diff --git a/win/tclWinError.c b/win/tclWinError.c index fc07b3e..f93f000 100644 --- a/win/tclWinError.c +++ b/win/tclWinError.c @@ -349,11 +349,11 @@ static const unsigned char wsaErrorTable[] = { void TclWinConvertError( - DWORD errCode) /* Win32 error code. */ + int errCode) /* Win32 error code. */ { - if (errCode >= sizeof(errorTable)/sizeof(errorTable[0])) { + if ((unsigned)errCode >= sizeof(errorTable)/sizeof(errorTable[0])) { errCode -= WSAEWOULDBLOCK; - if (errCode >= sizeof(wsaErrorTable)/sizeof(wsaErrorTable[0])) { + if ((unsigned)errCode >= sizeof(wsaErrorTable)/sizeof(wsaErrorTable[0])) { Tcl_SetErrno(errorTable[1]); } else { Tcl_SetErrno(wsaErrorTable[errCode]); diff --git a/win/tclWinInit.c b/win/tclWinInit.c index 122c4ae..7bd46cc 100644 --- a/win/tclWinInit.c +++ b/win/tclWinInit.c @@ -344,7 +344,7 @@ InitializeDefaultLibraryDir( size_t *lengthPtr, Tcl_Encoding *encodingPtr) { - HMODULE hModule = TclWinGetTclInstance(); + HMODULE hModule = (HMODULE)TclWinGetTclInstance(); WCHAR wName[MAX_PATH + LIBRARY_SIZE]; char name[(MAX_PATH + LIBRARY_SIZE) * 3]; char *end, *p; @@ -392,7 +392,7 @@ InitializeSourceLibraryDir( size_t *lengthPtr, Tcl_Encoding *encodingPtr) { - HMODULE hModule = TclWinGetTclInstance(); + HMODULE hModule = (HMODULE)TclWinGetTclInstance(); WCHAR wName[MAX_PATH + LIBRARY_SIZE]; char name[(MAX_PATH + LIBRARY_SIZE) * 3]; char *end, *p; diff --git a/win/tclWinNotify.c b/win/tclWinNotify.c index 2ab4efa..caab574 100644 --- a/win/tclWinNotify.c +++ b/win/tclWinNotify.c @@ -103,7 +103,7 @@ Tcl_InitNotifier(void) clazz.style = 0; clazz.cbClsExtra = 0; clazz.cbWndExtra = 0; - clazz.hInstance = TclWinGetTclInstance(); + clazz.hInstance = (HMODULE)TclWinGetTclInstance(); clazz.hbrBackground = NULL; clazz.lpszMenuName = NULL; clazz.lpszClassName = className; @@ -195,7 +195,7 @@ Tcl_FinalizeNotifier( if (notifierCount) { notifierCount--; if (notifierCount == 0) { - UnregisterClassW(className, TclWinGetTclInstance()); + UnregisterClassW(className, (HMODULE)TclWinGetTclInstance()); } } LeaveCriticalSection(¬ifierMutex); @@ -360,7 +360,7 @@ Tcl_ServiceModeHook( if (mode == TCL_SERVICE_ALL && !tsdPtr->hwnd) { tsdPtr->hwnd = CreateWindowW(className, className, - WS_TILED, 0, 0, 0, 0, NULL, NULL, TclWinGetTclInstance(), + WS_TILED, 0, 0, 0, 0, NULL, NULL, (HMODULE)TclWinGetTclInstance(), NULL); /* diff --git a/win/tclWinSock.c b/win/tclWinSock.c index 0bdb499..bdf659a 100644 --- a/win/tclWinSock.c +++ b/win/tclWinSock.c @@ -2485,7 +2485,7 @@ InitSockets(void) windowClass.style = 0; windowClass.cbClsExtra = 0; windowClass.cbWndExtra = 0; - windowClass.hInstance = TclWinGetTclInstance(); + windowClass.hInstance = (HMODULE)TclWinGetTclInstance(); windowClass.hbrBackground = NULL; windowClass.lpszMenuName = NULL; windowClass.lpszClassName = className; @@ -2616,7 +2616,7 @@ SocketExitHandler( */ TclpFinalizeSockets(); - UnregisterClassW(className, TclWinGetTclInstance()); + UnregisterClassW(className, (HMODULE)TclWinGetTclInstance()); initialized = 0; Tcl_MutexUnlock(&socketMutex); } -- cgit v0.12 From f97237e4e5219db9e644adbfaea74b8c915d9c45 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 26 Mar 2020 16:25:09 +0000 Subject: Fix build on UNIX/MacOS --- generic/tclInt.decls | 2 +- generic/tclIntPlatDecls.h | 22 +++++++++++++++------- generic/tclStubInit.c | 6 ++++++ 3 files changed, 22 insertions(+), 8 deletions(-) diff --git a/generic/tclInt.decls b/generic/tclInt.decls index 11bd196..a15cf5f 100644 --- a/generic/tclInt.decls +++ b/generic/tclInt.decls @@ -1122,7 +1122,7 @@ declare 19 { TclFile TclpOpenFile(const char *fname, int mode) } declare 20 { - void TclWinAddProcess(HANDLE hProcess, size_t id) + void TclWinAddProcess(void *hProcess, size_t id) } declare 22 { TclFile TclpCreateTempFile(const char *contents) diff --git a/generic/tclIntPlatDecls.h b/generic/tclIntPlatDecls.h index d027fdc..592ff92 100644 --- a/generic/tclIntPlatDecls.h +++ b/generic/tclIntPlatDecls.h @@ -82,7 +82,7 @@ EXTERN TclFile TclpMakeFile(Tcl_Channel channel, int direction); /* 19 */ EXTERN TclFile TclpOpenFile(const char *fname, int mode); /* 20 */ -EXTERN void TclWinAddProcess(HANDLE hProcess, size_t id); +EXTERN void TclWinAddProcess(void *hProcess, size_t id); /* Slot 21 is reserved */ /* 22 */ EXTERN TclFile TclpCreateTempFile(const char *contents); @@ -145,7 +145,7 @@ typedef struct TclIntPlatStubs { int (*tclUnixCopyFile) (const char *src, const char *dst, const Tcl_StatBuf *statBufPtr, int dontCopyAtts); /* 17 */ TclFile (*tclpMakeFile) (Tcl_Channel channel, int direction); /* 18 */ TclFile (*tclpOpenFile) (const char *fname, int mode); /* 19 */ - void (*tclWinAddProcess) (HANDLE hProcess, size_t id); /* 20 */ + void (*tclWinAddProcess) (void *hProcess, size_t id); /* 20 */ void (*reserved21)(void); TclFile (*tclpCreateTempFile) (const char *contents); /* 22 */ void (*reserved23)(void); @@ -244,12 +244,20 @@ extern const TclIntPlatStubs *tclIntPlatStubsPtr; #define TCL_STORAGE_CLASS DLLIMPORT #define TclWinConvertWSAError TclWinConvertError +#if !defined(_WIN32) && !defined(__CYGWIN__) +# undef TclWinConvertError /* 0 */ +# undef TclWinGetTclInstance /* 4 */ +# undef TclWinAddProcess /* 20 */ +# undef TclWinNoBackslash /* 24 */ +# undef TclWinFlushDirtyChannels /* 27 */ +#endif + #ifndef MAC_OSX_TCL /* Not accessable on UNIX */ -#undef TclMacOSXGetFileAttribute /* 15 */ -#undef TclMacOSXSetFileAttribute /* 16 */ -#undef TclMacOSXCopyFileAttributes /* 17 */ -#undef TclMacOSXMatchType /* 18 */ -#undef TclMacOSXNotifierAddRunLoopMode /* 19 */ +# undef TclMacOSXGetFileAttribute /* 15 */ +# undef TclMacOSXSetFileAttribute /* 16 */ +# undef TclMacOSXCopyFileAttributes /* 17 */ +# undef TclMacOSXMatchType /* 18 */ +# undef TclMacOSXNotifierAddRunLoopMode /* 19 */ #endif #if !defined(_WIN32) diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c index f67a934..c4a24e6 100644 --- a/generic/tclStubInit.c +++ b/generic/tclStubInit.c @@ -248,6 +248,12 @@ static int utfNcasecmp(const char *s1, const char *s2, unsigned int n){ #endif /* TCL_WIDE_INT_IS_LONG */ +#else +# define TclWinConvertError 0 +# define TclWinGetTclInstance 0 +# define TclWinAddProcess 0 +# define TclWinNoBackslash 0 +# define TclWinFlushDirtyChannels 0 #endif /* __CYGWIN__ */ /* -- cgit v0.12 From 19f97be0859daec65be8b841c7fea40b9cf47f7b Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 27 Mar 2020 09:02:57 +0000 Subject: 2 undefined symbols on UNIX/MacOS --- generic/tclIntPlatDecls.h | 1 + generic/tclStubInit.c | 6 ++++-- 2 files changed, 5 insertions(+), 2 deletions(-) diff --git a/generic/tclIntPlatDecls.h b/generic/tclIntPlatDecls.h index 592ff92..8c5a6d8 100644 --- a/generic/tclIntPlatDecls.h +++ b/generic/tclIntPlatDecls.h @@ -247,6 +247,7 @@ extern const TclIntPlatStubs *tclIntPlatStubsPtr; #if !defined(_WIN32) && !defined(__CYGWIN__) # undef TclWinConvertError /* 0 */ # undef TclWinGetTclInstance /* 4 */ +# undef TclpIsAtty /* 16 */ # undef TclWinAddProcess /* 20 */ # undef TclWinNoBackslash /* 24 */ # undef TclWinFlushDirtyChannels /* 27 */ diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c index c4a24e6..b84feca 100644 --- a/generic/tclStubInit.c +++ b/generic/tclStubInit.c @@ -248,13 +248,15 @@ static int utfNcasecmp(const char *s1, const char *s2, unsigned int n){ #endif /* TCL_WIDE_INT_IS_LONG */ -#else +#else /* ! WIN32 && !__CYGWIN__ */ # define TclWinConvertError 0 # define TclWinGetTclInstance 0 # define TclWinAddProcess 0 # define TclWinNoBackslash 0 # define TclWinFlushDirtyChannels 0 -#endif /* __CYGWIN__ */ +# define TclpGetPid 0 +# define TclpIsAtty 0 +#endif /* _WIN32 */ /* * WARNING: The contents of this file is automatically generated by the -- cgit v0.12 From 3d26bf2941bb78c8538f4b9e5abfdcfee819c6f3 Mon Sep 17 00:00:00 2001 From: dgp Date: Mon, 30 Mar 2020 14:52:55 +0000 Subject: When Tcl_SetByteArrayLength truncates a value, demand only that the truncated range must be a proper byte sequence. --- generic/tclBinary.c | 15 ++++++--------- tests/binary.test | 12 ++++++++++++ 2 files changed, 18 insertions(+), 9 deletions(-) diff --git a/generic/tclBinary.c b/generic/tclBinary.c index 6d33c83..af2550d 100644 --- a/generic/tclBinary.c +++ b/generic/tclBinary.c @@ -64,7 +64,7 @@ static int GetFormatSpec(const char **formatPtr, char *cmdPtr, size_t *countPtr, int *flagsPtr); static Tcl_Obj * ScanNumber(unsigned char *buffer, int type, int flags, Tcl_HashTable **numberCachePtr); -static int SetByteArrayFromAny(Tcl_Interp *interp, +static int SetByteArrayFromAny(Tcl_Interp *interp, size_t limit, Tcl_Obj *objPtr); static void UpdateStringOfByteArray(Tcl_Obj *listPtr); static void DeleteScanNumberCache(Tcl_HashTable *numberCachePtr); @@ -441,7 +441,7 @@ TclGetBytesFromObj( const Tcl_ObjIntRep *irPtr = TclFetchIntRep(objPtr, &properByteArrayType); if (irPtr == NULL) { - if (TCL_ERROR == SetByteArrayFromAny(interp, objPtr)) { + if (TCL_ERROR == SetByteArrayFromAny(interp, TCL_INDEX_NONE, objPtr)) { return NULL; } irPtr = TclFetchIntRep(objPtr, &properByteArrayType); @@ -534,11 +534,7 @@ Tcl_SetByteArrayLength( irPtr = TclFetchIntRep(objPtr, &properByteArrayType); if (irPtr == NULL) { - if (length == 0) { - Tcl_SetByteArrayObj(objPtr, NULL, 0); - } else if (TCL_ERROR == SetByteArrayFromAny(NULL, objPtr)) { - - /* TODO: Consider a length limit on conversion attempt. */ + if (TCL_ERROR == SetByteArrayFromAny(NULL, length, objPtr)) { return NULL; } irPtr = TclFetchIntRep(objPtr, &properByteArrayType); @@ -664,12 +660,13 @@ TclNarrowToBytes( static int SetByteArrayFromAny( Tcl_Interp *interp, /* For error reporting. */ + size_t limit, /* Create no more than this many bytes */ Tcl_Obj *objPtr) /* The object to convert to type ByteArray. */ { ByteArray *byteArrayPtr; Tcl_ObjIntRep ir; - if (0 == MakeByteArray(interp, objPtr, TCL_INDEX_NONE, 1, &byteArrayPtr)) { + if (0 == MakeByteArray(interp, objPtr, limit, 1, &byteArrayPtr)) { return TCL_ERROR; } @@ -839,7 +836,7 @@ TclAppendBytesToByteArray( irPtr = TclFetchIntRep(objPtr, &properByteArrayType); if (irPtr == NULL) { - if (TCL_ERROR == SetByteArrayFromAny(NULL, objPtr)) { + if (TCL_ERROR == SetByteArrayFromAny(NULL, TCL_INDEX_NONE, objPtr)) { Tcl_Panic("attempt to append bytes to non-bytearray"); } irPtr = TclFetchIntRep(objPtr, &properByteArrayType); diff --git a/tests/binary.test b/tests/binary.test index bb8560d..a764dd6 100644 --- a/tests/binary.test +++ b/tests/binary.test @@ -2934,6 +2934,18 @@ test binary-79.1 {Tcl_SetByteArrayLength} testsetbytearraylength { test binary-79.2 {Tcl_SetByteArrayLength} -body { testsetbytearraylength [string cat \u0141 B C] 1 } -constraints testsetbytearraylength -returnCodes error -match glob -result * +test binary-79.3 {Tcl_SetByteArrayLength} testsetbytearraylength { + testsetbytearraylength [string cat A B \u0141] 0 +} {} +test binary-79.4 {Tcl_SetByteArrayLength} testsetbytearraylength { + testsetbytearraylength [string cat A B \u0141] 1 +} A +test binary-79.5 {Tcl_SetByteArrayLength} testsetbytearraylength { + testsetbytearraylength [string cat A B \u0141] 2 +} AB +test binary-79.6 {Tcl_SetByteArrayLength} -body { + testsetbytearraylength [string cat A B \u0141] 3 +} -constraints testsetbytearraylength -returnCodes error -match glob -result * # ---------------------------------------------------------------------- -- cgit v0.12 From 450324bb3c7382853f8024d4cfe11b2c0b4595e9 Mon Sep 17 00:00:00 2001 From: dgp Date: Wed, 1 Apr 2020 21:11:49 +0000 Subject: Implement the public Tcl_GetBytesFromObj(). --- generic/tcl.decls | 6 ++++++ generic/tclBinary.c | 29 +++++++++++++++++++++++++++++ generic/tclDecls.h | 6 ++++++ generic/tclStubInit.c | 1 + 4 files changed, 42 insertions(+) diff --git a/generic/tcl.decls b/generic/tcl.decls index 0d29ba5..7337785 100644 --- a/generic/tcl.decls +++ b/generic/tcl.decls @@ -2465,6 +2465,12 @@ declare 648 { size_t length, Tcl_DString *dsPtr) } +# TIP #568 +declare 649 { + unsigned char *Tcl_GetBytesFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr, + int *lengthPtr) +} + # ----- BASELINE -- FOR -- 8.7.0 ----- # ############################################################################## diff --git a/generic/tclBinary.c b/generic/tclBinary.c index b2b75a2..7848083 100644 --- a/generic/tclBinary.c +++ b/generic/tclBinary.c @@ -453,6 +453,35 @@ TclGetBytesFromObj( } return baPtr->bytes; } + +unsigned char * +Tcl_GetBytesFromObj( + Tcl_Interp *interp, /* For error reporting */ + Tcl_Obj *objPtr, /* Value to extract from */ + int *lengthPtr) /* If non-NULL, filled with length of the + * array of bytes in the ByteArray object. */ +{ + size_t numBytes = 0; + unsigned char *bytes = TclGetBytesFromObj(interp, objPtr, &numBytes); + + if (lengthPtr) { + if (numBytes > INT_MAX) { + /* Caller asked for an int length, but true length is outside + * the int range. This case will be developed out of existence + * in Tcl 9. As interim measure, fail. */ + + if (interp) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "byte sequence length exceeds INT_MAX", -1)); + } + *lengthPtr = 0; + return NULL; + } else { + *lengthPtr = (int) numBytes; + } + } + return bytes; +} /* *---------------------------------------------------------------------- diff --git a/generic/tclDecls.h b/generic/tclDecls.h index 66ee818..6149699 100644 --- a/generic/tclDecls.h +++ b/generic/tclDecls.h @@ -1752,6 +1752,9 @@ EXTERN char * Tcl_UniCharToUtfDString(const int *uniStr, /* 648 */ EXTERN int * Tcl_UtfToUniCharDString(const char *src, size_t length, Tcl_DString *dsPtr); +/* 649 */ +EXTERN unsigned char * Tcl_GetBytesFromObj(Tcl_Interp *interp, + Tcl_Obj *objPtr, int *lengthPtr); typedef struct { const struct TclPlatStubs *tclPlatStubs; @@ -2436,6 +2439,7 @@ typedef struct TclStubs { int (*tcl_UtfToUniChar) (const char *src, int *chPtr); /* 646 */ char * (*tcl_UniCharToUtfDString) (const int *uniStr, size_t uniLength, Tcl_DString *dsPtr); /* 647 */ int * (*tcl_UtfToUniCharDString) (const char *src, size_t length, Tcl_DString *dsPtr); /* 648 */ + unsigned char * (*tcl_GetBytesFromObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, int *lengthPtr); /* 649 */ } TclStubs; extern const TclStubs *tclStubsPtr; @@ -3702,6 +3706,8 @@ extern const TclStubs *tclStubsPtr; (tclStubsPtr->tcl_UniCharToUtfDString) /* 647 */ #define Tcl_UtfToUniCharDString \ (tclStubsPtr->tcl_UtfToUniCharDString) /* 648 */ +#define Tcl_GetBytesFromObj \ + (tclStubsPtr->tcl_GetBytesFromObj) /* 649 */ #endif /* defined(USE_TCL_STUBS) */ diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c index a7c2f38..41a88b6 100644 --- a/generic/tclStubInit.c +++ b/generic/tclStubInit.c @@ -1415,6 +1415,7 @@ const TclStubs tclStubs = { Tcl_UtfToUniChar, /* 646 */ Tcl_UniCharToUtfDString, /* 647 */ Tcl_UtfToUniCharDString, /* 648 */ + Tcl_GetBytesFromObj, /* 649 */ }; /* !END!: Do not edit above this line. */ -- cgit v0.12 From 21cab9a23cb26db0e4552b1871da3fbf33ea6558 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 17 Sep 2020 14:52:02 +0000 Subject: Fix testcase binary-80.4 when TCL_UTF_MAX=3 --- generic/tclBinary.c | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/generic/tclBinary.c b/generic/tclBinary.c index 21c544b..ae34135 100644 --- a/generic/tclBinary.c +++ b/generic/tclBinary.c @@ -609,7 +609,7 @@ MakeByteArray( Tcl_Obj *objPtr, size_t limit, int demandProper, - ByteArray **byteArrayPtrPtr) + ByteArray **byteArrayPtrPtr) { size_t length; const char *src = TclGetStringFromObj(objPtr, &length); @@ -622,8 +622,8 @@ MakeByteArray( int proper = 1; for (; src < srcEnd && dst < dstEnd; ) { - Tcl_UniChar ch; - int count = TclUtfToUniChar(src, &ch); + int ch; + int count = TclUtfToUCS4(src, &ch); if (ch > 255) { proper = 0; -- cgit v0.12 From 3c0c59407f61fb9c78ced15b50d084b3670ca7b8 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 19 Oct 2020 11:29:22 +0000 Subject: Fix warning on MSVC: warning C4307: '+': integral constant overflow --- generic/tclInt.h | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/generic/tclInt.h b/generic/tclInt.h index 2e88348..c536aee 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -4851,7 +4851,7 @@ MODULE_SCOPE Tcl_PackageInitProc Procbodytest_SafeInit; (objPtr) = Tcl_NewWideIntObj(w) #define TclNewIndexObj(objPtr, w) \ - (objPtr) = Tcl_NewWideIntObj((Tcl_WideInt)((w) + 1) - 1) + (objPtr) = (w == TCL_INDEX_NONE) ? Tcl_NewWideIntObj(-1) : Tcl_NewWideIntObj(w) #define TclNewDoubleObj(objPtr, d) \ (objPtr) = Tcl_NewDoubleObj(d) -- cgit v0.12 From 8ac4aee0fc7e4d4020c874ab41fecad788d1c848 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 20 Oct 2020 10:31:34 +0000 Subject: One more attempt to fix the MSVC++ warning for Debug builds --- generic/tclInt.h | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/generic/tclInt.h b/generic/tclInt.h index c536aee..2a0dfa6 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -4816,11 +4816,12 @@ MODULE_SCOPE Tcl_PackageInitProc Procbodytest_SafeInit; #define TclNewIndexObj(objPtr, w) \ do { \ + size_t _w = (w); \ TclIncrObjsAllocated(); \ TclAllocObjStorage(objPtr); \ (objPtr)->refCount = 0; \ (objPtr)->bytes = NULL; \ - (objPtr)->internalRep.wideValue = (Tcl_WideInt)((w) + 1) - 1; \ + (objPtr)->internalRep.wideValue = ((_w) == TCL_INDEX_NONE) ? -1 : (Tcl_WideInt)(_w); \ (objPtr)->typePtr = &tclIntType; \ TCL_DTRACE_OBJ_CREATE(objPtr); \ } while (0) @@ -4851,7 +4852,7 @@ MODULE_SCOPE Tcl_PackageInitProc Procbodytest_SafeInit; (objPtr) = Tcl_NewWideIntObj(w) #define TclNewIndexObj(objPtr, w) \ - (objPtr) = (w == TCL_INDEX_NONE) ? Tcl_NewWideIntObj(-1) : Tcl_NewWideIntObj(w) + (objPtr) = ((w) == TCL_INDEX_NONE) ? Tcl_NewWideIntObj(-1) : Tcl_NewWideIntObj(w) #define TclNewDoubleObj(objPtr, d) \ (objPtr) = Tcl_NewDoubleObj(d) -- cgit v0.12 From 2a86d543545b1902bc81b6ad393d4c51fbecf402 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 21 Oct 2020 15:33:24 +0000 Subject: Finish correct implementation of stubbed TclZipfs_AppHook. Looks like complete now. --- doc/zipfs.3 | 3 ++- generic/tcl.h | 18 +++++++++--------- unix/dltest/Makefile.in | 2 +- unix/dltest/embtest.c | 35 ++++++++++++++++++++++++++++++----- 4 files changed, 42 insertions(+), 16 deletions(-) diff --git a/doc/zipfs.3 b/doc/zipfs.3 index 348557f..f810ec9 100644 --- a/doc/zipfs.3 +++ b/doc/zipfs.3 @@ -10,6 +10,7 @@ .so man.macros .BS .SH NAME +const char * TclZipfs_AppHook, Tclzipfs_Mount, TclZipfs_MountBuffer, Tclzipfs_Unmount \- handle ZIP files as Tcl virtual filesystems .SH SYNOPSIS .nf @@ -87,7 +88,7 @@ it uses WCHAR instead of char. As a result, it requires your application to be compiled with the UNICODE preprocessor symbol defined (e.g., via the \fB-DUNICODE\fR compiler flag). .PP -The result of \fBTclZipfs_AppHook\fR is a Tcl result code (e.g., \fBTCL_OK\fR +The result of \fBTclZipfs_AppHook\fR is the Tcl version string(e.g., \fB"9.0"\fR when the function is successful). The function \fImay\fR modify the variables pointed to by \fIargcPtr\fR and \fIargvPtr\fR to remove arguments; the current implementation does not do so, but callers \fIshould not\fR assume diff --git a/generic/tcl.h b/generic/tcl.h index fe73018..653fc6f 100644 --- a/generic/tcl.h +++ b/generic/tcl.h @@ -2215,22 +2215,22 @@ extern void *TclStubCall(void *arg); #define Tcl_SetPanicProc(panicProc) \ TclInitStubTable(((const char *(*)(Tcl_PanicProc *))TclStubCall((void *)panicProc))(panicProc)) #define Tcl_InitSubsystems() \ - TclInitStubTable(((const char *(*)(void))TclStubCall(INT2PTR(1)))()) + TclInitStubTable(((const char *(*)(void))TclStubCall((void *)1))()) #define Tcl_FindExecutable(argv0) \ - TclInitStubTable(((const char *(*)(const char *))TclStubCall(INT2PTR(1)))(argv0)) + TclInitStubTable(((const char *(*)(const char *))TclStubCall((void *)2))(argv0)) #if !defined(_WIN32) || !defined(UNICODE) #define Tcl_MainEx(argc, argv, appInitProc, interp) \ - ((void(*)(int, const void *, Tcl_AppInitProc *, Tcl_Interp *)) \ - TclStubCall(INT2PTR(3)))(argc, argv, appInitProc, interp) + (void)((void(*)(int, const void *, Tcl_AppInitProc *, Tcl_Interp *)) \ + TclStubCall((void *)3))(argc, argv, appInitProc, interp) #endif #define Tcl_MainExW(argc, argv, appInitProc, interp) \ - ((void(*)(int, const void *, Tcl_AppInitProc *, Tcl_Interp *)) \ - TclStubCall(INT2PTR(4)))(argc, argv, appInitProc, interp) + (void)((const char *(*)(int, const void *, Tcl_AppInitProc *, Tcl_Interp *)) \ + TclStubCall((void *)4))(argc, argv, appInitProc, interp) #define Tcl_StaticPackage(interp, pkgName, initProc, safeInitProc) \ - ((void(*)(Tcl_Interp *, const char *, Tcl_PackageInitProc *, Tcl_PackageInitProc *)) \ - TclStubCall(INT2PTR(5)))(interp, pkgName, initProc, safeInitProc) + ((const char *(*)(Tcl_Interp *, const char *, Tcl_PackageInitProc *, Tcl_PackageInitProc *)) \ + TclStubCall((void *)5))(interp, pkgName, initProc, safeInitProc) #define TclZipfs_AppHook(argcp, argvp) \ - ((const char *(*)(int *, void *))TclStubCall(INT2PTR(6)))(argcp, argvp) + TclInitStubTable(((const char *(*)(int *, void *))TclStubCall((void *)6))(argcp, argvp)) #endif /* diff --git a/unix/dltest/Makefile.in b/unix/dltest/Makefile.in index 165b859..dfee25a 100644 --- a/unix/dltest/Makefile.in +++ b/unix/dltest/Makefile.in @@ -57,7 +57,7 @@ pkgooa.o: $(SRC_DIR)/pkgooa.c $(CC) -c $(CC_SWITCHES) $(SRC_DIR)/pkgooa.c embtest: embtest.o - $(SHLIB_LD) -o $@ embtest.o ${SHLIB_LD_LIBS} -lc + $(CC) -o $@ embtest.o ${SHLIB_LD_LIBS} pkga${SHLIB_SUFFIX}: pkga.o ${SHLIB_LD} -o $@ pkga.o ${SHLIB_LD_LIBS} diff --git a/unix/dltest/embtest.c b/unix/dltest/embtest.c index c6724c3..1111268 100644 --- a/unix/dltest/embtest.c +++ b/unix/dltest/embtest.c @@ -1,11 +1,36 @@ #include "tcl.h" #include -int main() { - const char *version = Tcl_SetPanicProc(Tcl_ConsolePanic); +MODULE_SCOPE const TclStubs *tclStubsPtr; - if (version != NULL) { - printf("OK. version = %s\n", version); +int main(int argc, char **argv) { + const char *version; + int exitcode = 0; + + if (tclStubsPtr != NULL) { + printf("ERROR: stub table is already initialized"); + exitcode = 1; + } + tclStubsPtr = NULL; + version = Tcl_SetPanicProc(Tcl_ConsolePanic); + if (tclStubsPtr == NULL) { + printf("ERROR: Tcl_SetPanicProc does not initialize the stub table\n"); + exitcode = 1; + } + tclStubsPtr = NULL; + version = Tcl_InitSubsystems(); + if (tclStubsPtr == NULL) { + printf("ERROR: Tcl_InitSubsystems does not initialize the stub table\n"); + exitcode = 1; + } + tclStubsPtr = NULL; + version = Tcl_FindExecutable(argv[0]); + if (tclStubsPtr == NULL) { + printf("ERROR: Tcl_FindExecutable does not initialize the stub table\n"); + exitcode = 1; + } + if (!exitcode) { + printf("All OK!\n"); } - return 0; + return exitcode; } -- cgit v0.12 From b64263906d5ccdfc8d2eb75c1bccec3aacb898fa Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 23 Oct 2020 15:44:08 +0000 Subject: Add 2 more supported funtions to TclStubCall() --- compat/zlib/win32/zlib1.dll | Bin compat/zlib/win64/zlib1.dll | Bin doc/zipfs.3 | 3 +-- generic/tcl.h | 18 +++++++++++------- generic/tclStubCall.c | 30 ++++++++++++++++++++---------- 5 files changed, 32 insertions(+), 19 deletions(-) mode change 100644 => 100755 compat/zlib/win32/zlib1.dll mode change 100644 => 100755 compat/zlib/win64/zlib1.dll diff --git a/compat/zlib/win32/zlib1.dll b/compat/zlib/win32/zlib1.dll old mode 100644 new mode 100755 diff --git a/compat/zlib/win64/zlib1.dll b/compat/zlib/win64/zlib1.dll old mode 100644 new mode 100755 diff --git a/doc/zipfs.3 b/doc/zipfs.3 index f810ec9..f1efc65 100644 --- a/doc/zipfs.3 +++ b/doc/zipfs.3 @@ -10,11 +10,10 @@ .so man.macros .BS .SH NAME -const char * TclZipfs_AppHook, Tclzipfs_Mount, TclZipfs_MountBuffer, Tclzipfs_Unmount \- handle ZIP files as Tcl virtual filesystems .SH SYNOPSIS .nf -int +const char * \fBTclZipfs_AppHook(\fIargcPtr, argvPtr\fR) .sp int diff --git a/generic/tcl.h b/generic/tcl.h index 1d6dad0..0c75a4e 100644 --- a/generic/tcl.h +++ b/generic/tcl.h @@ -2218,19 +2218,23 @@ extern void *TclStubCall(void *arg); TclInitStubTable(((const char *(*)(void))TclStubCall((void *)1))()) #define Tcl_FindExecutable(argv0) \ TclInitStubTable(((const char *(*)(const char *))TclStubCall((void *)2))(argv0)) +#define TclZipfs_AppHook(argcp, argvp) \ + TclInitStubTable(((const char *(*)(int *, void *))TclStubCall((void *)3))(argcp, argvp)) +#define Tcl_MainExW(argc, argv, appInitProc, interp) \ + (void)((const char *(*)(int, const void *, Tcl_AppInitProc *, Tcl_Interp *)) \ + TclStubCall((void *)4))(argc, argv, appInitProc, interp) #if !defined(_WIN32) || !defined(UNICODE) #define Tcl_MainEx(argc, argv, appInitProc, interp) \ (void)((const char *(*)(int, const void *, Tcl_AppInitProc *, Tcl_Interp *)) \ - TclStubCall((void *)3))(argc, argv, appInitProc, interp) + TclStubCall((void *)5))(argc, argv, appInitProc, interp) #endif -#define Tcl_MainExW(argc, argv, appInitProc, interp) \ - (void)((const char *(*)(int, const void *, Tcl_AppInitProc *, Tcl_Interp *)) \ - TclStubCall((void *)4))(argc, argv, appInitProc, interp) #define Tcl_StaticPackage(interp, pkgName, initProc, safeInitProc) \ (void)((const char *(*)(Tcl_Interp *, const char *, Tcl_PackageInitProc *, Tcl_PackageInitProc *)) \ - TclStubCall((void *)5))(interp, pkgName, initProc, safeInitProc) -#define TclZipfs_AppHook(argcp, argvp) \ - TclInitStubTable(((const char *(*)(int *, void *))TclStubCall((void *)6))(argcp, argvp)) + TclStubCall((void *)6))(interp, pkgName, initProc, safeInitProc) +#define Tcl_SetExitProc(proc) \ + ((Tcl_ExitProc *(*)(Tcl_ExitProc *))TclStubCall((void *)7))(proc) +#define Tcl_GetMemoryInfo(dsPtr) \ + (void)((const char *(*)(Tcl_DString *))TclStubCall((void *)8))(dsPtr) #endif /* diff --git a/generic/tclStubCall.c b/generic/tclStubCall.c index da8d47a..0036e3a 100644 --- a/generic/tclStubCall.c +++ b/generic/tclStubCall.c @@ -21,22 +21,32 @@ MODULE_SCOPE void *tclStubsHandle; * * TclStubCall -- * - * Load the Tcl core dynamically, version "9.0" (or higher, in future versions) + * Load the Tcl core dynamically, version "9.0" (or higher, in future versions). * * Results: - * Outputs a function returning the value of the "version" argument or NULL. + * Returns a function from the Tcl dynamic library or a function + * returning NULL if that function cannot be found. See PROCNAME table. + * + * The functions Tcl_MainEx and Tcl_MainExW never return. + * Tcl_GetMemoryInfo and Tcl_StaticPackage return (void) and + * Tcl_SetExitProc returns its previous exitProc. This means that + * those 5 functions cannot be used to initialize the stub-table, + * only the first 4 functions in the table can do that. * *---------------------------------------------------------------------- */ +/* Table containing which function will be returned, depending on the "arg" */ static const char PROCNAME[][24] = { - "_Tcl_SetPanicProc", - "_Tcl_InitSubsystems", - "_Tcl_FindExecutable", - "_Tcl_MainEx", - "_Tcl_MainExW", - "_Tcl_StaticPackage", - "_TclZipfs_AppHook" + "_Tcl_SetPanicProc", /* Default, whenever "arg" <= 0 or "arg" > 8 */ + "_Tcl_InitSubsystems", /* "arg" == (void *)1 */ + "_Tcl_FindExecutable", /* "arg" == (void *)2 */ + "_TclZipfs_AppHook", /* "arg" == (void *)3 */ + "_Tcl_MainExW", /* "arg" == (void *)4 */ + "_Tcl_MainEx", /* "arg" == (void *)5 */ + "_Tcl_StaticPackage", /* "arg" == (void *)6 */ + "_Tcl_SetExitProc", /* "arg" == (void *)7 */ + "_Tcl_GetMemoryInfo" /* "arg" == (void *)8 */ }; MODULE_SCOPE const void *nullVersionProc(void) { @@ -52,7 +62,7 @@ TclStubCall(void *arg) static void *stubFn[] = {NULL,NULL,NULL,NULL,NULL,NULL,NULL}; unsigned index = PTR2UINT(arg); - if (index > 6) { + if (index > sizeof(PROCNAME)/sizeof(PROCNAME[0])) { /* Any other value means Tcl_SetPanicProc() with non-null panicProc */ index = 0; } -- cgit v0.12 From 9bf0f01d3d518909dba4fddd22b5eefdad229a83 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Sun, 25 Oct 2020 19:27:54 +0000 Subject: Fix (g++) Travis build --- generic/tclStubCall.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/generic/tclStubCall.c b/generic/tclStubCall.c index 42111a9..8fe7892 100644 --- a/generic/tclStubCall.c +++ b/generic/tclStubCall.c @@ -90,7 +90,7 @@ TclStubCall(void *arg) if (!stubFn[index]) { stubFn[index] = dlsym(tclStubsHandle, PROCNAME[index]); if (!stubFn[index]) { - stubFn[index] = nullVersionProc; + stubFn[index] = (void *)nullVersionProc; } } } -- cgit v0.12 -- cgit v0.12 From 9d4d81102579f655e9220ef0f705bb2a058d6ce3 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 9 Nov 2020 16:12:37 +0000 Subject: Possible solution for [ea39ab591e], making simply everything case-insensitive. TODO: TIP, documentation, code cleanup --- generic/tclLoad.c | 27 +++++++++++++++------------ 1 file changed, 15 insertions(+), 12 deletions(-) diff --git a/generic/tclLoad.c b/generic/tclLoad.c index 5090493..36c7457 100644 --- a/generic/tclLoad.c +++ b/generic/tclLoad.c @@ -226,8 +226,6 @@ Tcl_LoadObjCmd( Tcl_DStringAppend(&pkgName, packageName, -1); TclDStringClear(&tmp); Tcl_DStringAppend(&tmp, pkgPtr->packageName, -1); - Tcl_UtfToLower(Tcl_DStringValue(&pkgName)); - Tcl_UtfToLower(Tcl_DStringValue(&tmp)); if (strcmp(Tcl_DStringValue(&tmp), Tcl_DStringValue(&pkgName)) == 0) { namesMatch = 1; @@ -321,6 +319,12 @@ Tcl_LoadObjCmd( splitPtr = Tcl_FSSplitPath(objv[1], &pElements); Tcl_ListObjIndex(NULL, splitPtr, pElements -1, &pkgGuessPtr); pkgGuess = TclGetString(pkgGuessPtr); +#if defined(_WIN32) || defined(__CYGWIN__) + if ((pkgGuess[0] == 'w') && (pkgGuess[1] == 'i') + && (pkgGuess[2] == 'n')) { + pkgGuess += 3; + } else +#endif /* __CYGWIN__ */ if ((pkgGuess[0] == 'l') && (pkgGuess[1] == 'i') && (pkgGuess[2] == 'b')) { pkgGuess += 3; @@ -351,16 +355,17 @@ Tcl_LoadObjCmd( } Tcl_DStringAppend(&pkgName, pkgGuess, p - pkgGuess); Tcl_DecrRefCount(splitPtr); - } - /* - * Fix the capitalization in the package name so that the first - * character is in caps (or title case) but the others are all - * lower-case. - */ + /* + * Fix the capitalization in the package name so that the first + * character is in caps (or title case) but the others are all + * lower-case. + */ - Tcl_DStringSetLength(&pkgName, - Tcl_UtfToTitle(Tcl_DStringValue(&pkgName))); + Tcl_DStringSetLength(&pkgName, + Tcl_UtfToTitle(Tcl_DStringValue(&pkgName))); + + } /* * Compute the names of the two initialization functions, based on the @@ -656,8 +661,6 @@ Tcl_UnloadObjCmd( Tcl_DStringAppend(&pkgName, packageName, -1); TclDStringClear(&tmp); Tcl_DStringAppend(&tmp, pkgPtr->packageName, -1); - Tcl_UtfToLower(Tcl_DStringValue(&pkgName)); - Tcl_UtfToLower(Tcl_DStringValue(&tmp)); if (strcmp(Tcl_DStringValue(&tmp), Tcl_DStringValue(&pkgName)) == 0) { namesMatch = 1; -- cgit v0.12 From 062875b88e20fd9dea45ddd120f20df6a307ba3e Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 10 Nov 2020 14:51:44 +0000 Subject: Merge 9.0. Code/documentation cleanup --- .travis.yml | 2 +- doc/PkgRequire.3 | 2 +- doc/StaticLibrary.3 | 73 ++++++++ doc/StaticPkg.3 | 73 -------- doc/load.n | 75 ++++---- generic/tcl.decls | 4 +- generic/tcl.h | 3 +- generic/tclCmdIL.c | 2 +- generic/tclInt.decls | 2 +- generic/tclInt.h | 2 +- generic/tclIntDecls.h | 16 +- generic/tclLoad.c | 354 +++++++++++++++++------------------ generic/tclStubInit.c | 6 +- generic/tclTest.c | 16 +- macosx/Tcl.xcode/project.pbxproj | 4 +- macosx/Tcl.xcodeproj/project.pbxproj | 4 +- tests/load.test | 98 +++++----- tests/safe.test | 2 +- tests/unload.test | 22 +-- unix/tclAppInit.c | 2 +- win/tcl.dsp | 2 +- win/tclAppInit.c | 6 +- 22 files changed, 381 insertions(+), 389 deletions(-) create mode 100644 doc/StaticLibrary.3 delete mode 100644 doc/StaticPkg.3 diff --git a/.travis.yml b/.travis.yml index a7c1d2f..5c5ae80 100644 --- a/.travis.yml +++ b/.travis.yml @@ -243,7 +243,7 @@ jobs: 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 - - name: "Windows/MSVC/StaticPackage" + - name: "Windows/MSVC/StaticPkg" os: windows compiler: cl env: *vcenv diff --git a/doc/PkgRequire.3 b/doc/PkgRequire.3 index 71f3acf..f32c936 100644 --- a/doc/PkgRequire.3 +++ b/doc/PkgRequire.3 @@ -94,4 +94,4 @@ compatibility and translate their invocations to this form. .SH KEYWORDS package, present, provide, require, version .SH "SEE ALSO" -package(n), Tcl_StaticPackage(3) +package(n), Tcl_StaticLibrary(3) diff --git a/doc/StaticLibrary.3 b/doc/StaticLibrary.3 new file mode 100644 index 0000000..ecd064c --- /dev/null +++ b/doc/StaticLibrary.3 @@ -0,0 +1,73 @@ +'\" +'\" Copyright (c) 1995-1996 Sun Microsystems, Inc. +'\" +'\" See the file "license.terms" for information on usage and redistribution +'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. +'\" +.TH Tcl_StaticLibrary 3 7.5 Tcl "Tcl Library Procedures" +.so man.macros +.BS +.SH NAME +Tcl_StaticLibrary \- make a statically linked package available via the 'load' command +.SH SYNOPSIS +.nf +\fB#include \fR +.sp +\fBTcl_StaticLibrary\fR(\fIinterp, pkgName, initProc, safeInitProc\fR) +.SH ARGUMENTS +.AS Tcl_PackageInitProc *safeInitProc +.AP Tcl_Interp *interp in +If not NULL, points to an interpreter into which the package has +already been loaded (i.e., the caller has already invoked the +appropriate initialization procedure). NULL means the package +has not yet been incorporated into any interpreter. +.AP "const char" *pkgName in +Name of the package; should be properly capitalized (first letter +upper-case, all others lower-case). +.AP Tcl_PackageInitProc *initProc in +Procedure to invoke to incorporate this package into a trusted +interpreter. +.AP Tcl_PackageInitProc *safeInitProc in +Procedure to call to incorporate this package into a safe interpreter +(one that will execute untrusted scripts). NULL means the package +cannot be used in safe interpreters. +.BE +.SH DESCRIPTION +.PP +This procedure may be invoked to announce that a package has been +linked statically with a Tcl application and, optionally, that it +has already been loaded into an interpreter. +Once \fBTcl_StaticLibrary\fR has been invoked for a package, it +may be loaded into interpreters using the \fBload\fR command. +\fBTcl_StaticLibrary\fR is normally invoked only by the \fBTcl_AppInit\fR +procedure for the application, not by packages for themselves +(\fBTcl_StaticLibrary\fR should only be invoked for statically +loaded packages, and code in the package itself should not need +to know whether the package is dynamically or statically loaded). +.PP +When the \fBload\fR command is used later to load the package into +an interpreter, one of \fIinitProc\fR and \fIsafeInitProc\fR will +be invoked, depending on whether the target interpreter is safe +or not. +\fIinitProc\fR and \fIsafeInitProc\fR must both match the +following prototype: +.PP +.CS +typedef int \fBTcl_PackageInitProc\fR( + Tcl_Interp *\fIinterp\fR); +.CE +.PP +The \fIinterp\fR argument identifies the interpreter in which the package +is to be loaded. The initialization procedure must return \fBTCL_OK\fR or +\fBTCL_ERROR\fR to indicate whether or not it completed successfully; in +the event of an error it should set the interpreter's result to point to an +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 +\fBTcl_StaticLibrary\fR can not be safely used by stub-enabled extensions, +so its symbol is not included in the stub table. +.SH KEYWORDS +initialization procedure, package, static linking +.SH "SEE ALSO" +load(n), package(n), Tcl_PkgRequire(3) diff --git a/doc/StaticPkg.3 b/doc/StaticPkg.3 deleted file mode 100644 index a28652e..0000000 --- a/doc/StaticPkg.3 +++ /dev/null @@ -1,73 +0,0 @@ -'\" -'\" Copyright (c) 1995-1996 Sun Microsystems, Inc. -'\" -'\" See the file "license.terms" for information on usage and redistribution -'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. -'\" -.TH Tcl_StaticPackage 3 7.5 Tcl "Tcl Library Procedures" -.so man.macros -.BS -.SH NAME -Tcl_StaticPackage \- make a statically linked package available via the 'load' command -.SH SYNOPSIS -.nf -\fB#include \fR -.sp -\fBTcl_StaticPackage\fR(\fIinterp, pkgName, initProc, safeInitProc\fR) -.SH ARGUMENTS -.AS Tcl_PackageInitProc *safeInitProc -.AP Tcl_Interp *interp in -If not NULL, points to an interpreter into which the package has -already been loaded (i.e., the caller has already invoked the -appropriate initialization procedure). NULL means the package -has not yet been incorporated into any interpreter. -.AP "const char" *pkgName in -Name of the package; should be properly capitalized (first letter -upper-case, all others lower-case). -.AP Tcl_PackageInitProc *initProc in -Procedure to invoke to incorporate this package into a trusted -interpreter. -.AP Tcl_PackageInitProc *safeInitProc in -Procedure to call to incorporate this package into a safe interpreter -(one that will execute untrusted scripts). NULL means the package -cannot be used in safe interpreters. -.BE -.SH DESCRIPTION -.PP -This procedure may be invoked to announce that a package has been -linked statically with a Tcl application and, optionally, that it -has already been loaded into an interpreter. -Once \fBTcl_StaticPackage\fR has been invoked for a package, it -may be loaded into interpreters using the \fBload\fR command. -\fBTcl_StaticPackage\fR is normally invoked only by the \fBTcl_AppInit\fR -procedure for the application, not by packages for themselves -(\fBTcl_StaticPackage\fR should only be invoked for statically -loaded packages, and code in the package itself should not need -to know whether the package is dynamically or statically loaded). -.PP -When the \fBload\fR command is used later to load the package into -an interpreter, one of \fIinitProc\fR and \fIsafeInitProc\fR will -be invoked, depending on whether the target interpreter is safe -or not. -\fIinitProc\fR and \fIsafeInitProc\fR must both match the -following prototype: -.PP -.CS -typedef int \fBTcl_PackageInitProc\fR( - Tcl_Interp *\fIinterp\fR); -.CE -.PP -The \fIinterp\fR argument identifies the interpreter in which the package -is to be loaded. The initialization procedure must return \fBTCL_OK\fR or -\fBTCL_ERROR\fR to indicate whether or not it completed successfully; in -the event of an error it should set the interpreter's result to point to an -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 -\fBTcl_StaticPackage\fR can not be safely used by stub-enabled extensions, -so its symbol is not included in the stub table. -.SH KEYWORDS -initialization procedure, package, static linking -.SH "SEE ALSO" -load(n), package(n), Tcl_PkgRequire(3) diff --git a/doc/load.n b/doc/load.n index 03b4f4e..b8a26ae 100644 --- a/doc/load.n +++ b/doc/load.n @@ -13,22 +13,21 @@ load \- Load machine code and initialize new commands .SH SYNOPSIS \fBload\fR ?\fB\-global\fR? ?\fB\-lazy\fR? ?\fB\-\-\fR? \fIfileName\fR .br -\fBload\fR ?\fB\-global\fR? ?\fB\-lazy\fR? ?\fB\-\-\fR? \fIfileName packageName\fR +\fBload\fR ?\fB\-global\fR? ?\fB\-lazy\fR? ?\fB\-\-\fR? \fIfileName prefix\fR .br -\fBload\fR ?\fB\-global\fR? ?\fB\-lazy\fR? ?\fB\-\-\fR? \fIfileName packageName interp\fR +\fBload\fR ?\fB\-global\fR? ?\fB\-lazy\fR? ?\fB\-\-\fR? \fIfileName prefix interp\fR .BE .SH DESCRIPTION .PP This command loads binary code from a file into the application's address space and calls an initialization procedure -in the package to incorporate it into an interpreter. \fIfileName\fR +in the library to incorporate it into an interpreter. \fIfileName\fR is the name of the file containing the code; its exact form varies from system to system but on most systems it is a shared library, such as a \fB.so\fR file under Solaris or a DLL under Windows. -\fIpackageName\fR is the name of the package, and is used to -compute the name of an initialization procedure. +\fIprefix\fR is used to compute the name of an initialization procedure. \fIinterp\fR is the path name of the interpreter into which to load -the package (see the \fBinterp\fR manual entry for details); +the library (see the \fBinterp\fR manual entry for details); if \fIinterp\fR is omitted, it defaults to the interpreter in which the \fBload\fR command was invoked. .PP @@ -37,21 +36,19 @@ one of two initialization procedures will be invoked in the new code. Typically the initialization procedure will add new commands to a Tcl interpreter. The name of the initialization procedure is determined by -\fIpackageName\fR and whether or not the target interpreter +\fIprefix\fR and whether or not the target interpreter is a safe one. For normal interpreters the name of the initialization -procedure will have the form \fIpkg\fB_Init\fR, where \fIpkg\fR -is the same as \fIpackageName\fR except that the first letter is -converted to upper case and all other letters -are converted to lower case. For example, if \fIpackageName\fR is -\fBfoo\fR or \fBFOo\fR, the initialization procedure's name will +procedure will have the form \fIprefix\fB_Init\fR, where \fIprefix\fR +is the same as \fIprefix\fR. For example, if \fIprefix\fR is +\fBFoo\fR, the initialization procedure's name will be \fBFoo_Init\fR. .PP If the target interpreter is a safe interpreter, then the name -of the initialization procedure will be \fIpkg\fB_SafeInit\fR -instead of \fIpkg\fB_Init\fR. -The \fIpkg\fB_SafeInit\fR function should be written carefully, so that it +of the initialization procedure will be \fIprefix\fB_SafeInit\fR +instead of \fIprefix\fB_Init\fR. +The \fIprefix\fB_SafeInit\fR function should be written carefully, so that it initializes the safe interpreter only with partial functionality provided -by the package that is safe for use by untrusted code. For more information +by the library that is safe for use by untrusted code. For more information on Safe\-Tcl, see the \fBsafe\fR manual entry. .PP The initialization procedure must match the following prototype: @@ -62,7 +59,7 @@ typedef int \fBTcl_PackageInitProc\fR( .CE .PP The \fIinterp\fR argument identifies the interpreter in which the -package is to be loaded. The initialization procedure must return +library is to be loaded. The initialization procedure must return \fBTCL_OK\fR or \fBTCL_ERROR\fR to indicate whether or not it completed successfully; in the event of an error it should set the interpreter's result to point to an error message. The result of the \fBload\fR command @@ -74,36 +71,34 @@ interpreters, then the first \fBload\fR will load the code and call the initialization procedure; subsequent \fBload\fRs will call the initialization procedure without loading the code again. For Tcl versions lower than 8.5, it is not possible to unload or reload a -package. From version 8.5 however, the \fBunload\fR command allows the unloading +library. From version 8.5 however, the \fBunload\fR command allows the unloading of libraries loaded with \fBload\fR, for libraries that are aware of the Tcl's unloading mechanism. .PP -The \fBload\fR command also supports packages that are statically -linked with the application, if those packages have been registered -by calling the \fBTcl_StaticPackage\fR procedure. -If \fIfileName\fR is an empty string, then \fIpackageName\fR must +The \fBload\fR command also supports libraries that are statically +linked with the application, if those libraries have been registered +by calling the \fBTcl_StaticLibrary\fR procedure. +If \fIfileName\fR is an empty string, then \fIprefix\fR must be specified. .PP -If \fIpackageName\fR is omitted or specified as an empty string, -Tcl tries to guess the name of the package. -This may be done differently on different platforms. -The default guess, which is used on most UNIX platforms, is to -take the last element of \fIfileName\fR, strip off the first -three characters if they are \fBlib\fR, and use any following -alphabetic and underline characters as the module name. -For example, the command \fBload libxyz4.2.so\fR uses the module -name \fBxyz\fR and the command \fBload bin/last.so {}\fR uses the -module name \fBlast\fR. -.PP -If \fIfileName\fR is an empty string, then \fIpackageName\fR must +If \fIprefix\fR is omitted or specified as an empty string, +Tcl tries to guess the prefix by taking the last element of +\fIfileName\fR, strip off the first three characters if they +are \fBlib\fR, and use any following alphabetic and underline +characters, converted to titlecase as the prefix. +For example, the command \fBload libxyz4.2.so\fR uses the prefix +\fBxyz\fR and the command \fBload bin/last.so {}\fR uses the +prefix \fBlast\fR. +.PP +If \fIfileName\fR is an empty string, then \fIprefix\fR must be specified. -The \fBload\fR command first searches for a statically loaded package -(one that has been registered by calling the \fBTcl_StaticPackage\fR +The \fBload\fR command first searches for a statically loaded library +(one that has been registered by calling the \fBTcl_StaticLibrary\fR procedure) by that name; if one is found, it is used. Otherwise, the \fBload\fR command searches for a dynamically loaded -package by that name, and uses it if it is found. If several +library by that name, and uses it if it is found. If several different files have been \fBload\fRed with different versions of -the package, Tcl picks the file that was loaded first. +the library, Tcl picks the file that was loaded first. .PP If \fB\-global\fR is specified preceding the filename, all symbols found in the shared library are exported for global use by other @@ -111,7 +106,7 @@ libraries. The option \fB\-lazy\fR delays the actual loading of symbols until their first actual use. The options may be abbreviated. The option \fB\-\-\fR indicates the end of the options, and should be used if you wish to use a filename which starts with \fB\-\fR -and you provide a packageName to the \fBload\fR command. +and you provide a prefix to the \fBload\fR command. .PP On platforms which do not support the \fB\-global\fR or \fB\-lazy\fR options, the options still exist but have no effect. Note that use @@ -188,7 +183,7 @@ switch $tcl_platform(platform) { foo .CE .SH "SEE ALSO" -info sharedlibextension, package(n), Tcl_StaticPackage(3), safe(n) +info sharedlibextension, package(n), Tcl_StaticLibrary(3), safe(n) .SH KEYWORDS binary code, dynamic library, load, safe interpreter, shared library '\"Local Variables: diff --git a/generic/tcl.decls b/generic/tcl.decls index 4a58a20..ff97dfc 100644 --- a/generic/tcl.decls +++ b/generic/tcl.decls @@ -888,7 +888,7 @@ declare 243 { } # Removed in 9.0 (stub entry only) #declare 244 { -# void Tcl_StaticPackage(Tcl_Interp *interp, const char *pkgName, +# void Tcl_StaticLibrary(Tcl_Interp *interp, const char *prefix, # Tcl_PackageInitProc *initProc, Tcl_PackageInitProc *safeInitProc) #} # Removed in 9.0 (stub entry only) @@ -2514,7 +2514,7 @@ export { Tcl_Interp *interp) } export { - void Tcl_StaticPackage(Tcl_Interp *interp, const char *pkgName, + void Tcl_StaticLibrary(Tcl_Interp *interp, const char *prefix, Tcl_PackageInitProc *initProc, Tcl_PackageInitProc *safeInitProc) } export { diff --git a/generic/tcl.h b/generic/tcl.h index eb6d2fe..a87c5d4 100644 --- a/generic/tcl.h +++ b/generic/tcl.h @@ -2189,10 +2189,11 @@ EXTERN void Tcl_GetMemoryInfo(Tcl_DString *dsPtr); EXTERN void Tcl_FindExecutable(const char *argv0); EXTERN void Tcl_SetPanicProc( TCL_NORETURN1 Tcl_PanicProc *panicProc); -EXTERN void Tcl_StaticPackage(Tcl_Interp *interp, +EXTERN void Tcl_StaticLibrary(Tcl_Interp *interp, const char *pkgName, Tcl_PackageInitProc *initProc, Tcl_PackageInitProc *safeInitProc); +#define Tcl_StaticPackage Tcl_StaticLibrary EXTERN Tcl_ExitProc *Tcl_SetExitProc(TCL_NORETURN1 Tcl_ExitProc *proc); #ifdef _WIN32 EXTERN int TclZipfs_AppHook(int *argc, wchar_t ***argv); diff --git a/generic/tclCmdIL.c b/generic/tclCmdIL.c index 5a8ef22..4536d18 100644 --- a/generic/tclCmdIL.c +++ b/generic/tclCmdIL.c @@ -1699,7 +1699,7 @@ InfoLoadedCmd( } else { /* Get pkgs just in specified interp. */ packageName = TclGetString(objv[2]); } - return TclGetLoadedPackagesEx(interp, interpName, packageName); + return TclGetLoadedLibraries(interp, interpName, packageName); } /* diff --git a/generic/tclInt.decls b/generic/tclInt.decls index 5b02fb4..e764bc4 100644 --- a/generic/tclInt.decls +++ b/generic/tclInt.decls @@ -1058,7 +1058,7 @@ declare 256 { Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, const int flags) } declare 257 { - void TclStaticPackage(Tcl_Interp *interp, const char *pkgName, + void TclStaticLibrary(Tcl_Interp *interp, const char *prefix, Tcl_PackageInitProc *initProc, Tcl_PackageInitProc *safeInitProc) } diff --git a/generic/tclInt.h b/generic/tclInt.h index 2a0dfa6..cd0f148 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -2975,7 +2975,7 @@ MODULE_SCOPE Tcl_Obj * TclGetSourceFromFrame(CmdFrame *cfPtr, int objc, Tcl_Obj *const objv[]); MODULE_SCOPE char * TclGetStringStorage(Tcl_Obj *objPtr, size_t *sizePtr); -MODULE_SCOPE int TclGetLoadedPackagesEx(Tcl_Interp *interp, +MODULE_SCOPE int TclGetLoadedLibraries(Tcl_Interp *interp, const char *targetName, const char *packageName); MODULE_SCOPE int TclGetWideBitsFromObj(Tcl_Interp *, Tcl_Obj *, diff --git a/generic/tclIntDecls.h b/generic/tclIntDecls.h index e870aac..cf8d660 100644 --- a/generic/tclIntDecls.h +++ b/generic/tclIntDecls.h @@ -570,8 +570,8 @@ EXTERN int TclPtrUnsetVar(Tcl_Interp *interp, Tcl_Var varPtr, Tcl_Var arrayPtr, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, const int flags); /* 257 */ -EXTERN void TclStaticPackage(Tcl_Interp *interp, - const char *pkgName, +EXTERN void TclStaticLibrary(Tcl_Interp *interp, + const char *prefix, Tcl_PackageInitProc *initProc, Tcl_PackageInitProc *safeInitProc); /* 258 */ @@ -845,7 +845,7 @@ typedef struct TclIntStubs { Tcl_Obj * (*tclPtrIncrObjVar) (Tcl_Interp *interp, Tcl_Var varPtr, Tcl_Var arrayPtr, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, Tcl_Obj *incrPtr, const int flags); /* 254 */ int (*tclPtrObjMakeUpvar) (Tcl_Interp *interp, Tcl_Var otherPtr, Tcl_Obj *myNamePtr, int myFlags); /* 255 */ int (*tclPtrUnsetVar) (Tcl_Interp *interp, Tcl_Var varPtr, Tcl_Var arrayPtr, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, const int flags); /* 256 */ - void (*tclStaticPackage) (Tcl_Interp *interp, const char *pkgName, Tcl_PackageInitProc *initProc, Tcl_PackageInitProc *safeInitProc); /* 257 */ + void (*tclStaticLibrary) (Tcl_Interp *interp, const char *prefix, Tcl_PackageInitProc *initProc, Tcl_PackageInitProc *safeInitProc); /* 257 */ Tcl_Obj * (*tclpCreateTemporaryDirectory) (Tcl_Obj *dirObj, Tcl_Obj *basenameObj); /* 258 */ void (*tclAppendUnicodeToObj) (Tcl_Obj *objPtr, const Tcl_UniChar *unicode, size_t length); /* 259 */ unsigned char * (*tclGetBytesFromObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, size_t *lengthPtr); /* 260 */ @@ -1260,8 +1260,8 @@ extern const TclIntStubs *tclIntStubsPtr; (tclIntStubsPtr->tclPtrObjMakeUpvar) /* 255 */ #define TclPtrUnsetVar \ (tclIntStubsPtr->tclPtrUnsetVar) /* 256 */ -#define TclStaticPackage \ - (tclIntStubsPtr->tclStaticPackage) /* 257 */ +#define TclStaticLibrary \ + (tclIntStubsPtr->tclStaticLibrary) /* 257 */ #define TclpCreateTemporaryDirectory \ (tclIntStubsPtr->tclpCreateTemporaryDirectory) /* 258 */ #define TclAppendUnicodeToObj \ @@ -1274,9 +1274,9 @@ extern const TclIntStubs *tclIntStubsPtr; /* !END!: Do not edit above this line. */ #if defined(USE_TCL_STUBS) -#undef Tcl_StaticPackage -#define Tcl_StaticPackage \ - (tclIntStubsPtr->tclStaticPackage) +#undef Tcl_StaticLibrary +#define Tcl_StaticLibrary \ + (tclIntStubsPtr->tclStaticLibrary) #endif /* defined(USE_TCL_STUBS) */ #undef TCL_STORAGE_CLASS diff --git a/generic/tclLoad.c b/generic/tclLoad.c index 36c7457..67bc2cc 100644 --- a/generic/tclLoad.c +++ b/generic/tclLoad.c @@ -15,19 +15,17 @@ /* * The following structure describes a package that has been loaded either * dynamically (with the "load" command) or statically (as indicated by a call - * to TclGetLoadedPackages). All such packages are linked together into a + * to TclGetLoadedLibraries). All such packages are linked together into a * single list for the process. Packages are never unloaded, until the * application exits, when TclFinalizeLoad is called, and these structures are * freed. */ -typedef struct LoadedPackage { +typedef struct LoadedLibrary { char *fileName; /* Name of the file from which the package was * loaded. An empty string means the package * is loaded statically. Malloc-ed. */ - char *packageName; /* Name of package prefix for the package, - * properly capitalized (first letter UC, - * others LC), no "_", as in "Net". + char *prefix; /* Prefix for the library. * Malloc-ed. */ Tcl_LoadHandle loadHandle; /* Token for the loaded file which should be * passed to (*unLoadProcPtr)() when the file @@ -55,23 +53,23 @@ typedef struct LoadedPackage { * in trusted interpreters. */ int safeInterpRefCount; /* How many times the package has been loaded * in safe interpreters. */ - struct LoadedPackage *nextPtr; + struct LoadedLibrary *nextPtr; /* Next in list of all packages loaded into * this application process. NULL means end of * list. */ -} LoadedPackage; +} LoadedLibrary; /* * TCL_THREADS - * There is a global list of packages that is anchored at firstPackagePtr. + * There is a global list of packages that is anchored at firstLibraryPtr. * Access to this list is governed by a mutex. */ -static LoadedPackage *firstPackagePtr = NULL; +static LoadedLibrary *firstLibraryPtr = NULL; /* First in list of all packages loaded into * this process. */ -TCL_DECLARE_MUTEX(packageMutex) +TCL_DECLARE_MUTEX(libraryMutex) /* * The following structure represents a particular package that has been @@ -82,7 +80,7 @@ TCL_DECLARE_MUTEX(packageMutex) */ typedef struct InterpPackage { - LoadedPackage *pkgPtr; /* Points to detailed information about + LoadedLibrary *libraryPtr; /* Points to detailed information about * package. */ struct InterpPackage *nextPtr; /* Next package in this interpreter, or NULL @@ -121,14 +119,14 @@ Tcl_LoadObjCmd( Tcl_Obj *const objv[]) /* Argument objects. */ { Tcl_Interp *target; - LoadedPackage *pkgPtr, *defaultPtr; + LoadedLibrary *libraryPtr, *defaultPtr; Tcl_DString pkgName, tmp, initName, safeInitName; Tcl_DString unloadName, safeUnloadName; InterpPackage *ipFirstPtr, *ipPtr; int code, namesMatch, filesMatch, offset; const char *symbols[2]; Tcl_PackageInitProc *initProc; - const char *p, *fullFileName, *packageName; + const char *p, *fullFileName, *prefix; Tcl_LoadHandle loadHandle; Tcl_UniChar ch = 0; size_t len; @@ -159,7 +157,7 @@ Tcl_LoadObjCmd( } } if ((objc < 2) || (objc > 4)) { - Tcl_WrongNumArgs(interp, 1, savedobjv, "?-global? ?-lazy? ?--? fileName ?packageName? ?interp?"); + Tcl_WrongNumArgs(interp, 1, savedobjv, "?-global? ?-lazy? ?--? fileName ?prefix? ?interp?"); return TCL_ERROR; } if (Tcl_FSConvertToPathType(interp, objv[1]) != TCL_OK) { @@ -174,14 +172,14 @@ Tcl_LoadObjCmd( Tcl_DStringInit(&safeUnloadName); Tcl_DStringInit(&tmp); - packageName = NULL; + prefix = NULL; if (objc >= 3) { - packageName = TclGetString(objv[2]); - if (packageName[0] == '\0') { - packageName = NULL; + prefix = TclGetString(objv[2]); + if (prefix[0] == '\0') { + prefix = NULL; } } - if ((fullFileName[0] == 0) && (packageName == NULL)) { + if ((fullFileName[0] == 0) && (prefix == NULL)) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "must specify either file name or package name", -1)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LOAD", "NOLIBRARY", @@ -215,17 +213,17 @@ Tcl_LoadObjCmd( * only no statically loaded package with the same name. */ - Tcl_MutexLock(&packageMutex); + Tcl_MutexLock(&libraryMutex); defaultPtr = NULL; - for (pkgPtr = firstPackagePtr; pkgPtr != NULL; pkgPtr = pkgPtr->nextPtr) { - if (packageName == NULL) { + for (libraryPtr = firstLibraryPtr; libraryPtr != NULL; libraryPtr = libraryPtr->nextPtr) { + if (prefix == NULL) { namesMatch = 0; } else { TclDStringClear(&pkgName); - Tcl_DStringAppend(&pkgName, packageName, -1); + Tcl_DStringAppend(&pkgName, prefix, -1); TclDStringClear(&tmp); - Tcl_DStringAppend(&tmp, pkgPtr->packageName, -1); + Tcl_DStringAppend(&tmp, libraryPtr->prefix, -1); if (strcmp(Tcl_DStringValue(&tmp), Tcl_DStringValue(&pkgName)) == 0) { namesMatch = 1; @@ -235,12 +233,12 @@ Tcl_LoadObjCmd( } TclDStringClear(&pkgName); - filesMatch = (strcmp(pkgPtr->fileName, fullFileName) == 0); - if (filesMatch && (namesMatch || (packageName == NULL))) { + filesMatch = (strcmp(libraryPtr->fileName, fullFileName) == 0); + if (filesMatch && (namesMatch || (prefix == NULL))) { break; } if (namesMatch && (fullFileName[0] == 0)) { - defaultPtr = pkgPtr; + defaultPtr = libraryPtr; } if (filesMatch && !namesMatch && (fullFileName[0] != 0)) { /* @@ -249,17 +247,17 @@ Tcl_LoadObjCmd( Tcl_SetObjResult(interp, Tcl_ObjPrintf( "file \"%s\" is already loaded for package \"%s\"", - fullFileName, pkgPtr->packageName)); + fullFileName, libraryPtr->prefix)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LOAD", "SPLITPERSONALITY", NULL); code = TCL_ERROR; - Tcl_MutexUnlock(&packageMutex); + Tcl_MutexUnlock(&libraryMutex); goto done; } } - Tcl_MutexUnlock(&packageMutex); - if (pkgPtr == NULL) { - pkgPtr = defaultPtr; + Tcl_MutexUnlock(&libraryMutex); + if (libraryPtr == NULL) { + libraryPtr = defaultPtr; } /* @@ -268,17 +266,17 @@ Tcl_LoadObjCmd( * there's nothing for us to do. */ - if (pkgPtr != NULL) { + if (libraryPtr != NULL) { ipFirstPtr = (InterpPackage *)Tcl_GetAssocData(target, "tclLoad", NULL); for (ipPtr = ipFirstPtr; ipPtr != NULL; ipPtr = ipPtr->nextPtr) { - if (ipPtr->pkgPtr == pkgPtr) { + if (ipPtr->libraryPtr == libraryPtr) { code = TCL_OK; goto done; } } } - if (pkgPtr == NULL) { + if (libraryPtr == NULL) { /* * The desired file isn't currently loaded, so load it. It's an error * if the desired package is a static one. @@ -286,7 +284,7 @@ Tcl_LoadObjCmd( if (fullFileName[0] == 0) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "package \"%s\" isn't loaded statically", packageName)); + "no library with prefix \"%s\" is loaded statically", prefix)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LOAD", "NOTSTATIC", NULL); code = TCL_ERROR; @@ -297,8 +295,8 @@ Tcl_LoadObjCmd( * Figure out the module name if it wasn't provided explicitly. */ - if (packageName != NULL) { - Tcl_DStringAppend(&pkgName, packageName, -1); + if (prefix != NULL) { + Tcl_DStringAppend(&pkgName, prefix, -1); } else { Tcl_Obj *splitPtr, *pkgGuessPtr; int pElements; @@ -389,10 +387,10 @@ Tcl_LoadObjCmd( symbols[0] = Tcl_DStringValue(&initName); symbols[1] = NULL; - Tcl_MutexLock(&packageMutex); + Tcl_MutexLock(&libraryMutex); code = Tcl_LoadFile(interp, objv[1], symbols, flags, &initProc, &loadHandle); - Tcl_MutexUnlock(&packageMutex); + Tcl_MutexUnlock(&libraryMutex); if (code != TCL_OK) { goto done; } @@ -401,31 +399,31 @@ Tcl_LoadObjCmd( * Create a new record to describe this package. */ - pkgPtr = (LoadedPackage *)Tcl_Alloc(sizeof(LoadedPackage)); + libraryPtr = (LoadedLibrary *)Tcl_Alloc(sizeof(LoadedLibrary)); len = strlen(fullFileName) + 1; - pkgPtr->fileName = (char *)Tcl_Alloc(len); - memcpy(pkgPtr->fileName, fullFileName, len); + libraryPtr->fileName = (char *)Tcl_Alloc(len); + memcpy(libraryPtr->fileName, fullFileName, len); len = Tcl_DStringLength(&pkgName) + 1; - pkgPtr->packageName = (char *)Tcl_Alloc(len); - memcpy(pkgPtr->packageName, Tcl_DStringValue(&pkgName), len); - pkgPtr->loadHandle = loadHandle; - pkgPtr->initProc = initProc; - pkgPtr->safeInitProc = (Tcl_PackageInitProc *) + libraryPtr->prefix = (char *)Tcl_Alloc(len); + memcpy(libraryPtr->prefix, Tcl_DStringValue(&pkgName), len); + libraryPtr->loadHandle = loadHandle; + libraryPtr->initProc = initProc; + libraryPtr->safeInitProc = (Tcl_PackageInitProc *) Tcl_FindSymbol(interp, loadHandle, Tcl_DStringValue(&safeInitName)); - pkgPtr->unloadProc = (Tcl_PackageUnloadProc *) + libraryPtr->unloadProc = (Tcl_PackageUnloadProc *) Tcl_FindSymbol(interp, loadHandle, Tcl_DStringValue(&unloadName)); - pkgPtr->safeUnloadProc = (Tcl_PackageUnloadProc *) + libraryPtr->safeUnloadProc = (Tcl_PackageUnloadProc *) Tcl_FindSymbol(interp, loadHandle, Tcl_DStringValue(&safeUnloadName)); - pkgPtr->interpRefCount = 0; - pkgPtr->safeInterpRefCount = 0; + libraryPtr->interpRefCount = 0; + libraryPtr->safeInterpRefCount = 0; - Tcl_MutexLock(&packageMutex); - pkgPtr->nextPtr = firstPackagePtr; - firstPackagePtr = pkgPtr; - Tcl_MutexUnlock(&packageMutex); + Tcl_MutexLock(&libraryMutex); + libraryPtr->nextPtr = firstLibraryPtr; + firstLibraryPtr = libraryPtr; + Tcl_MutexUnlock(&libraryMutex); /* * The Tcl_FindSymbol calls may have left a spurious error message in @@ -441,27 +439,27 @@ Tcl_LoadObjCmd( */ if (Tcl_IsSafe(target)) { - if (pkgPtr->safeInitProc == NULL) { + if (libraryPtr->safeInitProc == NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "can't use package in a safe interpreter: no" - " %s_SafeInit procedure", pkgPtr->packageName)); + " %s_SafeInit procedure", libraryPtr->prefix)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LOAD", "UNSAFE", NULL); code = TCL_ERROR; goto done; } - code = pkgPtr->safeInitProc(target); + code = libraryPtr->safeInitProc(target); } else { - if (pkgPtr->initProc == NULL) { + if (libraryPtr->initProc == NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "can't attach package to interpreter: no %s_Init procedure", - pkgPtr->packageName)); + libraryPtr->prefix)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LOAD", "ENTRYPOINT", NULL); code = TCL_ERROR; goto done; } - code = pkgPtr->initProc(target); + code = libraryPtr->initProc(target); } /* @@ -492,13 +490,13 @@ Tcl_LoadObjCmd( * Update the proper reference count. */ - Tcl_MutexLock(&packageMutex); + Tcl_MutexLock(&libraryMutex); if (Tcl_IsSafe(target)) { - pkgPtr->safeInterpRefCount++; + libraryPtr->safeInterpRefCount++; } else { - pkgPtr->interpRefCount++; + libraryPtr->interpRefCount++; } - Tcl_MutexUnlock(&packageMutex); + Tcl_MutexUnlock(&libraryMutex); /* * Refetch ipFirstPtr: loading the package may have introduced additional @@ -507,7 +505,7 @@ Tcl_LoadObjCmd( ipFirstPtr = (InterpPackage *)Tcl_GetAssocData(target, "tclLoad", NULL); ipPtr = (InterpPackage *)Tcl_Alloc(sizeof(InterpPackage)); - ipPtr->pkgPtr = pkgPtr; + ipPtr->libraryPtr = libraryPtr; ipPtr->nextPtr = ipFirstPtr; Tcl_SetAssocData(target, "tclLoad", LoadCleanupProc, ipPtr); @@ -546,14 +544,14 @@ Tcl_UnloadObjCmd( Tcl_Obj *const objv[]) /* Argument objects. */ { Tcl_Interp *target; /* Which interpreter to unload from. */ - LoadedPackage *pkgPtr, *defaultPtr; + LoadedLibrary *libraryPtr, *defaultPtr; Tcl_DString pkgName, tmp; Tcl_PackageUnloadProc *unloadProc; InterpPackage *ipFirstPtr, *ipPtr; int i, index, code, complain = 1, keepLibrary = 0; int trustedRefCount = -1, safeRefCount = -1; const char *fullFileName = ""; - const char *packageName; + const char *prefix; static const char *const options[] = { "-nocomplain", "-keeplibrary", "--", NULL }; @@ -597,7 +595,7 @@ Tcl_UnloadObjCmd( endOfForLoop: if ((objc-i < 1) || (objc-i > 3)) { Tcl_WrongNumArgs(interp, 1, objv, - "?-switch ...? fileName ?packageName? ?interp?"); + "?-switch ...? fileName ?prefix? ?interp?"); return TCL_ERROR; } if (Tcl_FSConvertToPathType(interp, objv[i]) != TCL_OK) { @@ -608,14 +606,14 @@ Tcl_UnloadObjCmd( Tcl_DStringInit(&pkgName); Tcl_DStringInit(&tmp); - packageName = NULL; + prefix = NULL; if (objc - i >= 2) { - packageName = TclGetString(objv[i+1]); - if (packageName[0] == '\0') { - packageName = NULL; + prefix = TclGetString(objv[i+1]); + if (prefix[0] == '\0') { + prefix = NULL; } } - if ((fullFileName[0] == 0) && (packageName == NULL)) { + if ((fullFileName[0] == 0) && (prefix == NULL)) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "must specify either file name or package name", -1)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "UNLOAD", "NOLIBRARY", @@ -648,19 +646,19 @@ Tcl_UnloadObjCmd( * only no statically loaded package with the same name. */ - Tcl_MutexLock(&packageMutex); + Tcl_MutexLock(&libraryMutex); defaultPtr = NULL; - for (pkgPtr = firstPackagePtr; pkgPtr != NULL; pkgPtr = pkgPtr->nextPtr) { + for (libraryPtr = firstLibraryPtr; libraryPtr != NULL; libraryPtr = libraryPtr->nextPtr) { int namesMatch, filesMatch; - if (packageName == NULL) { + if (prefix == NULL) { namesMatch = 0; } else { TclDStringClear(&pkgName); - Tcl_DStringAppend(&pkgName, packageName, -1); + Tcl_DStringAppend(&pkgName, prefix, -1); TclDStringClear(&tmp); - Tcl_DStringAppend(&tmp, pkgPtr->packageName, -1); + Tcl_DStringAppend(&tmp, libraryPtr->prefix, -1); if (strcmp(Tcl_DStringValue(&tmp), Tcl_DStringValue(&pkgName)) == 0) { namesMatch = 1; @@ -670,32 +668,32 @@ Tcl_UnloadObjCmd( } TclDStringClear(&pkgName); - filesMatch = (strcmp(pkgPtr->fileName, fullFileName) == 0); - if (filesMatch && (namesMatch || (packageName == NULL))) { + filesMatch = (strcmp(libraryPtr->fileName, fullFileName) == 0); + if (filesMatch && (namesMatch || (prefix == NULL))) { break; } if (namesMatch && (fullFileName[0] == 0)) { - defaultPtr = pkgPtr; + defaultPtr = libraryPtr; } if (filesMatch && !namesMatch && (fullFileName[0] != 0)) { break; } } - Tcl_MutexUnlock(&packageMutex); + Tcl_MutexUnlock(&libraryMutex); if (fullFileName[0] == 0) { /* * It's an error to try unload a static package. */ Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "package \"%s\" is loaded statically and cannot be unloaded", - packageName)); + "library with prefix \"%s\" is loaded statically and cannot be unloaded", + prefix)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "UNLOAD", "STATIC", NULL); code = TCL_ERROR; goto done; } - if (pkgPtr == NULL) { + if (libraryPtr == NULL) { /* * The DLL pointed by the provided filename has never been loaded. */ @@ -715,10 +713,10 @@ Tcl_UnloadObjCmd( */ code = TCL_ERROR; - if (pkgPtr != NULL) { + if (libraryPtr != NULL) { ipFirstPtr = (InterpPackage *)Tcl_GetAssocData(target, "tclLoad", NULL); for (ipPtr = ipFirstPtr; ipPtr != NULL; ipPtr = ipPtr->nextPtr) { - if (ipPtr->pkgPtr == pkgPtr) { + if (ipPtr->libraryPtr == libraryPtr) { code = TCL_OK; break; } @@ -740,12 +738,12 @@ Tcl_UnloadObjCmd( /* * Ensure that the DLL can be unloaded. If it is a trusted interpreter, - * pkgPtr->unloadProc must not be NULL for the DLL to be unloadable. If - * the interpreter is a safe one, pkgPtr->safeUnloadProc must be non-NULL. + * libraryPtr->unloadProc must not be NULL for the DLL to be unloadable. If + * the interpreter is a safe one, libraryPtr->safeUnloadProc must be non-NULL. */ if (Tcl_IsSafe(target)) { - if (pkgPtr->safeUnloadProc == NULL) { + if (libraryPtr->safeUnloadProc == NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "file \"%s\" cannot be unloaded under a safe interpreter", fullFileName)); @@ -754,9 +752,9 @@ Tcl_UnloadObjCmd( code = TCL_ERROR; goto done; } - unloadProc = pkgPtr->safeUnloadProc; + unloadProc = libraryPtr->safeUnloadProc; } else { - if (pkgPtr->unloadProc == NULL) { + if (libraryPtr->unloadProc == NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "file \"%s\" cannot be unloaded under a trusted interpreter", fullFileName)); @@ -765,7 +763,7 @@ Tcl_UnloadObjCmd( code = TCL_ERROR; goto done; } - unloadProc = pkgPtr->unloadProc; + unloadProc = libraryPtr->unloadProc; } /* @@ -780,10 +778,10 @@ Tcl_UnloadObjCmd( code = TCL_UNLOAD_DETACH_FROM_INTERPRETER; if (!keepLibrary) { - Tcl_MutexLock(&packageMutex); - trustedRefCount = pkgPtr->interpRefCount; - safeRefCount = pkgPtr->safeInterpRefCount; - Tcl_MutexUnlock(&packageMutex); + Tcl_MutexLock(&libraryMutex); + trustedRefCount = libraryPtr->interpRefCount; + safeRefCount = libraryPtr->safeInterpRefCount; + Tcl_MutexUnlock(&libraryMutex); if (Tcl_IsSafe(target)) { safeRefCount--; @@ -806,34 +804,34 @@ Tcl_UnloadObjCmd( * if we unload the DLL. */ - Tcl_MutexLock(&packageMutex); + Tcl_MutexLock(&libraryMutex); if (Tcl_IsSafe(target)) { - pkgPtr->safeInterpRefCount--; + libraryPtr->safeInterpRefCount--; /* * Do not let counter get negative. */ - if (pkgPtr->safeInterpRefCount < 0) { - pkgPtr->safeInterpRefCount = 0; + if (libraryPtr->safeInterpRefCount < 0) { + libraryPtr->safeInterpRefCount = 0; } } else { - pkgPtr->interpRefCount--; + libraryPtr->interpRefCount--; /* * Do not let counter get negative. */ - if (pkgPtr->interpRefCount < 0) { - pkgPtr->interpRefCount = 0; + if (libraryPtr->interpRefCount < 0) { + libraryPtr->interpRefCount = 0; } } - trustedRefCount = pkgPtr->interpRefCount; - safeRefCount = pkgPtr->safeInterpRefCount; - Tcl_MutexUnlock(&packageMutex); + trustedRefCount = libraryPtr->interpRefCount; + safeRefCount = libraryPtr->safeInterpRefCount; + Tcl_MutexUnlock(&libraryMutex); code = TCL_OK; - if (pkgPtr->safeInterpRefCount <= 0 && pkgPtr->interpRefCount <= 0 + if (libraryPtr->safeInterpRefCount <= 0 && libraryPtr->interpRefCount <= 0 && !keepLibrary) { /* * Unload the shared library from the application memory... @@ -847,21 +845,21 @@ Tcl_UnloadObjCmd( * it's been unloaded. */ - if (pkgPtr->fileName[0] != '\0') { - Tcl_MutexLock(&packageMutex); - if (Tcl_FSUnloadFile(interp, pkgPtr->loadHandle) == TCL_OK) { + if (libraryPtr->fileName[0] != '\0') { + Tcl_MutexLock(&libraryMutex); + if (Tcl_FSUnloadFile(interp, libraryPtr->loadHandle) == TCL_OK) { /* * Remove this library from the loaded library cache. */ - defaultPtr = pkgPtr; - if (defaultPtr == firstPackagePtr) { - firstPackagePtr = pkgPtr->nextPtr; + defaultPtr = libraryPtr; + if (defaultPtr == firstLibraryPtr) { + firstLibraryPtr = libraryPtr->nextPtr; } else { - for (pkgPtr = firstPackagePtr; pkgPtr != NULL; - pkgPtr = pkgPtr->nextPtr) { - if (pkgPtr->nextPtr == defaultPtr) { - pkgPtr->nextPtr = defaultPtr->nextPtr; + for (libraryPtr = firstLibraryPtr; libraryPtr != NULL; + libraryPtr = libraryPtr->nextPtr) { + if (libraryPtr->nextPtr == defaultPtr) { + libraryPtr->nextPtr = defaultPtr->nextPtr; break; } } @@ -873,14 +871,14 @@ Tcl_UnloadObjCmd( ipFirstPtr = (InterpPackage *)Tcl_GetAssocData(target, "tclLoad", NULL); ipPtr = ipFirstPtr; - if (ipPtr->pkgPtr == defaultPtr) { + if (ipPtr->libraryPtr == defaultPtr) { ipFirstPtr = ipFirstPtr->nextPtr; } else { InterpPackage *ipPrevPtr; for (ipPrevPtr = ipPtr; ipPtr != NULL; ipPrevPtr = ipPtr, ipPtr = ipPtr->nextPtr) { - if (ipPtr->pkgPtr == defaultPtr) { + if (ipPtr->libraryPtr == defaultPtr) { ipPrevPtr->nextPtr = ipPtr->nextPtr; break; } @@ -889,10 +887,10 @@ Tcl_UnloadObjCmd( Tcl_SetAssocData(target, "tclLoad", LoadCleanupProc, ipFirstPtr); Tcl_Free(defaultPtr->fileName); - Tcl_Free(defaultPtr->packageName); + Tcl_Free(defaultPtr->prefix); Tcl_Free(defaultPtr); Tcl_Free(ipPtr); - Tcl_MutexUnlock(&packageMutex); + Tcl_MutexUnlock(&libraryMutex); } else { code = TCL_ERROR; } @@ -920,7 +918,7 @@ Tcl_UnloadObjCmd( /* *---------------------------------------------------------------------- * - * Tcl_StaticPackage -- + * Tcl_StaticLibrary -- * * This function is invoked to indicate that a particular package has * been linked statically with an application. @@ -936,14 +934,12 @@ Tcl_UnloadObjCmd( */ void -Tcl_StaticPackage( +Tcl_StaticLibrary( Tcl_Interp *interp, /* If not NULL, it means that the package has * already been loaded into the given * interpreter by calling the appropriate init * proc. */ - const char *pkgName, /* Name of package (must be properly - * capitalized: first letter upper case, - * others lower case). */ + const char *prefix, /* Prefix. */ Tcl_PackageInitProc *initProc, /* Function to call to incorporate this * package into a trusted interpreter. */ @@ -954,7 +950,7 @@ Tcl_StaticPackage( * the package can't be used in safe * interpreters. */ { - LoadedPackage *pkgPtr; + LoadedLibrary *libraryPtr; InterpPackage *ipPtr, *ipFirstPtr; /* @@ -962,34 +958,34 @@ Tcl_StaticPackage( * statically loaded in the process. */ - Tcl_MutexLock(&packageMutex); - for (pkgPtr = firstPackagePtr; pkgPtr != NULL; pkgPtr = pkgPtr->nextPtr) { - if ((pkgPtr->initProc == initProc) - && (pkgPtr->safeInitProc == safeInitProc) - && (strcmp(pkgPtr->packageName, pkgName) == 0)) { + Tcl_MutexLock(&libraryMutex); + for (libraryPtr = firstLibraryPtr; libraryPtr != NULL; libraryPtr = libraryPtr->nextPtr) { + if ((libraryPtr->initProc == initProc) + && (libraryPtr->safeInitProc == safeInitProc) + && (strcmp(libraryPtr->prefix, prefix) == 0)) { break; } } - Tcl_MutexUnlock(&packageMutex); + Tcl_MutexUnlock(&libraryMutex); /* * If the package is not yet recorded as being loaded statically, add it * to the list now. */ - if (pkgPtr == NULL) { - pkgPtr = (LoadedPackage *)Tcl_Alloc(sizeof(LoadedPackage)); - pkgPtr->fileName = (char *)Tcl_Alloc(1); - pkgPtr->fileName[0] = 0; - pkgPtr->packageName = (char *)Tcl_Alloc(strlen(pkgName) + 1); - strcpy(pkgPtr->packageName, pkgName); - pkgPtr->loadHandle = NULL; - pkgPtr->initProc = initProc; - pkgPtr->safeInitProc = safeInitProc; - Tcl_MutexLock(&packageMutex); - pkgPtr->nextPtr = firstPackagePtr; - firstPackagePtr = pkgPtr; - Tcl_MutexUnlock(&packageMutex); + if (libraryPtr == NULL) { + libraryPtr = (LoadedLibrary *)Tcl_Alloc(sizeof(LoadedLibrary)); + libraryPtr->fileName = (char *)Tcl_Alloc(1); + libraryPtr->fileName[0] = 0; + libraryPtr->prefix = (char *)Tcl_Alloc(strlen(prefix) + 1); + strcpy(libraryPtr->prefix, prefix); + libraryPtr->loadHandle = NULL; + libraryPtr->initProc = initProc; + libraryPtr->safeInitProc = safeInitProc; + Tcl_MutexLock(&libraryMutex); + libraryPtr->nextPtr = firstLibraryPtr; + firstLibraryPtr = libraryPtr; + Tcl_MutexUnlock(&libraryMutex); } if (interp != NULL) { @@ -1001,7 +997,7 @@ Tcl_StaticPackage( ipFirstPtr = (InterpPackage *)Tcl_GetAssocData(interp, "tclLoad", NULL); for (ipPtr = ipFirstPtr; ipPtr != NULL; ipPtr = ipPtr->nextPtr) { - if (ipPtr->pkgPtr == pkgPtr) { + if (ipPtr->libraryPtr == libraryPtr) { return; } } @@ -1012,7 +1008,7 @@ Tcl_StaticPackage( */ ipPtr = (InterpPackage *)Tcl_Alloc(sizeof(InterpPackage)); - ipPtr->pkgPtr = pkgPtr; + ipPtr->libraryPtr = libraryPtr; ipPtr->nextPtr = ipFirstPtr; Tcl_SetAssocData(interp, "tclLoad", LoadCleanupProc, ipPtr); } @@ -1021,7 +1017,7 @@ Tcl_StaticPackage( /* *---------------------------------------------------------------------- * - * TclGetLoadedPackagesEx -- + * TclGetLoadedLibraries -- * * This function returns information about all of the files that are * loaded (either in a particular interpreter, or for all interpreters). @@ -1040,33 +1036,33 @@ Tcl_StaticPackage( */ int -TclGetLoadedPackagesEx( +TclGetLoadedLibraries( Tcl_Interp *interp, /* Interpreter in which to return information * or error message. */ const char *targetName, /* Name of target interpreter or NULL. If * NULL, return info about all interps; * otherwise, just return info about this * interpreter. */ - const char *packageName) /* Package name or NULL. If NULL, return info + const char *prefix) /* Package name or NULL. If NULL, return info * for all packages. */ { Tcl_Interp *target; - LoadedPackage *pkgPtr; + LoadedLibrary *libraryPtr; InterpPackage *ipPtr; Tcl_Obj *resultObj, *pkgDesc[2]; if (targetName == NULL) { TclNewObj(resultObj); - Tcl_MutexLock(&packageMutex); - for (pkgPtr = firstPackagePtr; pkgPtr != NULL; - pkgPtr = pkgPtr->nextPtr) { - pkgDesc[0] = Tcl_NewStringObj(pkgPtr->fileName, -1); - pkgDesc[1] = Tcl_NewStringObj(pkgPtr->packageName, -1); + Tcl_MutexLock(&libraryMutex); + for (libraryPtr = firstLibraryPtr; libraryPtr != NULL; + libraryPtr = libraryPtr->nextPtr) { + pkgDesc[0] = Tcl_NewStringObj(libraryPtr->fileName, -1); + pkgDesc[1] = Tcl_NewStringObj(libraryPtr->prefix, -1); Tcl_ListObjAppendElement(NULL, resultObj, Tcl_NewListObj(2, pkgDesc)); } - Tcl_MutexUnlock(&packageMutex); + Tcl_MutexUnlock(&libraryMutex); Tcl_SetObjResult(interp, resultObj); return TCL_OK; } @@ -1080,14 +1076,14 @@ TclGetLoadedPackagesEx( /* * Return information about all of the available packages. */ - if (packageName) { + if (prefix) { resultObj = NULL; for (; ipPtr != NULL; ipPtr = ipPtr->nextPtr) { - pkgPtr = ipPtr->pkgPtr; + libraryPtr = ipPtr->libraryPtr; - if (!strcmp(packageName, pkgPtr->packageName)) { - resultObj = Tcl_NewStringObj(pkgPtr->fileName, -1); + if (!strcmp(prefix, libraryPtr->prefix)) { + resultObj = Tcl_NewStringObj(libraryPtr->fileName, -1); break; } } @@ -1105,9 +1101,9 @@ TclGetLoadedPackagesEx( TclNewObj(resultObj); for (; ipPtr != NULL; ipPtr = ipPtr->nextPtr) { - pkgPtr = ipPtr->pkgPtr; - pkgDesc[0] = Tcl_NewStringObj(pkgPtr->fileName, -1); - pkgDesc[1] = Tcl_NewStringObj(pkgPtr->packageName, -1); + libraryPtr = ipPtr->libraryPtr; + pkgDesc[0] = Tcl_NewStringObj(libraryPtr->fileName, -1); + pkgDesc[1] = Tcl_NewStringObj(libraryPtr->prefix, -1); Tcl_ListObjAppendElement(NULL, resultObj, Tcl_NewListObj(2, pkgDesc)); } Tcl_SetObjResult(interp, resultObj); @@ -1154,7 +1150,7 @@ LoadCleanupProc( * TclFinalizeLoad -- * * This function is invoked just before the application exits. It frees - * all of the LoadedPackage structures. + * all of the LoadedLibrary structures. * * Results: * None. @@ -1168,18 +1164,18 @@ LoadCleanupProc( void TclFinalizeLoad(void) { - LoadedPackage *pkgPtr; + LoadedLibrary *libraryPtr; /* * No synchronization here because there should just be one thread alive - * at this point. Logically, packageMutex should be grabbed at this point, + * at this point. Logically, libraryMutex should be grabbed at this point, * but the Mutexes get finalized before the call to this routine. The only * subsystem left alive at this point is the memory allocator. */ - while (firstPackagePtr != NULL) { - pkgPtr = firstPackagePtr; - firstPackagePtr = pkgPtr->nextPtr; + while (firstLibraryPtr != NULL) { + libraryPtr = firstLibraryPtr; + firstLibraryPtr = libraryPtr->nextPtr; #if defined(TCL_UNLOAD_DLLS) || defined(_WIN32) /* @@ -1189,14 +1185,14 @@ TclFinalizeLoad(void) * it has been unloaded. */ - if (pkgPtr->fileName[0] != '\0') { - Tcl_FSUnloadFile(NULL, pkgPtr->loadHandle); + if (libraryPtr->fileName[0] != '\0') { + Tcl_FSUnloadFile(NULL, libraryPtr->loadHandle); } #endif - Tcl_Free(pkgPtr->fileName); - Tcl_Free(pkgPtr->packageName); - Tcl_Free(pkgPtr); + Tcl_Free(libraryPtr->fileName); + Tcl_Free(libraryPtr->prefix); + Tcl_Free(libraryPtr); } } diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c index 93529d1..12e0272 100644 --- a/generic/tclStubInit.c +++ b/generic/tclStubInit.c @@ -60,9 +60,9 @@ #undef TclWinGetSockOpt #undef TclWinSetSockOpt #undef TclWinNToHS -#undef TclStaticPackage +#undef TclStaticLibrary #undef Tcl_BackgroundError -#define TclStaticPackage Tcl_StaticPackage +#define TclStaticLibrary Tcl_StaticLibrary #undef Tcl_UniCharToUtfDString #undef Tcl_UtfToUniCharDString #undef Tcl_UtfToUniChar @@ -528,7 +528,7 @@ static const TclIntStubs tclIntStubs = { TclPtrIncrObjVar, /* 254 */ TclPtrObjMakeUpvar, /* 255 */ TclPtrUnsetVar, /* 256 */ - TclStaticPackage, /* 257 */ + TclStaticLibrary, /* 257 */ TclpCreateTemporaryDirectory, /* 258 */ TclAppendUnicodeToObj, /* 259 */ TclGetBytesFromObj, /* 260 */ diff --git a/generic/tclTest.c b/generic/tclTest.c index 91e3b49..502d9c9 100644 --- a/generic/tclTest.c +++ b/generic/tclTest.c @@ -274,7 +274,7 @@ static Tcl_CmdProc Testset2Cmd; static Tcl_CmdProc TestseterrorcodeCmd; static Tcl_ObjCmdProc TestsetobjerrorcodeCmd; static Tcl_CmdProc TestsetplatformCmd; -static Tcl_CmdProc TeststaticpkgCmd; +static Tcl_CmdProc TeststaticlibraryCmd; static Tcl_CmdProc TesttranslatefilenameCmd; static Tcl_CmdProc TestupvarCmd; static Tcl_ObjCmdProc TestWrongNumArgsObjCmd; @@ -601,7 +601,7 @@ Tcltest_Init( NULL, NULL); Tcl_CreateCommand(interp, "testsocket", TestSocketCmd, NULL, NULL); - Tcl_CreateCommand(interp, "teststaticpkg", TeststaticpkgCmd, + Tcl_CreateCommand(interp, "teststaticlibrary", TeststaticlibraryCmd, NULL, NULL); Tcl_CreateCommand(interp, "testtranslatefilename", TesttranslatefilenameCmd, NULL, NULL); @@ -4217,10 +4217,10 @@ TestsetplatformCmd( /* *---------------------------------------------------------------------- * - * TeststaticpkgCmd -- + * TeststaticlibraryCmd -- * - * This procedure implements the "teststaticpkg" command. - * It is used to test the procedure Tcl_StaticPackage. + * This procedure implements the "teststaticlibrary" command. + * It is used to test the procedure Tcl_StaticLibrary. * * Results: * A standard Tcl result. @@ -4233,7 +4233,7 @@ TestsetplatformCmd( */ static int -TeststaticpkgCmd( +TeststaticlibraryCmd( TCL_UNUSED(void *), Tcl_Interp *interp, /* Current interpreter. */ int argc, /* Number of arguments. */ @@ -4243,7 +4243,7 @@ TeststaticpkgCmd( if (argc != 4) { Tcl_AppendResult(interp, "wrong # arguments: should be \"", - argv[0], " pkgName safe loaded\"", NULL); + argv[0], " prefix safe loaded\"", NULL); return TCL_ERROR; } if (Tcl_GetInt(interp, argv[2], &safe) != TCL_OK) { @@ -4252,7 +4252,7 @@ TeststaticpkgCmd( if (Tcl_GetInt(interp, argv[3], &loaded) != TCL_OK) { return TCL_ERROR; } - Tcl_StaticPackage((loaded) ? interp : NULL, argv[1], + Tcl_StaticLibrary((loaded) ? interp : NULL, argv[1], StaticInitProc, (safe) ? StaticInitProc : NULL); return TCL_OK; } diff --git a/macosx/Tcl.xcode/project.pbxproj b/macosx/Tcl.xcode/project.pbxproj index 8004ffe..6a3b921 100644 --- a/macosx/Tcl.xcode/project.pbxproj +++ b/macosx/Tcl.xcode/project.pbxproj @@ -394,7 +394,7 @@ F96D3EA208F272A7004A47F5 /* split.n */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = split.n; sourceTree = ""; }; F96D3EA308F272A7004A47F5 /* SplitList.3 */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = SplitList.3; sourceTree = ""; }; F96D3EA408F272A7004A47F5 /* SplitPath.3 */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = SplitPath.3; sourceTree = ""; }; - F96D3EA508F272A7004A47F5 /* StaticPkg.3 */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = StaticPkg.3; sourceTree = ""; }; + F96D3EA508F272A7004A47F5 /* StaticLibrary.3 */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = StaticLibrary.3; sourceTree = ""; }; F96D3EA608F272A7004A47F5 /* StdChannels.3 */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = StdChannels.3; sourceTree = ""; }; F96D3EA708F272A7004A47F5 /* string.n */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = string.n; sourceTree = ""; }; F96D3EA808F272A7004A47F5 /* StringObj.3 */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = StringObj.3; sourceTree = ""; }; @@ -1149,7 +1149,7 @@ F96D3EA208F272A7004A47F5 /* split.n */, F96D3EA308F272A7004A47F5 /* SplitList.3 */, F96D3EA408F272A7004A47F5 /* SplitPath.3 */, - F96D3EA508F272A7004A47F5 /* StaticPkg.3 */, + F96D3EA508F272A7004A47F5 /* StaticLibrary.3 */, F96D3EA608F272A7004A47F5 /* StdChannels.3 */, F96D3EA708F272A7004A47F5 /* string.n */, F96D3EA808F272A7004A47F5 /* StringObj.3 */, diff --git a/macosx/Tcl.xcodeproj/project.pbxproj b/macosx/Tcl.xcodeproj/project.pbxproj index 6528616..47f522c 100644 --- a/macosx/Tcl.xcodeproj/project.pbxproj +++ b/macosx/Tcl.xcodeproj/project.pbxproj @@ -393,7 +393,7 @@ F96D3EA208F272A7004A47F5 /* split.n */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = split.n; sourceTree = ""; }; F96D3EA308F272A7004A47F5 /* SplitList.3 */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = SplitList.3; sourceTree = ""; }; F96D3EA408F272A7004A47F5 /* SplitPath.3 */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = SplitPath.3; sourceTree = ""; }; - F96D3EA508F272A7004A47F5 /* StaticPkg.3 */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = StaticPkg.3; sourceTree = ""; }; + F96D3EA508F272A7004A47F5 /* StaticLibrary.3 */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = StaticLibrary.3; sourceTree = ""; }; F96D3EA608F272A7004A47F5 /* StdChannels.3 */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = StdChannels.3; sourceTree = ""; }; F96D3EA708F272A7004A47F5 /* string.n */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = string.n; sourceTree = ""; }; F96D3EA808F272A7004A47F5 /* StringObj.3 */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = StringObj.3; sourceTree = ""; }; @@ -1149,7 +1149,7 @@ F96D3EA208F272A7004A47F5 /* split.n */, F96D3EA308F272A7004A47F5 /* SplitList.3 */, F96D3EA408F272A7004A47F5 /* SplitPath.3 */, - F96D3EA508F272A7004A47F5 /* StaticPkg.3 */, + F96D3EA508F272A7004A47F5 /* StaticLibrary.3 */, F96D3EA608F272A7004A47F5 /* StdChannels.3 */, F96D3EA708F272A7004A47F5 /* string.n */, F96D3EA808F272A7004A47F5 /* StringObj.3 */, diff --git a/tests/load.test b/tests/load.test index c79ddf4..eaaf7a7 100644 --- a/tests/load.test +++ b/tests/load.test @@ -36,9 +36,9 @@ testConstraint $loaded [expr {![string match *pkga* $alreadyLoaded]}] set alreadyTotalLoaded [info loaded] -# Certain tests require the 'teststaticpkg' command from tcltest +# Certain tests require the 'teststaticlibrary' command from tcltest -testConstraint teststaticpkg [llength [info commands teststaticpkg]] +testConstraint teststaticlibrary [llength [info commands teststaticlibrary]] # Test load-10.1 requires the 'testsimplefilesystem' command from tcltest @@ -47,10 +47,10 @@ testConstraint testsimplefilesystem \ test load-1.1 {basic errors} -returnCodes error -body { load -} -result {wrong # args: should be "load ?-global? ?-lazy? ?--? fileName ?packageName? ?interp?"} +} -result {wrong # args: should be "load ?-global? ?-lazy? ?--? fileName ?prefix? ?interp?"} test load-1.2 {basic errors} -returnCodes error -body { load a b c d -} -result {wrong # args: should be "load ?-global? ?-lazy? ?--? fileName ?packageName? ?interp?"} +} -result {wrong # args: should be "load ?-global? ?-lazy? ?--? fileName ?prefix? ?interp?"} test load-1.3 {basic errors} -returnCodes error -body { load a b foobar } -result {could not find interpreter "foobar"} @@ -62,7 +62,7 @@ test load-1.5 {basic errors} -returnCodes error -body { } -result {must specify either file name or package name} test load-1.6 {basic errors} -returnCodes error -body { load {} Unknown -} -result {package "Unknown" isn't loaded statically} +} -result {no library with prefix "Unknown" is loaded statically} test load-1.7 {basic errors} -returnCodes error -body { load -abc foo } -result {bad option "-abc": must be -global, -lazy, or --} @@ -78,13 +78,13 @@ test load-2.1 {basic loading, with guess for package name} \ interp create -safe child test load-2.2 {loading into a safe interpreter, with package name conversion} \ [list $dll $loaded] { - load -lazy [file join $testDir pkgb$ext] pKgB child + load -lazy [file join $testDir pkgb$ext] Pkgb child list [child eval pkgb_sub 44 13] [catch {child eval pkgb_unsafe} msg] $msg \ [catch {pkgb_sub 12 10} msg2] $msg2 } {31 1 {invalid command name "pkgb_unsafe"} 1 {invalid command name "pkgb_sub"}} test load-2.3 {loading with no _Init procedure} -constraints [list $dll $loaded] \ -body { - list [catch {load [file join $testDir pkgc$ext] foo} msg] $msg $errorCode + list [catch {load [file join $testDir pkgc$ext] Foo} msg] $msg $errorCode } -match glob \ -result [list 1 {cannot find symbol "Foo_Init"*} \ {TCL LOOKUP LOAD_SYMBOL *Foo_Init}] @@ -94,7 +94,7 @@ test load-2.4 {loading with no _SafeInit procedure} [list $dll $loaded] { test load-3.1 {error in _Init procedure, same interpreter} \ [list $dll $loaded] { - list [catch {load [file join $testDir pkge$ext] pkge} msg] \ + list [catch {load [file join $testDir pkge$ext] Pkge} msg] \ $msg $::errorInfo $::errorCode } {1 {couldn't open "non_existent": no such file or directory} {couldn't open "non_existent": no such file or directory while executing @@ -102,14 +102,14 @@ test load-3.1 {error in _Init procedure, same interpreter} \ invoked from within "if 44 {open non_existent}" invoked from within -"load [file join $testDir pkge$ext] pkge"} {POSIX ENOENT {no such file or directory}}} +"load [file join $testDir pkge$ext] Pkge"} {POSIX ENOENT {no such file or directory}}} test load-3.2 {error in _Init procedure, child interpreter} \ [list $dll $loaded] { catch {interp delete x} interp create x set ::errorCode foo set ::errorInfo bar - set result [list [catch {load [file join $testDir pkge$ext] pkge x} msg] \ + set result [list [catch {load [file join $testDir pkge$ext] Pkge x} msg] \ $msg $::errorInfo $::errorCode] interp delete x set result @@ -119,23 +119,23 @@ test load-3.2 {error in _Init procedure, child interpreter} \ invoked from within "if 44 {open non_existent}" invoked from within -"load [file join $testDir pkge$ext] pkge x"} {POSIX ENOENT {no such file or directory}}} +"load [file join $testDir pkge$ext] Pkge x"} {POSIX ENOENT {no such file or directory}}} test load-4.1 {reloading package into same interpreter} [list $dll $loaded] { - list [catch {load [file join $testDir pkga$ext] pkga} msg] $msg + list [catch {load [file join $testDir pkga$ext] Pkga} msg] $msg } {0 {}} test load-4.2 {reloading package into same interpreter} -setup { catch {load [file join $testDir pkga$ext] pkga} } -constraints [list $dll $loaded] -returnCodes error -body { - load [file join $testDir pkga$ext] pkgb + load [file join $testDir pkga$ext] Pkgb } -result "file \"[file join $testDir pkga$ext]\" is already loaded for package \"Pkga\"" test load-5.1 {file name not specified and no static package: pick default} -setup { catch {interp delete x} interp create x } -constraints [list $dll $loaded] -body { - load -global [file join $testDir pkga$ext] pkga - load {} pkga x + load -global [file join $testDir pkga$ext] Pkga + load {} Pkga x info loaded x } -cleanup { interp delete x @@ -150,78 +150,78 @@ test load-6.1 {errors loading file} [list $dll $loaded] { catch {load foo foo} } {1} -test load-7.1 {Tcl_StaticPackage procedure} [list teststaticpkg] { +test load-7.1 {Tcl_StaticLibrary procedure} [list teststaticlibrary] { set x "not loaded" - teststaticpkg Test 1 0 + teststaticlibrary Test 1 0 load {} Test load {} Test child list [set x] [child eval set x] } {loaded loaded} -test load-7.2 {Tcl_StaticPackage procedure} [list teststaticpkg] { +test load-7.2 {Tcl_StaticLibrary procedure} [list teststaticlibrary] { set x "not loaded" - teststaticpkg Another 0 0 + teststaticlibrary Another 0 0 load {} Another child eval {set x "not loaded"} list [catch {load {} Another child} msg] $msg \ [child eval set x] [set x] } {1 {can't use package in a safe interpreter: no Another_SafeInit procedure} {not loaded} loaded} -test load-7.3 {Tcl_StaticPackage procedure} [list teststaticpkg] { +test load-7.3 {Tcl_StaticLibrary procedure} [list teststaticlibrary] { set x "not loaded" - teststaticpkg More 0 1 + teststaticlibrary More 0 1 load {} More set x } {not loaded} -catch {load [file join $testDir pkga$ext] pkga} -catch {load [file join $testDir pkgb$ext] pkgb} -catch {load [file join $testDir pkge$ext] pkge} +catch {load [file join $testDir pkga$ext] Pkga} +catch {load [file join $testDir pkgb$ext] Pkgb} +catch {load [file join $testDir pkge$ext] Pkge} set currentRealPackages [list [list [file join $testDir pkge$ext] Pkge] [list [file join $testDir pkgb$ext] Pkgb] [list [file join $testDir pkga$ext] Pkga]] -test load-7.4 {Tcl_StaticPackage procedure, redundant calls} -setup { - teststaticpkg Test 1 0 - teststaticpkg Another 0 0 - teststaticpkg More 0 1 -} -constraints [list teststaticpkg $dll $loaded] -body { - teststaticpkg Double 0 1 - teststaticpkg Double 0 1 +test load-7.4 {Tcl_StaticLibrary procedure, redundant calls} -setup { + teststaticlibrary Test 1 0 + teststaticlibrary Another 0 0 + teststaticlibrary More 0 1 +} -constraints [list teststaticlibrary $dll $loaded] -body { + teststaticlibrary Double 0 1 + teststaticlibrary Double 0 1 info loaded } -result [list {{} Double} {{} More} {{} Another} {{} Test} {*}$currentRealPackages {*}$alreadyTotalLoaded] -testConstraint teststaticpkg_8.x 0 -if {[testConstraint teststaticpkg]} { +testConstraint teststaticlibrary_8.x 0 +if {[testConstraint teststaticlibrary]} { catch { - teststaticpkg Test 1 1 - teststaticpkg Another 0 1 - teststaticpkg More 0 1 - teststaticpkg Double 0 1 - testConstraint teststaticpkg_8.x 1 + teststaticlibrary Test 1 1 + teststaticlibrary Another 0 1 + teststaticlibrary More 0 1 + teststaticlibrary Double 0 1 + testConstraint teststaticlibrary_8.x 1 } } -test load-8.1 {TclGetLoadedPackages procedure} [list teststaticpkg_8.x $dll $loaded] { +test load-8.1 {TclGetLoadedPackages procedure} [list teststaticlibrary_8.x $dll $loaded] { lsort -index 1 [info loaded] } [lsort -index 1 [list {{} Double} {{} More} {{} Another} {{} Test} {*}$currentRealPackages {*}$alreadyTotalLoaded]] -test load-8.2 {TclGetLoadedPackages procedure} -constraints {teststaticpkg_8.x} -body { +test load-8.2 {TclGetLoadedPackages procedure} -constraints {teststaticlibrary_8.x} -body { info loaded gorp } -returnCodes error -result {could not find interpreter "gorp"} -test load-8.3a {TclGetLoadedPackages procedure} [list teststaticpkg_8.x $dll $loaded] { +test load-8.3a {TclGetLoadedPackages procedure} [list teststaticlibrary_8.x $dll $loaded] { lsort -index 1 [info loaded {}] } [lsort -index 1 [list {{} Double} {{} More} {{} Another} {{} Test} [list [file join $testDir pkga$ext] Pkga] [list [file join $testDir pkgb$ext] Pkgb] {*}$alreadyLoaded]] -test load-8.3b {TclGetLoadedPackages procedure} [list teststaticpkg_8.x $dll $loaded] { +test load-8.3b {TclGetLoadedPackages procedure} [list teststaticlibrary_8.x $dll $loaded] { lsort -index 1 [info loaded child] } [lsort -index 1 [list {{} Test} [list [file join $testDir pkgb$ext] Pkgb]]] -test load-8.4 {TclGetLoadedPackages procedure} [list teststaticpkg_8.x $dll $loaded] { - load [file join $testDir pkgb$ext] pkgb +test load-8.4 {TclGetLoadedPackages procedure} [list teststaticlibrary_8.x $dll $loaded] { + load [file join $testDir pkgb$ext] Pkgb list [lsort -index 1 [info loaded {}]] [lsort [info commands pkgb_*]] } [list [lsort -index 1 [concat [list [list [file join $testDir pkgb$ext] Pkgb] {{} Double} {{} More} {{} Another} {{} Test} [list [file join $testDir pkga$ext] Pkga]] $alreadyLoaded]] {pkgb_demo pkgb_sub pkgb_unsafe}] interp delete child -test load-9.1 {Tcl_StaticPackage, load already-loaded package into another interp} -setup { +test load-9.1 {Tcl_StaticLibrary, load already-loaded package into another interp} -setup { interp create child1 interp create child2 load {} Tcltest child1 load {} Tcltest child2 -} -constraints {teststaticpkg} -body { - child1 eval { teststaticpkg Loadninepointone 0 1 } - child2 eval { teststaticpkg Loadninepointone 0 1 } +} -constraints {teststaticlibrary} -body { + child1 eval { teststaticlibrary Loadninepointone 0 1 } + child2 eval { teststaticlibrary Loadninepointone 0 1 } list [child1 eval { info loaded {} }] \ [child2 eval { info loaded {} }] } -match glob -cleanup { @@ -234,7 +234,7 @@ test load-10.1 {load from vfs} -setup { cd $testDir testsimplefilesystem 1 } -constraints [list $dll $loaded testsimplefilesystem] -body { - list [catch {load simplefs:/pkgd$ext pkgd} msg] $msg + list [catch {load simplefs:/pkgd$ext Pkgd} msg] $msg } -result {0 {}} -cleanup { testsimplefilesystem 0 cd $dir diff --git a/tests/safe.test b/tests/safe.test index 1177e19..0394eb9 100644 --- a/tests/safe.test +++ b/tests/safe.test @@ -1157,7 +1157,7 @@ test safe-9.24 {interpConfigure change the access path; check module loading; st res0 res1 res2} # See comments on lsort after test safe-9.20. -catch {teststaticpkg Safepkg1 0 0} +catch {teststaticlibrary Safepkg1 0 0} test safe-10.1 {testing statics loading} -constraints TcltestPackage -setup { set i [safe::interpCreate] } -body { diff --git a/tests/unload.test b/tests/unload.test index 32767fa..f1f4580 100644 --- a/tests/unload.test +++ b/tests/unload.test @@ -53,10 +53,10 @@ proc loadIfNotPresent {pkg args} { # Basic tests: parameter testing... test unload-1.1 {basic errors} -returnCodes error -body { unload -} -result {wrong # args: should be "unload ?-switch ...? fileName ?packageName? ?interp?"} +} -result {wrong # args: should be "unload ?-switch ...? fileName ?prefix? ?interp?"} test unload-1.2 {basic errors} -returnCodes error -body { unload a b c d -} -result {wrong # args: should be "unload ?-switch ...? fileName ?packageName? ?interp?"} +} -result {wrong # args: should be "unload ?-switch ...? fileName ?prefix? ?interp?"} test unload-1.3 {basic errors} -returnCodes error -body { unload a b foobar } -result {could not find interpreter "foobar"} @@ -68,7 +68,7 @@ test unload-1.5 {basic errors} -returnCodes error -body { } -result {must specify either file name or package name} test unload-1.6 {basic errors} -returnCodes error -body { unload {} Unknown -} -result {package "Unknown" is loaded statically and cannot be unloaded} +} -result {library with prefix "Unknown" is loaded statically and cannot be unloaded} test unload-1.7 {-nocomplain switch} { unload -nocomplain {} Unknown } {} @@ -135,14 +135,14 @@ child eval { test unload-3.1 {basic loading of non-unloadable package in a safe interpreter, with package name conversion} \ [list $dll $loaded] { catch {rename pkgb_sub {}} - load [file join $testDir pkgb$ext] pKgB child + load [file join $testDir pkgb$ext] Pkgb child list [child eval pkgb_sub 44 13] [catch {child eval pkgb_unsafe} msg] $msg \ [catch {pkgb_sub 12 10} msg2] $msg2 } {31 1 {invalid command name "pkgb_unsafe"} 1 {invalid command name "pkgb_sub"}} test unload-3.2 {basic loading of unloadable package in a safe interpreter, with package name conversion} \ [list $dll $loaded] { list [child eval {list $pkgua_loaded $pkgua_detached $pkgua_unloaded}] \ - [load [file join $testDir pkgua$ext] pKgUA child] \ + [load [file join $testDir pkgua$ext] Pkgua child] \ [child eval pkgua_eq abc def] \ [lsort [child eval info commands pkgua_*]] \ [child eval {list $pkgua_loaded $pkgua_detached $pkgua_unloaded}] @@ -154,14 +154,14 @@ test unload-3.3 {unloading of a package that has never been loaded from a safe i } -result {file "*" has never been loaded in this interpreter} test unload-3.4 {basic unloading of a non-unloadable package from a safe interpreter, with guess for package name} -setup { if {[lsearch -index 1 [info loaded child] Pkgb] < 0} { - load [file join $testDir pkgb$ext] pKgB child + load [file join $testDir pkgb$ext] Pkgb child } } -constraints [list $dll $loaded] -returnCodes error -match glob -body { unload [file join $testDir pkgb$ext] {} child } -result {file "*" cannot be unloaded under a safe interpreter} test unload-3.5 {basic unloading of an unloadable package from a safe interpreter, with guess for package name} -setup { if {[lsearch -index 1 [info loaded child] Pkgua] < 0} { - load [file join $testDir pkgua$ext] pkgua child + load [file join $testDir pkgua$ext] Pkgua child } } -constraints [list $dll $loaded] -body { list [child eval {list $pkgua_loaded $pkgua_detached $pkgua_unloaded}] \ @@ -189,7 +189,7 @@ test unload-3.7 {basic unloading of re-loaded package from a safe interpreter, w } } -constraints [list $dll $loaded] -body { list [child eval {list $pkgua_loaded $pkgua_detached $pkgua_unloaded}] \ - [unload [file join $testDir pkgua$ext] pKgUa child] \ + [unload [file join $testDir pkgua$ext] Pkgua child] \ [child eval info commands pkgua_*] \ [child eval {list $pkgua_loaded $pkgua_detached $pkgua_unloaded}] } -result {{.. . .} {} {} {.. .. ..}} @@ -224,7 +224,7 @@ test unload-4.2 {basic loading of unloadable package in a safe interpreter, with incr load(C) } -constraints [list $dll $loaded] -body { list [child eval {list $pkgua_loaded $pkgua_detached $pkgua_unloaded}] \ - [load [file join $testDir pkgua$ext] pKgUA child] \ + [load [file join $testDir pkgua$ext] Pkgua child] \ [child eval pkgua_eq abc def] \ [lsort [child eval info commands pkgua_*]] \ [child eval {list $pkgua_loaded $pkgua_detached $pkgua_unloaded}] @@ -234,7 +234,7 @@ test unload-4.3 {basic loading of unloadable package in a second trusted interpr incr load(T) } -constraints [list $dll $loaded] -body { list [child-trusted eval {list $pkgua_loaded $pkgua_detached $pkgua_unloaded}] \ - [load [file join $testDir pkgua$ext] pkguA child-trusted] \ + [load [file join $testDir pkgua$ext] Pkgua child-trusted] \ [child-trusted eval pkgua_eq abc def] \ [lsort [child-trusted eval info commands pkgua_*]] \ [child-trusted eval {list $pkgua_loaded $pkgua_detached $pkgua_unloaded}] @@ -291,7 +291,7 @@ test unload-5.1 {unload a module loaded from vfs} \ set dir [pwd] cd $testDir testsimplefilesystem 1 - load simplefs:/pkgua$ext pkgua + load simplefs:/pkgua$ext Pkgua } \ -body { list [catch {unload simplefs:/pkgua$ext} msg] $msg diff --git a/unix/tclAppInit.c b/unix/tclAppInit.c index 3587f35..0b03d5d 100644 --- a/unix/tclAppInit.c +++ b/unix/tclAppInit.c @@ -124,7 +124,7 @@ Tcl_AppInit( if (Tcltest_Init(interp) == TCL_ERROR) { return TCL_ERROR; } - Tcl_StaticPackage(interp, "Tcltest", Tcltest_Init, Tcltest_SafeInit); + Tcl_StaticLibrary(interp, "Tcltest", Tcltest_Init, Tcltest_SafeInit); #endif /* TCL_TEST */ /* diff --git a/win/tcl.dsp b/win/tcl.dsp index 8b20d66..02dcf32 100644 --- a/win/tcl.dsp +++ b/win/tcl.dsp @@ -824,7 +824,7 @@ SOURCE=..\doc\SplitPath.3 # End Source File # Begin Source File -SOURCE=..\doc\StaticPkg.3 +SOURCE=..\doc\StaticLibrary.3 # End Source File # Begin Source File diff --git a/win/tclAppInit.c b/win/tclAppInit.c index a9fb3bd..5c479f9 100644 --- a/win/tclAppInit.c +++ b/win/tclAppInit.c @@ -168,19 +168,19 @@ Tcl_AppInit( if (Registry_Init(interp) == TCL_ERROR) { return TCL_ERROR; } - Tcl_StaticPackage(interp, "Registry", Registry_Init, NULL); + Tcl_StaticLibrary(interp, "Registry", Registry_Init, NULL); if (Dde_Init(interp) == TCL_ERROR) { return TCL_ERROR; } - Tcl_StaticPackage(interp, "Dde", Dde_Init, Dde_SafeInit); + Tcl_StaticLibrary(interp, "Dde", Dde_Init, Dde_SafeInit); #endif #ifdef TCL_TEST if (Tcltest_Init(interp) == TCL_ERROR) { return TCL_ERROR; } - Tcl_StaticPackage(interp, "Tcltest", Tcltest_Init, Tcltest_SafeInit); + Tcl_StaticLibrary(interp, "Tcltest", Tcltest_Init, Tcltest_SafeInit); #endif /* TCL_TEST */ /* -- cgit v0.12 From bf23a021385451ff52770191acec3f55d5c8575a Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 10 Nov 2020 15:38:52 +0000 Subject: more cleanup/error-messages --- generic/tclLoad.c | 186 +++++++++++++++++++++++++++--------------------------- tests/load.test | 12 ++-- tests/safe.test | 8 +-- tests/unload.test | 4 +- 4 files changed, 104 insertions(+), 106 deletions(-) diff --git a/generic/tclLoad.c b/generic/tclLoad.c index 67bc2cc..fe86622 100644 --- a/generic/tclLoad.c +++ b/generic/tclLoad.c @@ -13,17 +13,15 @@ #include "tclInt.h" /* - * The following structure describes a package that has been loaded either + * The following structure describes a library that has been loaded either * dynamically (with the "load" command) or statically (as indicated by a call - * to TclGetLoadedLibraries). All such packages are linked together into a - * single list for the process. Packages are never unloaded, until the - * application exits, when TclFinalizeLoad is called, and these structures are - * freed. + * to Tcl_StaticLibrary). All such libraries are linked together into a + * single list for the process. */ typedef struct LoadedLibrary { - char *fileName; /* Name of the file from which the package was - * loaded. An empty string means the package + char *fileName; /* Name of the file from which the library was + * loaded. An empty string means the library * is loaded statically. Malloc-ed. */ char *prefix; /* Prefix for the library. * Malloc-ed. */ @@ -33,59 +31,59 @@ typedef struct LoadedLibrary { * then this field is irrelevant. */ Tcl_PackageInitProc *initProc; /* Initialization function to call to - * incorporate this package into a trusted + * incorporate this library into a trusted * interpreter. */ Tcl_PackageInitProc *safeInitProc; /* Initialization function to call to - * incorporate this package into a safe + * incorporate this library into a safe * interpreter (one that will execute - * untrusted scripts). NULL means the package + * untrusted scripts). NULL means the library * can't be used in unsafe interpreters. */ Tcl_PackageUnloadProc *unloadProc; - /* Finalisation function to unload a package + /* Finalization function to unload a library * from a trusted interpreter. NULL means that - * the package cannot be unloaded. */ + * the library cannot be unloaded. */ Tcl_PackageUnloadProc *safeUnloadProc; - /* Finalisation function to unload a package + /* Finalization function to unload a library * from a safe interpreter. NULL means that - * the package cannot be unloaded. */ - int interpRefCount; /* How many times the package has been loaded + * the library cannot be unloaded. */ + int interpRefCount; /* How many times the library has been loaded * in trusted interpreters. */ - int safeInterpRefCount; /* How many times the package has been loaded + int safeInterpRefCount; /* How many times the library has been loaded * in safe interpreters. */ struct LoadedLibrary *nextPtr; - /* Next in list of all packages loaded into + /* Next in list of all libraries loaded into * this application process. NULL means end of * list. */ } LoadedLibrary; /* * TCL_THREADS - * There is a global list of packages that is anchored at firstLibraryPtr. + * There is a global list of libraries that is anchored at firstLibraryPtr. * Access to this list is governed by a mutex. */ static LoadedLibrary *firstLibraryPtr = NULL; - /* First in list of all packages loaded into + /* First in list of all libraries loaded into * this process. */ TCL_DECLARE_MUTEX(libraryMutex) /* - * The following structure represents a particular package that has been + * The following structure represents a particular library that has been * incorporated into a particular interpreter (by calling its initialization * function). There is a list of these structures for each interpreter, with * an AssocData value (key "load") for the interpreter that points to the - * first package (if any). + * first library (if any). */ -typedef struct InterpPackage { +typedef struct InterpLibrary { LoadedLibrary *libraryPtr; /* Points to detailed information about - * package. */ - struct InterpPackage *nextPtr; - /* Next package in this interpreter, or NULL + * library. */ + struct InterpLibrary *nextPtr; + /* Next lirary in this interpreter, or NULL * for end of list. */ -} InterpPackage; +} InterpLibrary; /* * Prototypes for functions that are private to this file: @@ -122,7 +120,7 @@ Tcl_LoadObjCmd( LoadedLibrary *libraryPtr, *defaultPtr; Tcl_DString pkgName, tmp, initName, safeInitName; Tcl_DString unloadName, safeUnloadName; - InterpPackage *ipFirstPtr, *ipPtr; + InterpLibrary *ipFirstPtr, *ipPtr; int code, namesMatch, filesMatch, offset; const char *symbols[2]; Tcl_PackageInitProc *initProc; @@ -181,7 +179,7 @@ Tcl_LoadObjCmd( } if ((fullFileName[0] == 0) && (prefix == NULL)) { Tcl_SetObjResult(interp, Tcl_NewStringObj( - "must specify either file name or package name", -1)); + "must specify either file name or prefix", -1)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LOAD", "NOLIBRARY", NULL); code = TCL_ERROR; @@ -189,7 +187,7 @@ Tcl_LoadObjCmd( } /* - * Figure out which interpreter we're going to load the package into. + * Figure out which interpreter we're going to load the library into. */ target = interp; @@ -204,13 +202,13 @@ Tcl_LoadObjCmd( } /* - * Scan through the packages that are currently loaded to see if the - * package we want is already loaded. We'll use a loaded package if it + * Scan through the libraries that are currently loaded to see if the + * library we want is already loaded. We'll use a loaded library if it * meets any of the following conditions: * - Its name and file match the once we're looking for. * - Its file matches, and we weren't given a name. * - Its name matches, the file name was specified as empty, and there is - * only no statically loaded package with the same name. + * only no statically loaded library with the same prefix. */ Tcl_MutexLock(&libraryMutex); @@ -242,11 +240,11 @@ Tcl_LoadObjCmd( } if (filesMatch && !namesMatch && (fullFileName[0] != 0)) { /* - * Can't have two different packages loaded from the same file. + * Can't have two different libraries loaded from the same file. */ Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "file \"%s\" is already loaded for package \"%s\"", + "file \"%s\" is already loaded for prefix \"%s\"", fullFileName, libraryPtr->prefix)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LOAD", "SPLITPERSONALITY", NULL); @@ -261,13 +259,13 @@ Tcl_LoadObjCmd( } /* - * Scan through the list of packages already loaded in the target - * interpreter. If the package we want is already loaded there, then + * Scan through the list of libraries already loaded in the target + * interpreter. If the library we want is already loaded there, then * there's nothing for us to do. */ if (libraryPtr != NULL) { - ipFirstPtr = (InterpPackage *)Tcl_GetAssocData(target, "tclLoad", NULL); + ipFirstPtr = (InterpLibrary *)Tcl_GetAssocData(target, "tclLoad", NULL); for (ipPtr = ipFirstPtr; ipPtr != NULL; ipPtr = ipPtr->nextPtr) { if (ipPtr->libraryPtr == libraryPtr) { code = TCL_OK; @@ -279,7 +277,7 @@ Tcl_LoadObjCmd( if (libraryPtr == NULL) { /* * The desired file isn't currently loaded, so load it. It's an error - * if the desired package is a static one. + * if the desired library is a static one. */ if (fullFileName[0] == 0) { @@ -344,10 +342,10 @@ Tcl_LoadObjCmd( if (p == pkgGuess) { Tcl_DecrRefCount(splitPtr); Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "couldn't figure out package name for %s", + "couldn't figure out prefix for %s", fullFileName)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LOAD", - "WHATPACKAGE", NULL); + "WHATLIBRARY", NULL); code = TCL_ERROR; goto done; } @@ -355,7 +353,7 @@ Tcl_LoadObjCmd( Tcl_DecrRefCount(splitPtr); /* - * Fix the capitalization in the package name so that the first + * Fix the capitalization in the prefix so that the first * character is in caps (or title case) but the others are all * lower-case. */ @@ -367,7 +365,7 @@ Tcl_LoadObjCmd( /* * Compute the names of the two initialization functions, based on the - * package name. + * prefix. */ TclDStringAppendDString(&initName, &pkgName); @@ -380,7 +378,7 @@ Tcl_LoadObjCmd( TclDStringAppendLiteral(&safeUnloadName, "_SafeUnload"); /* - * Call platform-specific code to load the package and find the two + * Call platform-specific code to load the library and find the two * initialization functions. */ @@ -396,7 +394,7 @@ Tcl_LoadObjCmd( } /* - * Create a new record to describe this package. + * Create a new record to describe this library. */ libraryPtr = (LoadedLibrary *)Tcl_Alloc(sizeof(LoadedLibrary)); @@ -434,14 +432,14 @@ Tcl_LoadObjCmd( } /* - * Invoke the package's initialization function (either the normal one or + * Invoke the library's initialization function (either the normal one or * the safe one, depending on whether or not the interpreter is safe). */ if (Tcl_IsSafe(target)) { if (libraryPtr->safeInitProc == NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "can't use package in a safe interpreter: no" + "can't use library in a safe interpreter: no" " %s_SafeInit procedure", libraryPtr->prefix)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LOAD", "UNSAFE", NULL); @@ -452,7 +450,7 @@ Tcl_LoadObjCmd( } else { if (libraryPtr->initProc == NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "can't attach package to interpreter: no %s_Init procedure", + "can't attach library to interpreter: no %s_Init procedure", libraryPtr->prefix)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LOAD", "ENTRYPOINT", NULL); @@ -484,7 +482,7 @@ Tcl_LoadObjCmd( } /* - * Record the fact that the package has been loaded in the target + * Record the fact that the library has been loaded in the target * interpreter. * * Update the proper reference count. @@ -499,12 +497,12 @@ Tcl_LoadObjCmd( Tcl_MutexUnlock(&libraryMutex); /* - * Refetch ipFirstPtr: loading the package may have introduced additional - * static packages at the head of the linked list! + * Refetch ipFirstPtr: loading the library may have introduced additional + * static libraries at the head of the linked list! */ - ipFirstPtr = (InterpPackage *)Tcl_GetAssocData(target, "tclLoad", NULL); - ipPtr = (InterpPackage *)Tcl_Alloc(sizeof(InterpPackage)); + ipFirstPtr = (InterpLibrary *)Tcl_GetAssocData(target, "tclLoad", NULL); + ipPtr = (InterpLibrary *)Tcl_Alloc(sizeof(InterpLibrary)); ipPtr->libraryPtr = libraryPtr; ipPtr->nextPtr = ipFirstPtr; Tcl_SetAssocData(target, "tclLoad", LoadCleanupProc, ipPtr); @@ -547,7 +545,7 @@ Tcl_UnloadObjCmd( LoadedLibrary *libraryPtr, *defaultPtr; Tcl_DString pkgName, tmp; Tcl_PackageUnloadProc *unloadProc; - InterpPackage *ipFirstPtr, *ipPtr; + InterpLibrary *ipFirstPtr, *ipPtr; int i, index, code, complain = 1, keepLibrary = 0; int trustedRefCount = -1, safeRefCount = -1; const char *fullFileName = ""; @@ -615,7 +613,7 @@ Tcl_UnloadObjCmd( } if ((fullFileName[0] == 0) && (prefix == NULL)) { Tcl_SetObjResult(interp, Tcl_NewStringObj( - "must specify either file name or package name", -1)); + "must specify either file name or prefix", -1)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "UNLOAD", "NOLIBRARY", NULL); code = TCL_ERROR; @@ -623,7 +621,7 @@ Tcl_UnloadObjCmd( } /* - * Figure out which interpreter we're going to load the package into. + * Figure out which interpreter we're going to load the library into. */ target = interp; @@ -637,13 +635,13 @@ Tcl_UnloadObjCmd( } /* - * Scan through the packages that are currently loaded to see if the - * package we want is already loaded. We'll use a loaded package if it + * Scan through the libraries that are currently loaded to see if the + * library we want is already loaded. We'll use a loaded library if it * meets any of the following conditions: - * - Its name and file match the once we're looking for. - * - Its file matches, and we weren't given a name. - * - Its name matches, the file name was specified as empty, and there is - * only no statically loaded package with the same name. + * - Its prefix and file match the once we're looking for. + * - Its file matches, and we weren't given a prefix. + * - Its prefix matches, the file name was specified as empty, and there is + * only no statically loaded library with the same prefix. */ Tcl_MutexLock(&libraryMutex); @@ -682,7 +680,7 @@ Tcl_UnloadObjCmd( Tcl_MutexUnlock(&libraryMutex); if (fullFileName[0] == 0) { /* - * It's an error to try unload a static package. + * It's an error to try unload a static library. */ Tcl_SetObjResult(interp, Tcl_ObjPrintf( @@ -707,14 +705,14 @@ Tcl_UnloadObjCmd( } /* - * Scan through the list of packages already loaded in the target - * interpreter. If the package we want is already loaded there, then we + * Scan through the list of libraries already loaded in the target + * interpreter. If the library we want is already loaded there, then we * should proceed with unloading. */ code = TCL_ERROR; if (libraryPtr != NULL) { - ipFirstPtr = (InterpPackage *)Tcl_GetAssocData(target, "tclLoad", NULL); + ipFirstPtr = (InterpLibrary *)Tcl_GetAssocData(target, "tclLoad", NULL); for (ipPtr = ipFirstPtr; ipPtr != NULL; ipPtr = ipPtr->nextPtr) { if (ipPtr->libraryPtr == libraryPtr) { code = TCL_OK; @@ -724,7 +722,7 @@ Tcl_UnloadObjCmd( } if (code != TCL_OK) { /* - * The package has not been loaded in this interpreter. + * The library has not been loaded in this interpreter. */ Tcl_SetObjResult(interp, Tcl_ObjPrintf( @@ -767,7 +765,7 @@ Tcl_UnloadObjCmd( } /* - * We are ready to unload the package. First, evaluate the unload + * We are ready to unload the library. First, evaluate the unload * function. If this fails, we cannot proceed with unload. Also, we must * specify the proper flag to pass to the unload callback. * TCL_UNLOAD_DETACH_FROM_INTERPRETER is defined when the callback should @@ -869,12 +867,12 @@ Tcl_UnloadObjCmd( * Remove this library from the interpreter's library cache. */ - ipFirstPtr = (InterpPackage *)Tcl_GetAssocData(target, "tclLoad", NULL); + ipFirstPtr = (InterpLibrary *)Tcl_GetAssocData(target, "tclLoad", NULL); ipPtr = ipFirstPtr; if (ipPtr->libraryPtr == defaultPtr) { ipFirstPtr = ipFirstPtr->nextPtr; } else { - InterpPackage *ipPrevPtr; + InterpLibrary *ipPrevPtr; for (ipPrevPtr = ipPtr; ipPtr != NULL; ipPrevPtr = ipPtr, ipPtr = ipPtr->nextPtr) { @@ -920,14 +918,14 @@ Tcl_UnloadObjCmd( * * Tcl_StaticLibrary -- * - * This function is invoked to indicate that a particular package has + * This function is invoked to indicate that a particular library has * been linked statically with an application. * * Results: * None. * * Side effects: - * Once this function completes, the package becomes loadable via the + * Once this function completes, the library becomes loadable via the * "load" command with an empty file name. * *---------------------------------------------------------------------- @@ -935,26 +933,26 @@ Tcl_UnloadObjCmd( void Tcl_StaticLibrary( - Tcl_Interp *interp, /* If not NULL, it means that the package has + Tcl_Interp *interp, /* If not NULL, it means that the library has * already been loaded into the given * interpreter by calling the appropriate init * proc. */ const char *prefix, /* Prefix. */ Tcl_PackageInitProc *initProc, /* Function to call to incorporate this - * package into a trusted interpreter. */ + * library into a trusted interpreter. */ Tcl_PackageInitProc *safeInitProc) /* Function to call to incorporate this - * package into a safe interpreter (one that + * library into a safe interpreter (one that * will execute untrusted scripts). NULL means - * the package can't be used in safe + * the library can't be used in safe * interpreters. */ { LoadedLibrary *libraryPtr; - InterpPackage *ipPtr, *ipFirstPtr; + InterpLibrary *ipPtr, *ipFirstPtr; /* - * Check to see if someone else has already reported this package as + * Check to see if someone else has already reported this library as * statically loaded in the process. */ @@ -969,7 +967,7 @@ Tcl_StaticLibrary( Tcl_MutexUnlock(&libraryMutex); /* - * If the package is not yet recorded as being loaded statically, add it + * If the library is not yet recorded as being loaded statically, add it * to the list now. */ @@ -991,11 +989,11 @@ Tcl_StaticLibrary( if (interp != NULL) { /* - * If we're loading the package into an interpreter, determine whether + * If we're loading the library into an interpreter, determine whether * it's already loaded. */ - ipFirstPtr = (InterpPackage *)Tcl_GetAssocData(interp, "tclLoad", NULL); + ipFirstPtr = (InterpLibrary *)Tcl_GetAssocData(interp, "tclLoad", NULL); for (ipPtr = ipFirstPtr; ipPtr != NULL; ipPtr = ipPtr->nextPtr) { if (ipPtr->libraryPtr == libraryPtr) { return; @@ -1003,11 +1001,11 @@ Tcl_StaticLibrary( } /* - * Package isn't loaded in the current interp yet. Mark it as now being + * Lirary isn't loaded in the current interp yet. Mark it as now being * loaded. */ - ipPtr = (InterpPackage *)Tcl_Alloc(sizeof(InterpPackage)); + ipPtr = (InterpLibrary *)Tcl_Alloc(sizeof(InterpLibrary)); ipPtr->libraryPtr = libraryPtr; ipPtr->nextPtr = ipFirstPtr; Tcl_SetAssocData(interp, "tclLoad", LoadCleanupProc, ipPtr); @@ -1027,7 +1025,7 @@ Tcl_StaticLibrary( * list of lists is placed in the interp's result. Each sublist * corresponds to one loaded file; its first element is the name of the * file (or an empty string for something that's statically loaded) and - * the second element is the name of the package in that file. + * the second element is the prefix of the library in that file. * * Side effects: * None. @@ -1043,13 +1041,13 @@ TclGetLoadedLibraries( * NULL, return info about all interps; * otherwise, just return info about this * interpreter. */ - const char *prefix) /* Package name or NULL. If NULL, return info - * for all packages. + const char *prefix) /* Prefix or NULL. If NULL, return info + * for all prefixes. */ { Tcl_Interp *target; LoadedLibrary *libraryPtr; - InterpPackage *ipPtr; + InterpLibrary *ipPtr; Tcl_Obj *resultObj, *pkgDesc[2]; if (targetName == NULL) { @@ -1071,10 +1069,10 @@ TclGetLoadedLibraries( if (target == NULL) { return TCL_ERROR; } - ipPtr = (InterpPackage *)Tcl_GetAssocData(target, "tclLoad", NULL); + ipPtr = (InterpLibrary *)Tcl_GetAssocData(target, "tclLoad", NULL); /* - * Return information about all of the available packages. + * Return information about all of the available libraries. */ if (prefix) { resultObj = NULL; @@ -1095,7 +1093,7 @@ TclGetLoadedLibraries( } /* - * Return information about only the packages that are loaded in a given + * Return information about only the libraries that are loaded in a given * interpreter. */ @@ -1115,7 +1113,7 @@ TclGetLoadedLibraries( * * LoadCleanupProc -- * - * This function is called to delete all of the InterpPackage structures + * This function is called to delete all of the InterpLibrary structures * for an interpreter when the interpreter is deleted. It gets invoked * via the Tcl AssocData mechanism. * @@ -1123,20 +1121,20 @@ TclGetLoadedLibraries( * None. * * Side effects: - * Storage for all of the InterpPackage functions for interp get deleted. + * Storage for all of the InterpLibrary functions for interp get deleted. * *---------------------------------------------------------------------- */ static void LoadCleanupProc( - ClientData clientData, /* Pointer to first InterpPackage structure + ClientData clientData, /* Pointer to first InterpLibrary structure * for interp. */ TCL_UNUSED(Tcl_Interp *)) { - InterpPackage *ipPtr, *nextPtr; + InterpLibrary *ipPtr, *nextPtr; - ipPtr = (InterpPackage *)clientData; + ipPtr = (InterpLibrary *)clientData; while (ipPtr != NULL) { nextPtr = ipPtr->nextPtr; Tcl_Free(ipPtr); diff --git a/tests/load.test b/tests/load.test index eaaf7a7..9bbd510 100644 --- a/tests/load.test +++ b/tests/load.test @@ -56,10 +56,10 @@ test load-1.3 {basic errors} -returnCodes error -body { } -result {could not find interpreter "foobar"} test load-1.4 {basic errors} -returnCodes error -body { load -global {} -} -result {must specify either file name or package name} +} -result {must specify either file name or prefix} test load-1.5 {basic errors} -returnCodes error -body { load -lazy {} {} -} -result {must specify either file name or package name} +} -result {must specify either file name or prefix} test load-1.6 {basic errors} -returnCodes error -body { load {} Unknown } -result {no library with prefix "Unknown" is loaded statically} @@ -68,7 +68,7 @@ test load-1.7 {basic errors} -returnCodes error -body { } -result {bad option "-abc": must be -global, -lazy, or --} test load-1.8 {basic errors} -returnCodes error -body { load -global -} -result {couldn't figure out package name for -global} +} -result {couldn't figure out prefix for -global} test load-2.1 {basic loading, with guess for package name} \ [list $dll $loaded] { @@ -90,7 +90,7 @@ test load-2.3 {loading with no _Init procedure} -constraints [list $dll $loaded] {TCL LOOKUP LOAD_SYMBOL *Foo_Init}] test load-2.4 {loading with no _SafeInit procedure} [list $dll $loaded] { list [catch {load [file join $testDir pkga$ext] {} child} msg] $msg -} {1 {can't use package in a safe interpreter: no Pkga_SafeInit procedure}} +} {1 {can't use library in a safe interpreter: no Pkga_SafeInit procedure}} test load-3.1 {error in _Init procedure, same interpreter} \ [list $dll $loaded] { @@ -128,7 +128,7 @@ test load-4.2 {reloading package into same interpreter} -setup { catch {load [file join $testDir pkga$ext] pkga} } -constraints [list $dll $loaded] -returnCodes error -body { load [file join $testDir pkga$ext] Pkgb -} -result "file \"[file join $testDir pkga$ext]\" is already loaded for package \"Pkga\"" +} -result "file \"[file join $testDir pkga$ext]\" is already loaded for prefix \"Pkga\"" test load-5.1 {file name not specified and no static package: pick default} -setup { catch {interp delete x} @@ -164,7 +164,7 @@ test load-7.2 {Tcl_StaticLibrary procedure} [list teststaticlibrary] { child eval {set x "not loaded"} list [catch {load {} Another child} msg] $msg \ [child eval set x] [set x] -} {1 {can't use package in a safe interpreter: no Another_SafeInit procedure} {not loaded} loaded} +} {1 {can't use library in a safe interpreter: no Another_SafeInit procedure} {not loaded} loaded} test load-7.3 {Tcl_StaticLibrary procedure} [list teststaticlibrary] { set x "not loaded" teststaticlibrary More 0 1 diff --git a/tests/safe.test b/tests/safe.test index 0394eb9..45a0177 100644 --- a/tests/safe.test +++ b/tests/safe.test @@ -1164,7 +1164,7 @@ test safe-10.1 {testing statics loading} -constraints TcltestPackage -setup { interp eval $i {load {} Safepkg1} } -returnCodes error -cleanup { safe::interpDelete $i -} -result {load of binary library for package Safepkg1 failed: can't use package in a safe interpreter: no Safepkg1_SafeInit procedure} +} -result {load of binary library for package Safepkg1 failed: can't use library in a safe interpreter: no Safepkg1_SafeInit procedure} test safe-10.1.1 {testing statics loading} -constraints TcltestPackage -setup { set i [safe::interpCreate] } -body { @@ -1173,7 +1173,7 @@ test safe-10.1.1 {testing statics loading} -constraints TcltestPackage -setup { } -returnCodes ok -cleanup { unset -nocomplain m o safe::interpDelete $i -} -result {load of binary library for package Safepkg1 failed: can't use package in a safe interpreter: no Safepkg1_SafeInit procedure +} -result {load of binary library for package Safepkg1 failed: can't use library in a safe interpreter: no Safepkg1_SafeInit procedure invoked from within "load {} Safepkg1" invoked from within @@ -1196,7 +1196,7 @@ test safe-10.4 {testing nested statics loading / -nestedloadok} -constraints Tcl interp eval $i {interp create x; load {} Safepkg1 x} } -returnCodes error -cleanup { safe::interpDelete $i -} -result {load of binary library for package Safepkg1 failed: can't use package in a safe interpreter: no Safepkg1_SafeInit procedure} +} -result {load of binary library for package Safepkg1 failed: can't use library in a safe interpreter: no Safepkg1_SafeInit procedure} test safe-10.4.1 {testing nested statics loading / -nestedloadok} -constraints TcltestPackage -body { set i [safe::interpCreate -nestedloadok] catch {interp eval $i {interp create x; load {} Safepkg1 x}} m o @@ -1204,7 +1204,7 @@ test safe-10.4.1 {testing nested statics loading / -nestedloadok} -constraints T } -returnCodes ok -cleanup { unset -nocomplain m o safe::interpDelete $i -} -result {load of binary library for package Safepkg1 failed: can't use package in a safe interpreter: no Safepkg1_SafeInit procedure +} -result {load of binary library for package Safepkg1 failed: can't use library in a safe interpreter: no Safepkg1_SafeInit procedure invoked from within "load {} Safepkg1 x" invoked from within diff --git a/tests/unload.test b/tests/unload.test index f1f4580..68cdd13 100644 --- a/tests/unload.test +++ b/tests/unload.test @@ -62,10 +62,10 @@ test unload-1.3 {basic errors} -returnCodes error -body { } -result {could not find interpreter "foobar"} test unload-1.4 {basic errors} -returnCodes error -body { unload {} -} -result {must specify either file name or package name} +} -result {must specify either file name or prefix} test unload-1.5 {basic errors} -returnCodes error -body { unload {} {} -} -result {must specify either file name or package name} +} -result {must specify either file name or prefix} test unload-1.6 {basic errors} -returnCodes error -body { unload {} Unknown } -result {library with prefix "Unknown" is loaded statically and cannot be unloaded} -- cgit v0.12 From da7ec341ce01a8f3499ecb556c739ef4dfa9c6e4 Mon Sep 17 00:00:00 2001 From: bch Date: Thu, 26 Nov 2020 00:30:43 +0000 Subject: grammar --- doc/Tcl.n | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/doc/Tcl.n b/doc/Tcl.n index 48a3488..0f46f73 100644 --- a/doc/Tcl.n +++ b/doc/Tcl.n @@ -224,7 +224,7 @@ is reached. The upper bits of the Unicode character will be 0. .RS .PP The range U+00D800\(enU+00DFFF is reserved for surrogates, which -are illegal on its own. Therefore, such sequences will result in +are illegal on their own. Therefore, such sequences will result in the replacement character U+FFFD. Surrogate pairs should be encoded as single \e\fBU\fIhhhhhhhh\fR character. .RE -- cgit v0.12 From e6d3b1557cc89901800f050c7a8fcc5fe20c99ab Mon Sep 17 00:00:00 2001 From: bch Date: Thu, 26 Nov 2020 00:38:21 +0000 Subject: silence warning re: sign-compare --- generic/tclInt.h | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/generic/tclInt.h b/generic/tclInt.h index 3a759ca..92945ca 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -4854,7 +4854,7 @@ MODULE_SCOPE Tcl_PackageInitProc Procbodytest_SafeInit; (objPtr) = Tcl_NewWideIntObj(w) #define TclNewIndexObj(objPtr, w) \ - (objPtr) = ((w) == TCL_INDEX_NONE) ? Tcl_NewWideIntObj(-1) : Tcl_NewWideIntObj(w) + (objPtr) = (((size_t)w) == TCL_INDEX_NONE) ? Tcl_NewWideIntObj(-1) : Tcl_NewWideIntObj(w) #define TclNewDoubleObj(objPtr, d) \ (objPtr) = Tcl_NewDoubleObj(d) -- cgit v0.12 From 888a59788321731a3060797cac7db475eb6d9028 Mon Sep 17 00:00:00 2001 From: bch Date: Thu, 26 Nov 2020 03:26:05 +0000 Subject: use new TIP 494 64bit/#define in code comment to be consistent w/ code --- generic/tclStringObj.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/generic/tclStringObj.c b/generic/tclStringObj.c index 9f46b9d..1ac0aeb 100644 --- a/generic/tclStringObj.c +++ b/generic/tclStringObj.c @@ -1162,7 +1162,7 @@ Tcl_AppendToObj( const char *bytes, /* Points to the bytes to append to the * object. */ size_t length) /* The number of bytes to append from "bytes". - * If -1, then append all bytes up to NUL + * If TCL_INDEX_NONE, then append all bytes up to NUL * byte. */ { Tcl_AppendLimitedToObj(objPtr, bytes, length, TCL_INDEX_NONE, NULL); -- cgit v0.12 From 5e62e86d4c48da0f90984d1d69a7ecc8160659d7 Mon Sep 17 00:00:00 2001 From: bch Date: Thu, 26 Nov 2020 03:27:15 +0000 Subject: squelch -Wunused warning --- generic/tclExecute.c | 1 + 1 file changed, 1 insertion(+) diff --git a/generic/tclExecute.c b/generic/tclExecute.c index 60f8928..05c1ceb 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -9336,6 +9336,7 @@ EvalStatsCmd( char *litTableStats; LiteralEntry *entryPtr; Tcl_Obj *objPtr; + (void)unused; #define Percent(a,b) ((a) * 100.0 / (b)) -- cgit v0.12 From 4a6876c53700885e4b6c5b9613d59784387c0b82 Mon Sep 17 00:00:00 2001 From: bch Date: Thu, 26 Nov 2020 03:34:47 +0000 Subject: squelch warning by using proper(?) format specifiers; intent needs TBD, so committing to branch for review --- generic/tclExecute.c | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/generic/tclExecute.c b/generic/tclExecute.c index 05c1ceb..466e89e 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -5356,14 +5356,14 @@ TEBCresume( case INST_STR_FIND: objResultPtr = TclStringFirst(OBJ_UNDER_TOS, OBJ_AT_TOS, 0); - TRACE(("%.20s %.20s => %d\n", + TRACE(("%.20s %.20s => %p\n", O2S(OBJ_UNDER_TOS), O2S(OBJ_AT_TOS), O2S(objResultPtr))); NEXT_INST_F(1, 2, 1); case INST_STR_FIND_LAST: objResultPtr = TclStringLast(OBJ_UNDER_TOS, OBJ_AT_TOS, INT_MAX - 1); - TRACE(("%.20s %.20s => %d\n", + TRACE(("%.20s %.20s => %p\n", O2S(OBJ_UNDER_TOS), O2S(OBJ_AT_TOS), O2S(objResultPtr))); NEXT_INST_F(1, 2, 1); -- cgit v0.12 From c53412abcf8c4ce4eb65bde9e5c72d5d5611b5ad Mon Sep 17 00:00:00 2001 From: bch Date: Thu, 26 Nov 2020 03:49:18 +0000 Subject: adjust for() loop controls to squelch sign-compare warning, move maxSizeDecade assignment to maintain identical functionality --- generic/tclExecute.c | 21 ++++++++++++--------- 1 file changed, 12 insertions(+), 9 deletions(-) diff --git a/generic/tclExecute.c b/generic/tclExecute.c index 466e89e..91bcb91 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -9612,12 +9612,13 @@ EvalStatsCmd( break; } } - for (i = 31; i >= 0; i--) { + for (i = 31; i; i--) { if (statsPtr->srcCount[i] > 0) { - maxSizeDecade = i; - break; + break; /* maxSizeDecade to consume 'i' value + * below... */ } } + maxSizeDecade = i; sum = 0; for (i = minSizeDecade; i <= maxSizeDecade; i++) { decadeHigh = (1 << (i+1)) - 1; @@ -9635,12 +9636,13 @@ EvalStatsCmd( break; } } - for (i = 31; i >= 0; i--) { + for (i = 31; i; i--) { if (statsPtr->byteCodeCount[i] > 0) { - maxSizeDecade = i; - break; + break; /* maxSizeDecade to consume 'i' value + * below... */ } } + maxSizeDecade = i; sum = 0; for (i = minSizeDecade; i <= maxSizeDecade; i++) { decadeHigh = (1 << (i+1)) - 1; @@ -9658,12 +9660,13 @@ EvalStatsCmd( break; } } - for (i = 31; i >= 0; i--) { + for (i = 31; i; i--) { if (statsPtr->lifetimeCount[i] > 0) { - maxSizeDecade = i; - break; + break; /* maxSizeDecade to consume 'i' value + * below... */ } } + maxSizeDecade = i; sum = 0; for (i = minSizeDecade; i <= maxSizeDecade; i++) { decadeHigh = (1 << (i+1)) - 1; -- cgit v0.12 From 42b1424fc5d7d2f09ff77fa4b4a30da726e45627 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 27 Nov 2020 11:28:03 +0000 Subject: Fix compilation error --- generic/tclExecute.c | 1 - 1 file changed, 1 deletion(-) diff --git a/generic/tclExecute.c b/generic/tclExecute.c index 32d6458..910a751 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -9336,7 +9336,6 @@ EvalStatsCmd( char *litTableStats; LiteralEntry *entryPtr; Tcl_Obj *objPtr; - (void)unused; #define Percent(a,b) ((a) * 100.0 / (b)) -- cgit v0.12 From cc7d39873fa40c42eeca9a655fa579c3feb54ab5 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Sat, 5 Dec 2020 11:28:33 +0000 Subject: Add -fextended-identifiers option to unix/dltest makefile --- unix/dltest/Makefile.in | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/unix/dltest/Makefile.in b/unix/dltest/Makefile.in index 09b496d..fdd3e98 100644 --- a/unix/dltest/Makefile.in +++ b/unix/dltest/Makefile.in @@ -33,7 +33,7 @@ dltest_suffix: pkgπ${DLTEST_SUFFIX} pkga${DLTEST_SUFFIX} pkgb${DLTEST_SUFFIX} p @touch ../dltest.marker pkgπ.o: $(SRC_DIR)/pkgπ.c - $(CC) -c $(CC_SWITCHES) $(SRC_DIR)/pkgπ.c + $(CC) -c $(CC_SWITCHES) -fextended-identifiers $(SRC_DIR)/pkgπ.c pkga.o: $(SRC_DIR)/pkga.c $(CC) -c $(CC_SWITCHES) $(SRC_DIR)/pkga.c -- cgit v0.12 From 3f62bdc438a97dd70b557b9c95c73ad9cddac1f6 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Sun, 6 Dec 2020 13:47:42 +0000 Subject: Add -finput-charset=UTF-8 to CFLAGS --- unix/configure | 4 ++-- unix/dltest/Makefile.in | 2 +- unix/tcl.m4 | 4 ++-- 3 files changed, 5 insertions(+), 5 deletions(-) diff --git a/unix/configure b/unix/configure index 3dc88a1..4a91811 100755 --- a/unix/configure +++ b/unix/configure @@ -5027,12 +5027,12 @@ fi if test "$GCC" = yes; then : CFLAGS_OPTIMIZE=-O2 - CFLAGS_WARNING="-Wall -Wextra -Wshadow -Wundef -Wwrite-strings -Wpointer-arith" + CFLAGS_WARNING="-Wall -Wextra -Wshadow -Wundef -Wwrite-strings -Wpointer-arith -finput-charset=UTF-8" case "${CC}" in *++|*++-*) ;; *) - CFLAGS_WARNING="${CFLAGS_WARNING} -Wc++-compat -Wdeclaration-after-statement" + CFLAGS_WARNING="${CFLAGS_WARNING} -Wc++-compat -fextended-identifiers -Wdeclaration-after-statement" ;; esac diff --git a/unix/dltest/Makefile.in b/unix/dltest/Makefile.in index fdd3e98..09b496d 100644 --- a/unix/dltest/Makefile.in +++ b/unix/dltest/Makefile.in @@ -33,7 +33,7 @@ dltest_suffix: pkgπ${DLTEST_SUFFIX} pkga${DLTEST_SUFFIX} pkgb${DLTEST_SUFFIX} p @touch ../dltest.marker pkgπ.o: $(SRC_DIR)/pkgπ.c - $(CC) -c $(CC_SWITCHES) -fextended-identifiers $(SRC_DIR)/pkgπ.c + $(CC) -c $(CC_SWITCHES) $(SRC_DIR)/pkgπ.c pkga.o: $(SRC_DIR)/pkga.c $(CC) -c $(CC_SWITCHES) $(SRC_DIR)/pkga.c diff --git a/unix/tcl.m4 b/unix/tcl.m4 index 930f381..695588d 100644 --- a/unix/tcl.m4 +++ b/unix/tcl.m4 @@ -958,12 +958,12 @@ AC_DEFUN([SC_CONFIG_CFLAGS], [ CFLAGS_DEBUG=-g AS_IF([test "$GCC" = yes], [ CFLAGS_OPTIMIZE=-O2 - CFLAGS_WARNING="-Wall -Wextra -Wshadow -Wundef -Wwrite-strings -Wpointer-arith" + CFLAGS_WARNING="-Wall -Wextra -Wshadow -Wundef -Wwrite-strings -Wpointer-arith -finput-charset=UTF-8" case "${CC}" in *++|*++-*) ;; *) - CFLAGS_WARNING="${CFLAGS_WARNING} -Wc++-compat -Wdeclaration-after-statement" + CFLAGS_WARNING="${CFLAGS_WARNING} -Wc++-compat -fextended-identifiers -Wdeclaration-after-statement" ;; esac -- cgit v0.12 From c9c1696a2d8c2c3d094e54b96defd269c0687692 Mon Sep 17 00:00:00 2001 From: bch Date: Sun, 6 Dec 2020 18:39:21 +0000 Subject: allow NULL for indexPtr to say "am not interested in index, just membership in set of possibilities" for Tcl_GetIndexFromObj() --- doc/GetIndex.3 | 8 ++++---- generic/tclIndexObj.c | 31 ++++++++++++++++++------------- 2 files changed, 22 insertions(+), 17 deletions(-) diff --git a/doc/GetIndex.3 b/doc/GetIndex.3 index 8591c56..111ae62 100644 --- a/doc/GetIndex.3 +++ b/doc/GetIndex.3 @@ -56,8 +56,8 @@ OR-ed combination of bits providing additional information for operation. The only bits that are currently defined are \fBTCL_EXACT\fR and \fBTCL_INDEX_TEMP_TABLE\fR. .AP int *indexPtr out -The index of the string in \fItablePtr\fR that matches the value of -\fIobjPtr\fR is returned here. +If not NULL, the index of the string in \fItablePtr\fR that matches +the value of \fIobjPtr\fR is returned here. .BE .SH DESCRIPTION .PP @@ -70,8 +70,8 @@ the strings in \fItablePtr\fR to find a match. A match occurs if \fItablePtr\fR, or if it is a non-empty unique abbreviation for exactly one of the strings in \fItablePtr\fR and the \fBTCL_EXACT\fR flag was not specified; in either case -the index of the matching entry is stored at \fI*indexPtr\fR -and \fBTCL_OK\fR is returned. +\fBTCL_OK\fR is returned. If \fI*indexPtr\fR is not NULL the index +of the matching entry is stored there. .PP If there is no matching entry, \fBTCL_ERROR\fR is returned and an error message is left in \fIinterp\fR's diff --git a/generic/tclIndexObj.c b/generic/tclIndexObj.c index 89582b7..c3092c9 100644 --- a/generic/tclIndexObj.c +++ b/generic/tclIndexObj.c @@ -166,11 +166,12 @@ GetIndexFromObjList( * Results: * If the value of objPtr is identical to or a unique abbreviation for * one of the entries in tablePtr, then the return value is TCL_OK and - * the index of the matching entry is stored at *indexPtr. If there isn't - * a proper match, then TCL_ERROR is returned and an error message is - * left in interp's result (unless interp is NULL). The msg argument is - * used in the error message; for example, if msg has the value "option" - * then the error message will say something like 'bad option "foo": must + * the index of the matching entry is stored at *indexPtr + * (unless indexPtr is NULL). If there isn't a proper match, then + * TCL_ERROR is returned and an error message is left in interp's + * result (unless interp is NULL). The msg argument is used in the + * error message; for example, if msg has the value "option" then + * the error message will say something like 'bad option "foo": must * be ...' * * Side effects: @@ -212,15 +213,17 @@ Tcl_GetIndexFromObjStruct( */ if (!(flags & TCL_INDEX_TEMP_TABLE)) { - irPtr = TclFetchIntRep(objPtr, &indexType); - if (irPtr) { - indexRep = (IndexRep *)irPtr->twoPtrValue.ptr1; - if (indexRep->tablePtr==tablePtr && indexRep->offset==offset) { - *indexPtr = indexRep->index; - return TCL_OK; + irPtr = TclFetchIntRep (objPtr, &indexType); + if (irPtr) { + indexRep = (IndexRep *) irPtr->twoPtrValue.ptr1; + if (indexRep->tablePtr == tablePtr && indexRep->offset == offset) { + if (indexPtr != NULL) { + *indexPtr = indexRep->index; + } + return TCL_OK; + } } } - } /* * Lookup the value of the object in the table. Accept unique @@ -291,7 +294,9 @@ Tcl_GetIndexFromObjStruct( indexRep->index = index; } - *indexPtr = index; + if(indexPtr != NULL) { + *indexPtr = index; + } return TCL_OK; error: -- cgit v0.12 From 902547c2b25bc92a576879d666aaf79c6e635aab Mon Sep 17 00:00:00 2001 From: bch Date: Sun, 6 Dec 2020 20:57:32 +0000 Subject: comment grammar --- generic/tcl.decls | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/generic/tcl.decls b/generic/tcl.decls index dc57324..eacfb28 100644 --- a/generic/tcl.decls +++ b/generic/tcl.decls @@ -24,8 +24,8 @@ hooks {tclPlat tclInt tclIntPlat} scspec EXTERN # Declare each of the functions in the public Tcl interface. Note that -# the an index should never be reused for a different function in order -# to preserve backwards compatibility. +# in order to preserve backwards compatibility an index should +# never be reused for a different function declare 0 { int Tcl_PkgProvideEx(Tcl_Interp *interp, const char *name, -- cgit v0.12 From 933584b14430d2c9df09702eb344ff261bd40776 Mon Sep 17 00:00:00 2001 From: bch Date: Sun, 6 Dec 2020 20:58:21 +0000 Subject: Period. --- generic/tcl.decls | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/generic/tcl.decls b/generic/tcl.decls index eacfb28..4362c4c 100644 --- a/generic/tcl.decls +++ b/generic/tcl.decls @@ -25,7 +25,7 @@ scspec EXTERN # Declare each of the functions in the public Tcl interface. Note that # in order to preserve backwards compatibility an index should -# never be reused for a different function +# never be reused for a different function. declare 0 { int Tcl_PkgProvideEx(Tcl_Interp *interp, const char *name, -- cgit v0.12 From 567b79ea315fea66d4c49ecae05c9d37f9cdf175 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 7 Dec 2020 09:16:19 +0000 Subject: Use \u???? syntax in identifiers, to make it work with gcc too --- "unix/dltest/pkg\317\200.c" | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git "a/unix/dltest/pkg\317\200.c" "b/unix/dltest/pkg\317\200.c" index faeaa46..81078fa 100644 --- "a/unix/dltest/pkg\317\200.c" +++ "b/unix/dltest/pkg\317\200.c" @@ -17,7 +17,7 @@ * Prototypes for procedures defined later in this file: */ -static int Pkgπ_ΠObjCmd(ClientData clientData, +static int Pkg\u03C0_\u03A0ObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); /* @@ -39,7 +39,7 @@ static int Pkgπ_ΠObjCmd(ClientData clientData, */ static int -Pkgπ_ΠObjCmd( +Pkg\u03C0_\u03A0ObjCmd( void *dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ @@ -77,7 +77,7 @@ Pkgπ_ΠObjCmd( */ DLLEXPORT int -Pkgπ_Init( +Pkg\u03C0_Init( Tcl_Interp *interp) /* Interpreter in which the package is to be * made available. */ { @@ -90,6 +90,6 @@ Pkgπ_Init( if (code != TCL_OK) { return code; } - Tcl_CreateObjCommand(interp, "π", Pkgπ_ΠObjCmd, NULL, NULL); + Tcl_CreateObjCommand(interp, "π", Pkg\u03C0_\u03A0ObjCmd, NULL, NULL); return TCL_OK; } -- cgit v0.12 From c42695035ce9433fed4856709e9acb518a4979ac Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 7 Dec 2020 09:21:31 +0000 Subject: =?UTF-8?q?=C2=A9?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- unix/dltest/pkga.c | 2 +- unix/dltest/pkgb.c | 2 +- unix/dltest/pkgc.c | 2 +- unix/dltest/pkgd.c | 2 +- unix/dltest/pkge.c | 2 +- unix/dltest/pkgooa.c | 2 +- unix/dltest/pkgua.c | 4 ++-- "unix/dltest/pkg\317\200.c" | 2 +- 8 files changed, 9 insertions(+), 9 deletions(-) diff --git a/unix/dltest/pkga.c b/unix/dltest/pkga.c index c2d814f..e00f996 100644 --- a/unix/dltest/pkga.c +++ b/unix/dltest/pkga.c @@ -4,7 +4,7 @@ * This file contains a simple Tcl package "pkga" that is intended for * testing the Tcl dynamic loading facilities. * - * Copyright (c) 1995 Sun Microsystems, Inc. + * Copyright © 1995 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. diff --git a/unix/dltest/pkgb.c b/unix/dltest/pkgb.c index 741b2a1..3210669 100644 --- a/unix/dltest/pkgb.c +++ b/unix/dltest/pkgb.c @@ -5,7 +5,7 @@ * testing the Tcl dynamic loading facilities. It can be used in both * safe and unsafe interpreters. * - * Copyright (c) 1995 Sun Microsystems, Inc. + * Copyright © 1995 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. diff --git a/unix/dltest/pkgc.c b/unix/dltest/pkgc.c index 46f6e86..2b46986 100644 --- a/unix/dltest/pkgc.c +++ b/unix/dltest/pkgc.c @@ -5,7 +5,7 @@ * testing the Tcl dynamic loading facilities. It can be used in both * safe and unsafe interpreters. * - * Copyright (c) 1995 Sun Microsystems, Inc. + * Copyright © 1995 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. diff --git a/unix/dltest/pkgd.c b/unix/dltest/pkgd.c index d3af83f..5c799f5 100644 --- a/unix/dltest/pkgd.c +++ b/unix/dltest/pkgd.c @@ -5,7 +5,7 @@ * testing the Tcl dynamic loading facilities. It can be used in both * safe and unsafe interpreters. * - * Copyright (c) 1995 Sun Microsystems, Inc. + * Copyright © 1995 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. diff --git a/unix/dltest/pkge.c b/unix/dltest/pkge.c index f46ca74..26a4b79 100644 --- a/unix/dltest/pkge.c +++ b/unix/dltest/pkge.c @@ -5,7 +5,7 @@ * testing the Tcl dynamic loading facilities. Its Init procedure returns * an error in order to test how this is handled. * - * Copyright (c) 1995 Sun Microsystems, Inc. + * Copyright © 1995 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. diff --git a/unix/dltest/pkgooa.c b/unix/dltest/pkgooa.c index 7d0c98b..ff1cf1f 100644 --- a/unix/dltest/pkgooa.c +++ b/unix/dltest/pkgooa.c @@ -4,7 +4,7 @@ * This file contains a simple Tcl package "pkgooa" that is intended for * testing the Tcl dynamic loading facilities. * - * Copyright (c) 1995 Sun Microsystems, Inc. + * Copyright © 1995 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. diff --git a/unix/dltest/pkgua.c b/unix/dltest/pkgua.c index c5102a8..0ab3e23 100644 --- a/unix/dltest/pkgua.c +++ b/unix/dltest/pkgua.c @@ -4,8 +4,8 @@ * This file contains a simple Tcl package "pkgua" that is intended for * testing the Tcl dynamic unloading facilities. * - * Copyright (c) 1995 Sun Microsystems, Inc. - * Copyright (c) 2004 Georgios Petasis + * Copyright © 1995 Sun Microsystems, Inc. + * Copyright © 2004 Georgios Petasis * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. diff --git "a/unix/dltest/pkg\317\200.c" "b/unix/dltest/pkg\317\200.c" index 81078fa..1cf95cf 100644 --- "a/unix/dltest/pkg\317\200.c" +++ "b/unix/dltest/pkg\317\200.c" @@ -4,7 +4,7 @@ * This file contains a simple Tcl package "pkgπ" that is intended for * testing the Tcl dynamic loading facilities. * - * Copyright (c) 1995 Sun Microsystems, Inc. + * Copyright © 1995 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. -- cgit v0.12 From 165061b1c46cae8e6c6f05714d9135c7c3d2395b Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 9 Dec 2020 09:55:19 +0000 Subject: Fix github actions Windows build --- .github/workflows/win-build.yml | 1 - win/makefile.vc | 6 ++++-- 2 files changed, 4 insertions(+), 3 deletions(-) diff --git a/.github/workflows/win-build.yml b/.github/workflows/win-build.yml index 341f7ca..5148a47 100644 --- a/.github/workflows/win-build.yml +++ b/.github/workflows/win-build.yml @@ -56,7 +56,6 @@ jobs: - "--disable-shared" - "--enable-symbols" - "--enable-symbols=mem" - - "CC=g++" # Using powershell means we need to explicitly stop on failure steps: - name: Checkout diff --git a/win/makefile.vc b/win/makefile.vc index 394bd13..2e3a080 100644 --- a/win/makefile.vc +++ b/win/makefile.vc @@ -587,8 +587,10 @@ $(LIBTCLZIP): .PHONY @move /y "$(LIBTCLVFS)\tcl_library\manifest.txt" "$(LIBTCLVFS)\tcl_library\pkgIndex.tcl" > NUL !if ! $(STATIC_BUILD) # Remove the registry and dde directories as the DLLS are still external - @$(RMDIR) "$(LIBTCLVFS)\tcl_library\registry" - @$(RMDIR) "$(LIBTCLVFS)\tcl_library\dde" + @del "$(LIBTCLVFS)\tcl_library\registry\pkgIndex.tcl" + @rmdir "$(LIBTCLVFS)\tcl_library\registry" + @del "$(LIBTCLVFS)\tcl_library\dde\pkgIndex.tcl" + @rmdir "$(LIBTCLVFS)\tcl_library\dde" !endif @echo file delete -force {$@} > "$(OUT_DIR)\zipper.tcl" @echo zipfs mkzip {$@} {$(LIBTCLVFS)} {$(LIBTCLVFS)} >> "$(OUT_DIR)\zipper.tcl" -- cgit v0.12 From ec714e1d4fe3c39ba19520dbf55debd3ac26cbae Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 10 Dec 2020 10:33:41 +0000 Subject: Tweak error-message --- library/safe.tcl | 24 ++++++++++++------------ tests/safe.test | 32 ++++++++++++++++---------------- 2 files changed, 28 insertions(+), 28 deletions(-) diff --git a/library/safe.tcl b/library/safe.tcl index e7760f8..9f2d007 100644 --- a/library/safe.tcl +++ b/library/safe.tcl @@ -1009,8 +1009,8 @@ proc ::safe::AliasLoad {child file args} { return -code error $msg } - # package name (can be empty if file is not). - set package [lindex $args 0] + # prefix (can be empty if file is not). + set prefix [lindex $args 0] namespace upvar ::safe [VarName $child] state @@ -1022,23 +1022,23 @@ proc ::safe::AliasLoad {child file args} { # authorize that. if {!$state(nestedok)} { Log $child "loading to a sub interp (nestedok)\ - disabled (trying to load $package to $target)" + disabled (trying to load $prefix to $target)" return -code error "permission denied (nested load)" } } # Determine what kind of load is requested if {$file eq ""} { - # static package loading - if {$package eq ""} { - set msg "load error: empty filename and no package name" + # static loading + if {$prefix eq ""} { + set msg "load error: empty filename and no prefix" Log $child $msg return -code error $msg } if {!$state(staticsok)} { - Log $child "static packages loading disabled\ - (trying to load $package to $target)" - return -code error "permission denied (static package)" + Log $child "static library loading disabled\ + (trying to load $prefix to $target)" + return -code error "permission denied (static library)" } } else { # file loading @@ -1061,10 +1061,10 @@ proc ::safe::AliasLoad {child file args} { } try { - return [::interp invokehidden $child load $file $package $target] + return [::interp invokehidden $child load $file $prefix $target] } on error msg { - # Some packages return no error message. - set msg0 "load of binary library for package $package failed" + # Some libraries return no error message. + set msg0 "load of binary library with prefix $prefix failed" if {$msg eq {}} { set msg $msg0 } else { diff --git a/tests/safe.test b/tests/safe.test index 454d670..ffc005c 100644 --- a/tests/safe.test +++ b/tests/safe.test @@ -1157,58 +1157,58 @@ test safe-9.24 {interpConfigure change the access path; check module loading; st res0 res1 res2} # See comments on lsort after test safe-9.20. -catch {teststaticlibrary Safepkg1 0 0} +catch {teststaticlibrary Safe1 0 0} test safe-10.1 {testing statics loading} -constraints tcl::test -setup { set i [safe::interpCreate] } -body { - interp eval $i {load {} Safepkg1} + interp eval $i {load {} Safe1} } -returnCodes error -cleanup { safe::interpDelete $i -} -result {load of binary library for package Safepkg1 failed: can't use library in a safe interpreter: no Safepkg1_SafeInit procedure} +} -result {load of binary library with prefix Safe1 failed: can't use library in a safe interpreter: no Safe1_SafeInit procedure} test safe-10.1.1 {testing statics loading} -constraints tcl::test -setup { set i [safe::interpCreate] } -body { - catch {interp eval $i {load {} Safepkg1}} m o + catch {interp eval $i {load {} Safe1}} m o dict get $o -errorinfo } -returnCodes ok -cleanup { unset -nocomplain m o safe::interpDelete $i -} -result {load of binary library for package Safepkg1 failed: can't use library in a safe interpreter: no Safepkg1_SafeInit procedure +} -result {load of binary library with prefix Safe1 failed: can't use library in a safe interpreter: no Safe1_SafeInit procedure invoked from within -"load {} Safepkg1" +"load {} Safe1" invoked from within -"interp eval $i {load {} Safepkg1}"} +"interp eval $i {load {} Safe1}"} test safe-10.2 {testing statics loading / -nostatics} -constraints tcl::test -body { set i [safe::interpCreate -nostatics] - interp eval $i {load {} Safepkg1} + interp eval $i {load {} Safe1} } -returnCodes error -cleanup { safe::interpDelete $i -} -result {permission denied (static package)} +} -result {permission denied (static library)} test safe-10.3 {testing nested statics loading / no nested by default} -setup { set i [safe::interpCreate] } -constraints tcl::test -body { - interp eval $i {interp create x; load {} Safepkg1 x} + interp eval $i {interp create x; load {} Safe1 x} } -returnCodes error -cleanup { safe::interpDelete $i } -result {permission denied (nested load)} test safe-10.4 {testing nested statics loading / -nestedloadok} -constraints tcl::test -body { set i [safe::interpCreate -nestedloadok] - interp eval $i {interp create x; load {} Safepkg1 x} + interp eval $i {interp create x; load {} Safe1 x} } -returnCodes error -cleanup { safe::interpDelete $i -} -result {load of binary library for package Safepkg1 failed: can't use library in a safe interpreter: no Safepkg1_SafeInit procedure} +} -result {load of binary library with prefix Safe1 failed: can't use library in a safe interpreter: no Safe1_SafeInit procedure} test safe-10.4.1 {testing nested statics loading / -nestedloadok} -constraints tcl::test -body { set i [safe::interpCreate -nestedloadok] - catch {interp eval $i {interp create x; load {} Safepkg1 x}} m o + catch {interp eval $i {interp create x; load {} Safe1 x}} m o dict get $o -errorinfo } -returnCodes ok -cleanup { unset -nocomplain m o safe::interpDelete $i -} -result {load of binary library for package Safepkg1 failed: can't use library in a safe interpreter: no Safepkg1_SafeInit procedure +} -result {load of binary library with prefix Safe1 failed: can't use library in a safe interpreter: no Safe1_SafeInit procedure invoked from within -"load {} Safepkg1 x" +"load {} Safe1 x" invoked from within -"interp eval $i {interp create x; load {} Safepkg1 x}"} +"interp eval $i {interp create x; load {} Safe1 x}"} test safe-11.1 {testing safe encoding} -setup { set i [safe::interpCreate] -- cgit v0.12 From 8abb212fb655d173a547e5e2dced0a3865e4fc6f Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 11 Jan 2021 15:58:39 +0000 Subject: Make tclStrToD.c compile on systems without inttypes.h --- generic/tclStrToD.c | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/generic/tclStrToD.c b/generic/tclStrToD.c index c0a8a65..92902da4 100644 --- a/generic/tclStrToD.c +++ b/generic/tclStrToD.c @@ -22,6 +22,11 @@ #define copysign _copysign #endif +#ifndef PRIx64 +# define PRIx64 TCL_LL_MODIFIER "x" +#endif + + /* * This code supports (at least hypothetically), IBM, Cray, VAX and IEEE-754 * floating point; of these, only IEEE-754 can represent NaN. IEEE-754 can be -- cgit v0.12 From 9e0e24e95304e0dc8d8f1ba93adf0af8b702f940 Mon Sep 17 00:00:00 2001 From: msi Date: Tue, 19 Jan 2021 20:57:04 +0000 Subject: Improve clarity of [file attributes] documentation --- doc/file.n | 33 ++++++++++++++++++--------------- 1 file changed, 18 insertions(+), 15 deletions(-) diff --git a/doc/file.n b/doc/file.n index 292c3b8..43eee9b 100644 --- a/doc/file.n +++ b/doc/file.n @@ -45,21 +45,24 @@ specific option. The third form sets one or more of the values. The values are as follows: .RS .PP -On Unix, \fB\-group\fR gets or sets the group name for the file. A group id -can be given to the command, but it returns a group name. \fB\-owner\fR gets -or sets the user name of the owner of the file. The command returns the -owner name, but the numerical id can be passed when setting the -owner. \fB\-permissions\fR sets or retrieves the octal code that chmod(1) -uses. This option also provides limited support for setting permissions -using the symbolic notation used by the Unix chmod(1) command, following the -form [ugo]?[[+-=][rwxst],[...]]. Multiple permission specifications may be -given, separated by commas. E.g., \fBu+s,go-rw\fR would set the setuid bit -for a file's owner as well as remove read and write permission for the file's -group and other users. A simplified \fBls\fR style string, of the form -rwxrwxrwx (must be 9 characters), is also supported (example: -\fBrwxr\-xr\-t\fR is equivalent to 01755). On versions of Unix supporting -file flags, \fB\-readonly\fR gives the value or sets or clears the readonly -attribute of the file, i.e. the user immutable flag \fBuchg\fR to chflags(1). +On Unix, \fB\-group\fR gets or sets the group name for the file. A +group id can be given to the command, but it returns a group name. +\fB\-owner\fR gets or sets the user name of the owner of the file. The +command returns the owner name, but the numerical id can be passed when +setting the owner. \fB\-permissions\fR retrieves or sets a file's access +permissions, using octal notation by default. This option also provides +limited support for setting permissions using the symbolic notation +accepted by the \fBchmod\fR command, following the form +[\fBugo\fR]?[[\fB+-=\fR][\fBrwxst\fR]\fB,\fR[...]]. Multiple permission +specifications may be given, separated by commas. E.g., \fBu+s,go-rw\fR +would set the setuid bit for a file's owner as well as remove read and +write permission for the file's group and other users. An +\fBls\fR-style string of the form \fBrwxrwxrwx\fR is also accepted but +must always be 9 characters long. E.g., \fBrwxr-xr-t\fR is equivalent to +\fB01755\fR. On versions of Unix supporting file flags, \fB-readonly\fR +returns the value of, or sets, or clears the readonly attribute of a +file, i.e., the user immutable flag (\fBuchg\fR) to the \fBchflags\fR +command. .PP On Windows, \fB\-archive\fR gives the value or sets or clears the archive attribute of the file. \fB\-hidden\fR gives the value or sets -- cgit v0.12 From 1edbb06e02d1a83129944d6860f3519dc5c579e4 Mon Sep 17 00:00:00 2001 From: msi Date: Wed, 20 Jan 2021 23:05:44 +0000 Subject: Improve [file attributes] documentation --- doc/file.n | 28 ++++++++++++++-------------- 1 file changed, 14 insertions(+), 14 deletions(-) diff --git a/doc/file.n b/doc/file.n index 43eee9b..c5a5eed 100644 --- a/doc/file.n +++ b/doc/file.n @@ -38,31 +38,31 @@ generated. On Windows, FAT file systems do not support access time. .TP \fBfile attributes \fIname\fR ?\fIoption value option value...\fR? . -This subcommand returns or sets platform specific values associated -with a file. The first form returns a list of the platform specific -flags and their values. The second form returns the value for the -specific option. The third form sets one or more of the values. The -values are as follows: +This subcommand returns or sets platform-specific values associated +with a file. The first form returns a list of the platform-specific +options and their values. The second form returns the value for the +given option. The third form sets one or more of the values. The values +are as follows: .RS .PP On Unix, \fB\-group\fR gets or sets the group name for the file. A group id can be given to the command, but it returns a group name. \fB\-owner\fR gets or sets the user name of the owner of the file. The command returns the owner name, but the numerical id can be passed when -setting the owner. \fB\-permissions\fR retrieves or sets a file's access -permissions, using octal notation by default. This option also provides -limited support for setting permissions using the symbolic notation -accepted by the \fBchmod\fR command, following the form +setting the owner. \fB\-permissions\fR retrieves or sets a file's +access permissions, using octal notation by default. This option also +provides limited support for setting permissions using the symbolic +notation accepted by the \fBchmod\fR command, following the form [\fBugo\fR]?[[\fB+-=\fR][\fBrwxst\fR]\fB,\fR[...]]. Multiple permission specifications may be given, separated by commas. E.g., \fBu+s,go-rw\fR would set the setuid bit for a file's owner as well as remove read and write permission for the file's group and other users. An \fBls\fR-style string of the form \fBrwxrwxrwx\fR is also accepted but -must always be 9 characters long. E.g., \fBrwxr-xr-t\fR is equivalent to -\fB01755\fR. On versions of Unix supporting file flags, \fB-readonly\fR -returns the value of, or sets, or clears the readonly attribute of a -file, i.e., the user immutable flag (\fBuchg\fR) to the \fBchflags\fR -command. +must always be 9 characters long. E.g., \fBrwxr-xr-t\fR is equivalent +to \fB01755\fR. On versions of Unix supporting file flags, +\fB-readonly\fR returns the value of, or sets, or clears the readonly +attribute of a file, i.e., the user immutable flag (\fBuchg\fR) to the +\fBchflags\fR command. .PP On Windows, \fB\-archive\fR gives the value or sets or clears the archive attribute of the file. \fB\-hidden\fR gives the value or sets -- cgit v0.12 From adae2dcc7ca1c9e8162356b4263e4bb77b083091 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 22 Jan 2021 15:31:42 +0000 Subject: Undo (for now) removal of TclMacOSXNotifierAddRunLoopMode(), we don't want an earlier compiled Tk to crash. Just wait some time, until everyone uses a newer Tk 8.7, using Tcl_MacOSXNotifierAddRunLoopMode() --- generic/tclInt.decls | 7 +++---- generic/tclIntPlatDecls.h | 19 +++++++++++++------ generic/tclStubInit.c | 5 +++-- 3 files changed, 19 insertions(+), 12 deletions(-) diff --git a/generic/tclInt.decls b/generic/tclInt.decls index add705b..303492e 100644 --- a/generic/tclInt.decls +++ b/generic/tclInt.decls @@ -1317,10 +1317,9 @@ declare 18 {unix macosx} { const char *fileName, Tcl_StatBuf *statBufPtr, Tcl_GlobTypeData *types) } -# Removed in 9.0: -#declare 19 {unix macosx} { -# void TclMacOSXNotifierAddRunLoopMode(const void *runLoopMode) -#} +declare 19 {unix macosx} { + void TclMacOSXNotifierAddRunLoopMode(const void *runLoopMode) +} declare 22 {unix macosx} { TclFile TclpCreateTempFile_(const char *contents) } diff --git a/generic/tclIntPlatDecls.h b/generic/tclIntPlatDecls.h index b45f25d..bc6a7e3 100644 --- a/generic/tclIntPlatDecls.h +++ b/generic/tclIntPlatDecls.h @@ -92,7 +92,9 @@ EXTERN int TclMacOSXMatchType(Tcl_Interp *interp, const char *pathName, const char *fileName, Tcl_StatBuf *statBufPtr, Tcl_GlobTypeData *types); -/* Slot 19 is reserved */ +/* 19 */ +EXTERN void TclMacOSXNotifierAddRunLoopMode( + const void *runLoopMode); /* Slot 20 is reserved */ /* Slot 21 is reserved */ /* 22 */ @@ -224,7 +226,9 @@ EXTERN int TclMacOSXMatchType(Tcl_Interp *interp, const char *pathName, const char *fileName, Tcl_StatBuf *statBufPtr, Tcl_GlobTypeData *types); -/* Slot 19 is reserved */ +/* 19 */ +EXTERN void TclMacOSXNotifierAddRunLoopMode( + const void *runLoopMode); /* Slot 20 is reserved */ /* Slot 21 is reserved */ /* 22 */ @@ -267,7 +271,7 @@ typedef struct TclIntPlatStubs { int (*tclMacOSXSetFileAttribute) (Tcl_Interp *interp, int objIndex, Tcl_Obj *fileName, Tcl_Obj *attributePtr); /* 16 */ int (*tclMacOSXCopyFileAttributes) (const char *src, const char *dst, const Tcl_StatBuf *statBufPtr); /* 17 */ int (*tclMacOSXMatchType) (Tcl_Interp *interp, const char *pathName, const char *fileName, Tcl_StatBuf *statBufPtr, Tcl_GlobTypeData *types); /* 18 */ - void (*reserved19)(void); + void (*tclMacOSXNotifierAddRunLoopMode) (const void *runLoopMode); /* 19 */ void (*reserved20)(void); void (*reserved21)(void); TclFile (*tclpCreateTempFile_) (const char *contents); /* 22 */ @@ -333,7 +337,7 @@ typedef struct TclIntPlatStubs { int (*tclMacOSXSetFileAttribute) (Tcl_Interp *interp, int objIndex, Tcl_Obj *fileName, Tcl_Obj *attributePtr); /* 16 */ int (*tclMacOSXCopyFileAttributes) (const char *src, const char *dst, const Tcl_StatBuf *statBufPtr); /* 17 */ int (*tclMacOSXMatchType) (Tcl_Interp *interp, const char *pathName, const char *fileName, Tcl_StatBuf *statBufPtr, Tcl_GlobTypeData *types); /* 18 */ - void (*reserved19)(void); + void (*tclMacOSXNotifierAddRunLoopMode) (const void *runLoopMode); /* 19 */ void (*reserved20)(void); void (*reserved21)(void); TclFile (*tclpCreateTempFile_) (const char *contents); /* 22 */ @@ -395,7 +399,8 @@ extern const TclIntPlatStubs *tclIntPlatStubsPtr; (tclIntPlatStubsPtr->tclMacOSXCopyFileAttributes) /* 17 */ #define TclMacOSXMatchType \ (tclIntPlatStubsPtr->tclMacOSXMatchType) /* 18 */ -/* Slot 19 is reserved */ +#define TclMacOSXNotifierAddRunLoopMode \ + (tclIntPlatStubsPtr->tclMacOSXNotifierAddRunLoopMode) /* 19 */ /* Slot 20 is reserved */ /* Slot 21 is reserved */ #define TclpCreateTempFile_ \ @@ -498,7 +503,8 @@ extern const TclIntPlatStubs *tclIntPlatStubsPtr; (tclIntPlatStubsPtr->tclMacOSXCopyFileAttributes) /* 17 */ #define TclMacOSXMatchType \ (tclIntPlatStubsPtr->tclMacOSXMatchType) /* 18 */ -/* Slot 19 is reserved */ +#define TclMacOSXNotifierAddRunLoopMode \ + (tclIntPlatStubsPtr->tclMacOSXNotifierAddRunLoopMode) /* 19 */ /* Slot 20 is reserved */ /* Slot 21 is reserved */ #define TclpCreateTempFile_ \ @@ -525,6 +531,7 @@ extern const TclIntPlatStubs *tclIntPlatStubsPtr; #undef TclpCreateTempFile_ #undef TclUnixWaitForFile_ +#undef TclMacOSXNotifierAddRunLoopMode #ifndef MAC_OSX_TCL /* not accessable on Win32/UNIX */ #undef TclMacOSXGetFileAttribute /* 15 */ #undef TclMacOSXSetFileAttribute /* 16 */ diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c index 51d0a38..577c05a 100644 --- a/generic/tclStubInit.c +++ b/generic/tclStubInit.c @@ -154,6 +154,7 @@ static void uniCodePanic() { # define Tcl_MacOSXOpenVersionedBundleResources 0 # define Tcl_MacOSXNotifierAddRunLoopMode 0 #endif +#define TclMacOSXNotifierAddRunLoopMode Tcl_MacOSXNotifierAddRunLoopMode #ifdef _WIN32 # define Tcl_CreateFileHandler 0 # define Tcl_DeleteFileHandler 0 @@ -564,7 +565,7 @@ static const TclIntPlatStubs tclIntPlatStubs = { TclMacOSXSetFileAttribute, /* 16 */ TclMacOSXCopyFileAttributes, /* 17 */ TclMacOSXMatchType, /* 18 */ - 0, /* 19 */ + TclMacOSXNotifierAddRunLoopMode, /* 19 */ 0, /* 20 */ 0, /* 21 */ TclpCreateTempFile_, /* 22 */ @@ -630,7 +631,7 @@ static const TclIntPlatStubs tclIntPlatStubs = { TclMacOSXSetFileAttribute, /* 16 */ TclMacOSXCopyFileAttributes, /* 17 */ TclMacOSXMatchType, /* 18 */ - 0, /* 19 */ + TclMacOSXNotifierAddRunLoopMode, /* 19 */ 0, /* 20 */ 0, /* 21 */ TclpCreateTempFile_, /* 22 */ -- cgit v0.12 From 634ebe7c6db3115dea3f52b3aaebbe8542313ce7 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 25 Jan 2021 10:04:49 +0000 Subject: Remove many commented-out sections of tclInt.decls: Since Tcl 9.0 doesn't need to be binary compatible with Tcl 8.7, it doesn't matter any more. And we have fossil for that. --- generic/tclInt.decls | 601 +-------------------------------------------------- 1 file changed, 1 insertion(+), 600 deletions(-) diff --git a/generic/tclInt.decls b/generic/tclInt.decls index 303492e..9eb9a71 100644 --- a/generic/tclInt.decls +++ b/generic/tclInt.decls @@ -23,23 +23,9 @@ interface tclInt # Use at your own risk. Note that the position of functions should not # be changed between versions to avoid gratuitous incompatibilities. -# Replaced by Tcl_FSAccess in 8.4: -#declare 0 { -# int TclAccess(const char *path, int mode) -#} -#declare 1 { -# int TclAccessDeleteProc(TclAccessProc_ *proc) -#} -#declare 2 { -# int TclAccessInsertProc(TclAccessProc_ *proc) -#} declare 3 { void TclAllocateFreeObjects(void) } -# Replaced by TclpChdir in 8.1: -# declare 4 { -# int TclChdir(Tcl_Interp *interp, char *dirName) -# } declare 5 { int TclCleanupChildren(Tcl_Interp *interp, int numPids, Tcl_Pid *pidPtr, Tcl_Channel errorChan) @@ -50,14 +36,7 @@ declare 6 { declare 7 { size_t TclCopyAndCollapse(size_t count, const char *src, char *dst) } -# Removed in 9.0: -#declare 8 { -# int TclCopyChannelOld(Tcl_Interp *interp, Tcl_Channel inChan, -# Tcl_Channel outChan, int toRead, Tcl_Obj *cmdPtr) -#} - # TclCreatePipeline unofficially exported for use by BLT. - declare 9 { int TclCreatePipeline(Tcl_Interp *interp, int argc, const char **argv, Tcl_Pid **pidArrayPtr, TclFile *inPipePtr, TclFile *outPipePtr, @@ -74,37 +53,12 @@ declare 11 { declare 12 { void TclDeleteVars(Interp *iPtr, TclVarHashTable *tablePtr) } -# Removed in 8.5: -#declare 13 { -# int TclDoGlob(Tcl_Interp *interp, char *separators, -# Tcl_DString *headPtr, char *tail, Tcl_GlobTypeData *types) -#} declare 14 { int TclDumpMemoryInfo(void *clientData, int flags) } -# Removed in 8.1: -# declare 15 { -# void TclExpandParseValue(ParseValue *pvPtr, int needed) -# } declare 16 { void TclExprFloatError(Tcl_Interp *interp, double value) } -# Removed in 8.4: -#declare 17 { -# int TclFileAttrsCmd(Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) -#} -#declare 18 { -# int TclFileCopyCmd(Tcl_Interp *interp, int argc, char **argv) -#} -#declare 19 { -# int TclFileDeleteCmd(Tcl_Interp *interp, int argc, char **argv) -#} -#declare 20 { -# int TclFileMakeDirsCmd(Tcl_Interp *interp, int argc, char **argv) -#} -#declare 21 { -# int TclFileRenameCmd(Tcl_Interp *interp, int argc, char **argv) -#} declare 22 { int TclFindElement(Tcl_Interp *interp, const char *listStr, int listLength, const char **elementPtr, const char **nextPtr, @@ -120,27 +74,9 @@ declare 24 { declare 25 { void TclFreePackageInfo(Interp *iPtr) } -# Removed in 8.1: -# declare 26 { -# char *TclGetCwd(Tcl_Interp *interp) -# } -# Removed in 8.5: -#declare 27 { -# int TclGetDate(char *p, unsigned long now, long zone, -# unsigned long *timePtr) -#} declare 28 { Tcl_Channel TclpGetDefaultStdChannel(int type) } -# Removed in 8.4b2: -#declare 29 { -# Tcl_Obj *TclGetElementOfIndexedArray(Tcl_Interp *interp, -# int localIndex, Tcl_Obj *elemPtr, int flags) -#} -# Replaced by char *TclGetEnv(const char *name, Tcl_DString *valuePtr) in 8.1: -# declare 30 { -# char *TclGetEnv(const char *name) -# } declare 31 { const char *TclGetExtension(const char *name) } @@ -148,28 +84,6 @@ declare 32 { int TclGetFrame(Tcl_Interp *interp, const char *str, CallFrame **framePtrPtr) } -# Removed in 8.5: -#declare 33 { -# TclCmdProcType TclGetInterpProc(void) -#} -# Removed in 9.0: -#declare 34 {deprecated {Use Tcl_GetIntForIndex}} { -# int TclGetIntForIndex(Tcl_Interp *interp, Tcl_Obj *objPtr, -# int endValue, int *indexPtr) -#} -# Removed in 8.4b2: -#declare 35 { -# Tcl_Obj *TclGetIndexedScalar(Tcl_Interp *interp, int localIndex, -# int flags) -#} -# Removed in 8.6a2: -#declare 36 { -# int TclGetLong(Tcl_Interp *interp, const char *str, long *longPtr) -#} -# Removed in 9.0: -#declare 37 { -# int TclGetLoadedPackages(Tcl_Interp *interp, const char *targetName) -#} declare 38 { int TclGetNamespaceForQualName(Tcl_Interp *interp, const char *qualName, Namespace *cxtNsPtr, int flags, Namespace **nsPtrPtr, @@ -188,48 +102,15 @@ declare 41 { declare 42 { const char *TclpGetUserHome(const char *name, Tcl_DString *bufferPtr) } -# Removed in 8.5a2: -#declare 43 { -# int TclGlobalInvoke(Tcl_Interp *interp, int argc, const char **argv, -# int flags) -#} -# Removed in 9.0: -#declare 44 { -# int TclGuessPackageName(const char *fileName, Tcl_DString *bufPtr) -#} declare 45 { int TclHideUnsafeCommands(Tcl_Interp *interp) } declare 46 { int TclInExit(void) } -# Removed in 8.4b2: -#declare 47 { -# Tcl_Obj *TclIncrElementOfIndexedArray(Tcl_Interp *interp, -# int localIndex, Tcl_Obj *elemPtr, long incrAmount) -#} -# Removed in 8.4b2: -#declare 48 { -# Tcl_Obj *TclIncrIndexedScalar(Tcl_Interp *interp, int localIndex, -# long incrAmount) -#} -#declare 49 { -# Tcl_Obj *TclIncrVar2(Tcl_Interp *interp, Tcl_Obj *part1Ptr, -# Tcl_Obj *part2Ptr, long incrAmount, int part1NotParsed) -#} -# Removed in 9.0: -#declare 50 { -# void TclInitCompiledLocals(Tcl_Interp *interp, CallFrame *framePtr, -# Namespace *nsPtr) -#} declare 51 { int TclInterpInit(Tcl_Interp *interp) } -# Removed in 8.5a2: -#declare 52 { -# int TclInvoke(Tcl_Interp *interp, int argc, const char **argv, -# int flags) -#} declare 53 { int TclInvokeObjectCommand(void *clientData, Tcl_Interp *interp, int argc, const char **argv) @@ -241,26 +122,11 @@ declare 54 { declare 55 { Proc *TclIsProc(Command *cmdPtr) } -# Replaced with TclpLoadFile in 8.1: -# declare 56 { -# int TclLoadFile(Tcl_Interp *interp, char *fileName, char *sym1, -# char *sym2, Tcl_PackageInitProc **proc1Ptr, -# Tcl_PackageInitProc **proc2Ptr) -# } -# Signature changed to take a length in 8.1: -# declare 57 { -# int TclLooksLikeInt(char *p) -# } declare 58 { Var *TclLookupVar(Tcl_Interp *interp, const char *part1, const char *part2, int flags, const char *msg, int createPart1, int createPart2, Var **arrayPtrPtr) } -# Replaced by Tcl_FSMatchInDirectory in 8.4 -#declare 59 { -# int TclpMatchFiles(Tcl_Interp *interp, char *separators, -# Tcl_DString *dirPtr, char *pattern, char *tail) -#} declare 60 { int TclNeedSpace(const char *start, const char *end) } @@ -278,37 +144,9 @@ declare 64 { int TclObjInvoke(Tcl_Interp *interp, int objc, Tcl_Obj *const objv[], int flags) } -# Removed in 8.5a2: -#declare 65 { -# int TclObjInvokeGlobal(Tcl_Interp *interp, int objc, -# Tcl_Obj *const objv[], int flags) -#} -#declare 66 { -# int TclOpenFileChannelDeleteProc(TclOpenFileChannelProc_ *proc) -#} -#declare 67 { -# int TclOpenFileChannelInsertProc(TclOpenFileChannelProc_ *proc) -#} -# Replaced by Tcl_FSAccess in 8.4: -#declare 68 { -# int TclpAccess(const char *path, int mode) -#} declare 69 { void *TclpAlloc(size_t size) } -#declare 70 { -# int TclpCopyFile(const char *source, const char *dest) -#} -#declare 71 { -# int TclpCopyDirectory(const char *source, const char *dest, -# Tcl_DString *errorPtr) -#} -#declare 72 { -# int TclpCreateDirectory(const char *path) -#} -#declare 73 { -# int TclpDeleteFile(const char *path) -#} declare 74 { void TclpFree(void *ptr) } @@ -318,63 +156,13 @@ declare 75 { declare 76 { Tcl_WideUInt TclpGetSeconds(void) } - -# Removed in 9.0: -#declare 77 { -# void TclpGetTime(Tcl_Time *time) -#} -# Removed in 8.6: -#declare 78 { -# int TclpGetTimeZone(unsigned long time) -#} -# Replaced by Tcl_FSListVolumes in 8.4: -#declare 79 { -# int TclpListVolumes(Tcl_Interp *interp) -#} -# Replaced by Tcl_FSOpenFileChannel in 8.4: -#declare 80 { -# Tcl_Channel TclpOpenFileChannel(Tcl_Interp *interp, char *fileName, -# char *modeString, int permissions) -#} declare 81 { void *TclpRealloc(void *ptr, size_t size) } -#declare 82 { -# int TclpRemoveDirectory(const char *path, int recursive, -# Tcl_DString *errorPtr) -#} -#declare 83 { -# int TclpRenameFile(const char *source, const char *dest) -#} -# Removed in 8.1: -# declare 84 { -# int TclParseBraces(Tcl_Interp *interp, char *str, char **termPtr, -# ParseValue *pvPtr) -# } -# declare 85 { -# int TclParseNestedCmd(Tcl_Interp *interp, char *str, int flags, -# char **termPtr, ParseValue *pvPtr) -# } -# declare 86 { -# int TclParseQuotes(Tcl_Interp *interp, char *str, int termChar, -# int flags, char **termPtr, ParseValue *pvPtr) -# } -# declare 87 { -# void TclPlatformInit(Tcl_Interp *interp) -# } -# Removed in 9.0: -#declare 88 { -# char *TclPrecTraceProc(void *clientData, Tcl_Interp *interp, -# const char *name1, const char *name2, int flags) -#} declare 89 { int TclPreventAliasLoop(Tcl_Interp *interp, Tcl_Interp *cmdInterp, Tcl_Command cmd) } -# Removed in 8.1 (only available if compiled with TCL_COMPILE_DEBUG): -# declare 90 { -# void TclPrintByteCodeObj(Tcl_Interp *interp, Tcl_Obj *objPtr) -# } declare 91 { void TclProcCleanupProc(Proc *procPtr) } @@ -386,15 +174,6 @@ declare 92 { declare 93 { void TclProcDeleteProc(void *clientData) } -# Removed in 8.5: -#declare 94 { -# int TclProcInterpProc(void *clientData, Tcl_Interp *interp, -# int argc, const char **argv) -#} -# Replaced by Tcl_FSStat in 8.4: -#declare 95 { -# int TclpStat(const char *path, Tcl_StatBuf *buf) -#} declare 96 { int TclRenameCommand(Tcl_Interp *interp, const char *oldName, const char *newName) @@ -405,16 +184,6 @@ declare 97 { declare 98 { int TclServiceIdle(void) } -# Removed in 8.4b2: -#declare 99 { -# Tcl_Obj *TclSetElementOfIndexedArray(Tcl_Interp *interp, int localIndex, -# Tcl_Obj *elemPtr, Tcl_Obj *objPtr, int flags) -#} -# Removed in 8.4b2: -#declare 100 { -# Tcl_Obj *TclSetIndexedScalar(Tcl_Interp *interp, int localIndex, -# Tcl_Obj *objPtr, int flags) -#} declare 101 { const char *TclSetPreInitScript(const char *string) } @@ -425,20 +194,6 @@ declare 103 { int TclSockGetPort(Tcl_Interp *interp, const char *str, const char *proto, int *portPtr) } -# Removed in 9.0: -#declare 104 { -# int TclSockMinimumBuffersOld(int sock, int size) -#} -# Replaced by Tcl_FSStat in 8.4: -#declare 105 { -# int TclStat(const char *path, Tcl_StatBuf *buf) -#} -#declare 106 { -# int TclStatDeleteProc(TclStatProc_ *proc) -#} -#declare 107 { -# int TclStatInsertProc(TclStatProc_ *proc) -#} declare 108 { void TclTeardownNamespace(Namespace *nsPtr) } @@ -461,35 +216,6 @@ declare 111 { Tcl_ResolveCmdProc *cmdProc, Tcl_ResolveVarProc *varProc, Tcl_ResolveCompiledVarProc *compiledVarProc) } -# Removed in 9.0: -#declare 112 { -# int Tcl_AppendExportList(Tcl_Interp *interp, Tcl_Namespace *nsPtr, -# Tcl_Obj *objPtr) -#} -# Removed in 9.0: -#declare 113 { -# Tcl_Namespace *Tcl_CreateNamespace(Tcl_Interp *interp, const char *name, -# void *clientData, Tcl_NamespaceDeleteProc *deleteProc) -#} -# Removed in 9.0: -#declare 114 { -# void Tcl_DeleteNamespace(Tcl_Namespace *nsPtr) -#} -# Removed in 9.0: -#declare 115 { -# int Tcl_Export(Tcl_Interp *interp, Tcl_Namespace *nsPtr, -# const char *pattern, int resetListFirst) -#} -# Removed in 9.0: -#declare 116 { -# Tcl_Command Tcl_FindCommand(Tcl_Interp *interp, const char *name, -# Tcl_Namespace *contextNsPtr, int flags) -#} -# Removed in 9.0: -#declare 117 { -# Tcl_Namespace *Tcl_FindNamespace(Tcl_Interp *interp, const char *name, -# Tcl_Namespace *contextNsPtr, int flags) -#} declare 118 { int Tcl_GetInterpResolvers(Tcl_Interp *interp, const char *name, Tcl_ResolverInfo *resInfo) @@ -502,37 +228,10 @@ declare 120 { Tcl_Var Tcl_FindNamespaceVar(Tcl_Interp *interp, const char *name, Tcl_Namespace *contextNsPtr, int flags) } -# Removed in 9.0: -#declare 121 { -# int Tcl_ForgetImport(Tcl_Interp *interp, Tcl_Namespace *nsPtr, -# const char *pattern) -#} -# Removed in 9.0: -#declare 122 { -# Tcl_Command Tcl_GetCommandFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr) -#} -# Removed in 9.0: -#declare 123 { -# void Tcl_GetCommandFullName(Tcl_Interp *interp, Tcl_Command command, -# Tcl_Obj *objPtr) -#} -# Removed in 9.0: -#declare 124 { -# Tcl_Namespace *Tcl_GetCurrentNamespace(Tcl_Interp *interp) -#} -# Removed in 9.0: -#declare 125 { -# Tcl_Namespace *Tcl_GetGlobalNamespace(Tcl_Interp *interp) -#} declare 126 { void Tcl_GetVariableFullName(Tcl_Interp *interp, Tcl_Var variable, Tcl_Obj *objPtr) } -# Removed in 9.0: -#declare 127 { -# int Tcl_Import(Tcl_Interp *interp, Tcl_Namespace *nsPtr, -# const char *pattern, int allowOverwrite) -#} declare 128 { void Tcl_PopCallFrame(Tcl_Interp *interp) } @@ -551,35 +250,9 @@ declare 131 { declare 132 { int TclpHasSockets(Tcl_Interp *interp) } -# Removed in 9.0 -#declare 133 { -# struct tm *TclpGetDate(const time_t *time, int useGMT) -#} -# Removed in 8.5 -#declare 134 { -# size_t TclpStrftime(char *s, size_t maxsize, const char *format, -# const struct tm *t, int useGMT) -#} -#declare 135 { -# int TclpCheckStackSpace(void) -#} - -# Added in 8.1: - -#declare 137 { -# int TclpChdir(const char *dirName) -#} declare 138 { const char *TclGetEnv(const char *name, Tcl_DString *valuePtr) } -#declare 139 { -# int TclpLoadFile(Tcl_Interp *interp, char *fileName, char *sym1, -# char *sym2, Tcl_PackageInitProc **proc1Ptr, -# Tcl_PackageInitProc **proc2Ptr, void **clientDataPtr) -#} -#declare 140 { -# int TclLooksLikeInt(const char *bytes, int length) -#} # This is used by TclX, but should otherwise be considered private declare 141 { const char *TclpGetCwd(Tcl_Interp *interp, Tcl_DString *cwdPtr) @@ -611,9 +284,6 @@ declare 148 { declare 149 { void TclHandleRelease(TclHandle handle) } - -# Added for Tcl 8.2 - declare 150 { int TclRegAbout(Tcl_Interp *interp, Tcl_RegExp re) } @@ -627,17 +297,6 @@ declare 152 { declare 153 { Tcl_Obj *TclGetLibraryPath(void) } - -# moved to tclTest.c (static) in 8.3.2/8.4a2 -#declare 154 { -# int TclTestChannelCmd(void *clientData, -# Tcl_Interp *interp, int argc, char **argv) -#} -#declare 155 { -# int TclTestChannelEventCmd(void *clientData, -# Tcl_Interp *interp, int argc, char **argv) -#} - declare 156 { void TclRegError(Tcl_Interp *interp, const char *msg, int status) @@ -645,21 +304,6 @@ declare 156 { declare 157 { Var *TclVarTraceExists(Tcl_Interp *interp, const char *varName) } -# REMOVED - use public Tcl_SetStartupScript() -#declare 158 { -# void TclSetStartupScriptFileName(const char *filename) -#} -# REMOVED - use public Tcl_GetStartupScript() -#declare 159 { -# const char *TclGetStartupScriptFileName(void) -#} -#declare 160 { -# int TclpMatchFilesTypes(Tcl_Interp *interp, char *separators, -# Tcl_DString *dirPtr, char *pattern, char *tail, -# GlobTypeData *types) -#} - -# new in 8.3.2/8.4a2 declare 161 { int TclChannelTransform(Tcl_Interp *interp, Tcl_Channel chan, Tcl_Obj *cmdObjPtr) @@ -696,15 +340,6 @@ declare 166 { int index, Tcl_Obj *valuePtr) } -# VFS-aware versions of Tcl*StartupScriptFileName (158 and 159 above) -# REMOVED - use public Tcl_SetStartupScript() -#declare 167 { -# void TclSetStartupScriptPath(Tcl_Obj *pathPtr) -#} -# REMOVED - use public Tcl_GetStartupScript() -#declare 168 { -# Tcl_Obj *TclGetStartupScriptPath(void) -#} # variant of Tcl_UtfNCmp that takes n as bytes, not chars declare 169 { int TclpUtfNcmp2(const char *s1, const char *s2, size_t n) @@ -722,23 +357,10 @@ declare 171 { declare 172 { int TclInThreadExit(void) } - -# added for 8.4.2 - declare 173 { int TclUniCharMatch(const Tcl_UniChar *string, size_t strLen, const Tcl_UniChar *pattern, size_t ptnLen, int flags) } - -# added for 8.4.3 - -#declare 174 { -# Tcl_Obj *TclIncrWideVar2(Tcl_Interp *interp, Tcl_Obj *part1Ptr, -# Tcl_Obj *part2Ptr, Tcl_WideInt wideIncrAmount, int part1NotParsed) -#} - -# Factoring out of trace code - declare 175 { int TclCallVarTraces(Interp *iPtr, Var *arrayPtr, Var *varPtr, const char *part1, const char *part2, int flags, int leaveErrMsg) @@ -750,95 +372,10 @@ declare 177 { void TclVarErrMsg(Tcl_Interp *interp, const char *part1, const char *part2, const char *operation, const char *reason) } -# TIP 338 made these public - now declared in tcl.h -#declare 178 { -# void Tcl_SetStartupScript(Tcl_Obj *pathPtr, const char *encodingName) -#} -#declare 179 { -# Tcl_Obj *Tcl_GetStartupScript(const char **encodingNamePtr) -#} - -# REMOVED -# Allocate lists without copying arrays -# declare 180 { -# Tcl_Obj *TclNewListObjDirect(int objc, Tcl_Obj **objv) -# } -#declare 181 { -# Tcl_Obj *TclDbNewListObjDirect(int objc, Tcl_Obj **objv, -# const char *file, int line) -#} - -# Removed in 9.0 -#declare 182 { -# struct tm *TclpLocaltime(const time_t *clock) -#} -# Removed in 9.0 -#declare 183 { -# struct tm *TclpGmtime(const time_t *clock) -#} - -# For the new "Thread Storage" subsystem. - -### REMOVED on grounds it should never have been exposed. All these -### functions are now either static in tclThreadStorage.c or -### MODULE_SCOPE. -# declare 184 { -# void TclThreadStorageLockInit(void) -# } -# declare 185 { -# void TclThreadStorageLock(void) -# } -# declare 186 { -# void TclThreadStorageUnlock(void) -# } -# declare 187 { -# void TclThreadStoragePrint(FILE *outFile, int flags) -# } -# declare 188 { -# Tcl_HashTable *TclThreadStorageGetHashTable(Tcl_ThreadId id) -# } -# declare 189 { -# Tcl_HashTable *TclThreadStorageInit(Tcl_ThreadId id, void *reserved) -# } -# declare 190 { -# void TclThreadStorageDataKeyInit(Tcl_ThreadDataKey *keyPtr) -# } -# declare 191 { -# void *TclThreadStorageDataKeyGet(Tcl_ThreadDataKey *keyPtr) -# } -# declare 192 { -# void TclThreadStorageDataKeySet(Tcl_ThreadDataKey *keyPtr, void *data) -# } -# declare 193 { -# void TclFinalizeThreadStorageThread(Tcl_ThreadId id) -# } -# declare 194 { -# void TclFinalizeThreadStorage(void) -# } -# declare 195 { -# void TclFinalizeThreadStorageData(Tcl_ThreadDataKey *keyPtr) -# } -# declare 196 { -# void TclFinalizeThreadStorageDataKey(Tcl_ThreadDataKey *keyPtr) -# } - -# -# Added in tcl8.5a5 for compiler/executor experimentation. -# Disabled in Tcl 8.5.1; experiments terminated. :/ -# -#declare 197 { -# int TclCompEvalObj(Tcl_Interp *interp, Tcl_Obj *objPtr, -# const CmdFrame *invoker, int word) -#} declare 198 { int TclObjGetFrame(Tcl_Interp *interp, Tcl_Obj *objPtr, CallFrame **framePtrPtr) } - -#declare 199 { -# int TclMatchIsTrivial(const char *pattern) -#} - # 200-208 exported for use by the test suite [Bug 1054748] declare 200 { int TclpObjRemoveDirectory(Tcl_Obj *pathPtr, int recursive, @@ -870,16 +407,6 @@ declare 208 { Tcl_Channel TclpOpenFileChannel(Tcl_Interp *interp, Tcl_Obj *pathPtr, int mode, int permissions) } -# Made public by TIP 258 -#declare 209 { -# Tcl_Obj *TclGetEncodingSearchPath(void) -#} -#declare 210 { -# int TclSetEncodingSearchPath(Tcl_Obj *searchPath) -#} -#declare 211 { -# const char *TclpGetEncodingNameFromEnvironment(Tcl_DString *bufPtr) -#} declare 212 { void TclpFindExecutable(const char *argv0) } @@ -907,8 +434,6 @@ declare 218 { declare 224 { TclPlatformType *TclGetPlatform(void) } - -# declare 225 { Tcl_Obj *TclTraceDictPath(Tcl_Interp *interp, Tcl_Obj *rootPtr, int keyc, Tcl_Obj *const keyv[], int flags) @@ -920,12 +445,6 @@ declare 227 { void TclSetNsPath(Namespace *nsPtr, size_t pathLength, Tcl_Namespace *pathAry[]) } -# Used to be needed for TclOO-extension; unneeded now that TclOO is in the -# core and NRE-enabled -# declare 228 { -# int TclObjInterpProcCore(Tcl_Interp *interp, Tcl_Obj *procNameObj, -# int skip, ProcErrorProc *errorProc) -# } declare 229 { int TclPtrMakeUpvar(Tcl_Interp *interp, Var *otherP1Ptr, const char *myName, int myFlags, int index) @@ -948,7 +467,6 @@ declare 232 { declare 233 { void TclGetSrcInfoForPc(CmdFrame *contextPtr) } - # Exports for VarReform compat: Itcl, XOTcl like to peek into our varTables :( declare 234 { Var *TclVarHashCreateVar(TclVarHashTable *tablePtr, const char *key, @@ -957,18 +475,10 @@ declare 234 { declare 235 { void TclInitVarHashTable(TclVarHashTable *tablePtr, Namespace *nsPtr) } - - -# TIP 337 made this one public -#declare 236 { -# void TclBackgroundException(Tcl_Interp *interp, int code) -#} - # TIP #285: Script cancellation support. declare 237 { int TclResetCancellation(Tcl_Interp *interp, int force) } - # NRE functions for "rogue" extensions to exploit NRE; they will need to # include NRE.h too. declare 238 { @@ -1057,6 +567,7 @@ declare 256 { int TclPtrUnsetVar(Tcl_Interp *interp, Tcl_Var varPtr, Tcl_Var arrayPtr, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, const int flags) } + declare 257 { void TclStaticPackage(Tcl_Interp *interp, const char *pkgName, Tcl_PackageInitProc *initProc, Tcl_PackageInitProc *safeInitProc) @@ -1077,7 +588,6 @@ declare 260 { unsigned char *TclGetBytesFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr, size_t *lengthPtr) } - ############################################################################## @@ -1092,58 +602,15 @@ interface tclIntPlat declare 0 win { void TclWinConvertError(int errCode) } -# Removed in 9.0: -#declare 1 win { -# void TclWinConvertWSAError(int errCode) -#} -# Removed in 9.0: -#declare 2 win { -# struct servent *TclWinGetServByName(const char *nm, -# const char *proto) -#} -# Removed in 9.0: -#declare 3 win { -# int TclWinGetSockOpt(SOCKET s, int level, int optname, -# char *optval, int *optlen) -#} declare 4 win { void *TclWinGetTclInstance(void) } -# new for 8.4.20+/8.5.12+ Cygwin only declare 5 win { int TclUnixWaitForFile(int fd, int mask, int timeout) } -# Removed in 8.1: -# declare 5 win { -# HINSTANCE TclWinLoadLibrary(char *name) -# } -# Removed in 9.0: -#declare 6 win { -# unsigned short TclWinNToHS(unsigned short ns) -#} -# Removed in 9.0: -#declare 7 win { -# int TclWinSetSockOpt(SOCKET s, int level, int optname, -# const char *optval, int optlen) -#} declare 8 win { size_t TclpGetPid(Tcl_Pid pid) } -# Removed in 9.0: -#declare 9 win { -# int TclWinGetPlatformId(void) -#} -# Removed in 9.0: -#declare 10 win { -# Tcl_DirEntry *TclpReaddir(TclDIR *dir) -#} -# Removed in 8.3.1 (for Win32s only): -#declare 10 win { -# int TclWinSynchSpawn(void *args, int type, void **trans, Tcl_Pid *pidPtr) -#} - -# Pipe channel functions - declare 11 win { void TclGetAndDetachPids(Tcl_Interp *interp, Tcl_Channel chan) } @@ -1162,18 +629,9 @@ declare 15 win { const char **argv, TclFile inputFile, TclFile outputFile, TclFile errorFile, Tcl_Pid *pidPtr) } -# new for 8.4.20+/8.5.12+ Cygwin only declare 16 win { int TclpIsAtty(int fd) } -# Signature changed in 8.1: -# declare 16 win { -# TclFile TclpCreateTempFile(char *contents, Tcl_DString *namePtr) -# } -# declare 17 win { -# char *TclpGetTZName(void) -# } -# new for 8.5.12+ Cygwin only declare 17 win { int TclUnixCopyFile(const char *src, const char *dst, const Tcl_StatBuf *statBufPtr, int dontCopyAtts) @@ -1187,48 +645,16 @@ declare 19 win { declare 20 win { void TclWinAddProcess(void *hProcess, size_t id) } -# Removed in 9.0: -#declare 21 win { -# char *TclpInetNtoa(struct in_addr addr) -#} -# removed permanently for 8.4 -#declare 21 win { -# void TclpAsyncMark(Tcl_AsyncHandler async) -#} - -# Added in 8.1: declare 22 win { TclFile TclpCreateTempFile(const char *contents) } -# Removed in 8.6: -#declare 23 win { -# char *TclpGetTZName(int isdst) -#} declare 24 win { char *TclWinNoBackslash(char *path) } -# replaced by generic TclGetPlatform -#declare 25 win { -# TclPlatformType *TclWinGetPlatform(void) -#} -# Removed in 9.0: -#declare 26 win { -# void TclWinSetInterfaces(int wide) -#} - -# Added in Tcl 8.3.3 / 8.4 - declare 27 win { void TclWinFlushDirtyChannels(void) } -# Added in 8.4.2 - -# Removed in 9.0: -#declare 28 win { -# void TclWinResetInterfaces(void) -#} - ################################ # Unix specific functions @@ -1264,34 +690,9 @@ declare 7 unix { declare 8 unix { int TclUnixWaitForFile(int fd, int mask, int timeout) } - -# Added in 8.1: - declare 9 unix { TclFile TclpCreateTempFile(const char *contents) } - -# Added in 8.4: - -# Removed in 9.0: -#declare 10 unix { -# Tcl_DirEntry *TclpReaddir(TclDIR *dir) -#} -# Removed in 9.0: -#declare 11 unix { -# struct tm *TclpLocaltime_unix(const time_t *clock) -#} -# Removed in 9.0: -#declare 12 unix { -# struct tm *TclpGmtime_unix(const time_t *clock) -#} -# Removed in 9.0: -#declare 13 unix { -# char *TclpInetNtoa(struct in_addr addr) -#} - -# Added in 8.5: - declare 14 unix { int TclUnixCopyFile(const char *src, const char *dst, const Tcl_StatBuf *statBufPtr, int dontCopyAtts) -- cgit v0.12 From b7af5cca11d2d8d1a1950ad09ddbc47d4fa1c3fc Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 25 Jan 2021 15:20:16 +0000 Subject: Remove 4 (internal, MacOS-specific) functions from internal stub table, MODULE_SCOPE should be sufficient for those. Move other internal stub-entries around, all still binary compatible) --- generic/tclInt.decls | 36 +++---- generic/tclIntPlatDecls.h | 238 ++++++++++++++++++++++------------------------ generic/tclStubInit.c | 50 +++++----- 3 files changed, 154 insertions(+), 170 deletions(-) diff --git a/generic/tclInt.decls b/generic/tclInt.decls index 9eb9a71..59104cc 100644 --- a/generic/tclInt.decls +++ b/generic/tclInt.decls @@ -661,13 +661,13 @@ declare 27 win { # Pipe channel functions declare 0 unix { - void TclGetAndDetachPids(Tcl_Interp *interp, Tcl_Channel chan) + void TclGetAndDetachPids_(Tcl_Interp *interp, Tcl_Channel chan) } declare 1 unix { int TclpCloseFile(TclFile file) } declare 2 unix { - Tcl_Channel TclpCreateCommandChannel(TclFile readFile, + Tcl_Channel TclpCreateCommandChannel_(TclFile readFile, TclFile writeFile, TclFile errorFile, int numPids, Tcl_Pid *pidPtr) } declare 3 unix { @@ -679,7 +679,7 @@ declare 4 unix { TclFile errorFile, Tcl_Pid *pidPtr) } declare 5 unix { - int TclUnixWaitForFile_(int fd, int mask, int timeout) + int TclUnixWaitForFile(int fd, int mask, int timeout) } declare 6 unix { TclFile TclpMakeFile(Tcl_Channel channel, int direction) @@ -688,10 +688,17 @@ declare 7 unix { TclFile TclpOpenFile(const char *fname, int mode) } declare 8 unix { - int TclUnixWaitForFile(int fd, int mask, int timeout) + int TclUnixWaitForFile_(int fd, int mask, int timeout) } declare 9 unix { - TclFile TclpCreateTempFile(const char *contents) + TclFile TclpCreateTempFile_(const char *contents) +} +declare 11 unix { + void TclGetAndDetachPids(Tcl_Interp *interp, Tcl_Channel chan) +} +declare 13 unix { + Tcl_Channel TclpCreateCommandChannel(TclFile readFile, + TclFile writeFile, TclFile errorFile, int numPids, Tcl_Pid *pidPtr) } declare 14 unix { int TclUnixCopyFile(const char *src, const char *dst, @@ -701,28 +708,11 @@ declare 14 unix { ################################ # Mac OS X specific functions -declare 15 {unix macosx} { - int TclMacOSXGetFileAttribute(Tcl_Interp *interp, int objIndex, - Tcl_Obj *fileName, Tcl_Obj **attributePtrPtr) -} -declare 16 {unix macosx} { - int TclMacOSXSetFileAttribute(Tcl_Interp *interp, int objIndex, - Tcl_Obj *fileName, Tcl_Obj *attributePtr) -} -declare 17 {unix macosx} { - int TclMacOSXCopyFileAttributes(const char *src, const char *dst, - const Tcl_StatBuf *statBufPtr) -} -declare 18 {unix macosx} { - int TclMacOSXMatchType(Tcl_Interp *interp, const char *pathName, - const char *fileName, Tcl_StatBuf *statBufPtr, - Tcl_GlobTypeData *types) -} declare 19 {unix macosx} { void TclMacOSXNotifierAddRunLoopMode(const void *runLoopMode) } declare 22 {unix macosx} { - TclFile TclpCreateTempFile_(const char *contents) + TclFile TclpCreateTempFile(const char *contents) } declare 29 {win unix} { diff --git a/generic/tclIntPlatDecls.h b/generic/tclIntPlatDecls.h index bc6a7e3..1ce68b3 100644 --- a/generic/tclIntPlatDecls.h +++ b/generic/tclIntPlatDecls.h @@ -42,12 +42,12 @@ extern "C" { #if !defined(_WIN32) && !defined(__CYGWIN__) && !defined(MAC_OSX_TCL) /* UNIX */ /* 0 */ -EXTERN void TclGetAndDetachPids(Tcl_Interp *interp, +EXTERN void TclGetAndDetachPids_(Tcl_Interp *interp, Tcl_Channel chan); /* 1 */ EXTERN int TclpCloseFile(TclFile file); /* 2 */ -EXTERN Tcl_Channel TclpCreateCommandChannel(TclFile readFile, +EXTERN Tcl_Channel TclpCreateCommandChannel_(TclFile readFile, TclFile writeFile, TclFile errorFile, int numPids, Tcl_Pid *pidPtr); /* 3 */ @@ -58,47 +58,39 @@ EXTERN int TclpCreateProcess(Tcl_Interp *interp, int argc, TclFile outputFile, TclFile errorFile, Tcl_Pid *pidPtr); /* 5 */ -EXTERN int TclUnixWaitForFile_(int fd, int mask, int timeout); +EXTERN int TclUnixWaitForFile(int fd, int mask, int timeout); /* 6 */ EXTERN TclFile TclpMakeFile(Tcl_Channel channel, int direction); /* 7 */ EXTERN TclFile TclpOpenFile(const char *fname, int mode); /* 8 */ -EXTERN int TclUnixWaitForFile(int fd, int mask, int timeout); +EXTERN int TclUnixWaitForFile_(int fd, int mask, int timeout); /* 9 */ -EXTERN TclFile TclpCreateTempFile(const char *contents); +EXTERN TclFile TclpCreateTempFile_(const char *contents); /* Slot 10 is reserved */ -/* Slot 11 is reserved */ +/* 11 */ +EXTERN void TclGetAndDetachPids(Tcl_Interp *interp, + Tcl_Channel chan); /* Slot 12 is reserved */ -/* Slot 13 is reserved */ +/* 13 */ +EXTERN Tcl_Channel TclpCreateCommandChannel(TclFile readFile, + TclFile writeFile, TclFile errorFile, + int numPids, Tcl_Pid *pidPtr); /* 14 */ EXTERN int TclUnixCopyFile(const char *src, const char *dst, const Tcl_StatBuf *statBufPtr, int dontCopyAtts); -/* 15 */ -EXTERN int TclMacOSXGetFileAttribute(Tcl_Interp *interp, - int objIndex, Tcl_Obj *fileName, - Tcl_Obj **attributePtrPtr); -/* 16 */ -EXTERN int TclMacOSXSetFileAttribute(Tcl_Interp *interp, - int objIndex, Tcl_Obj *fileName, - Tcl_Obj *attributePtr); -/* 17 */ -EXTERN int TclMacOSXCopyFileAttributes(const char *src, - const char *dst, - const Tcl_StatBuf *statBufPtr); -/* 18 */ -EXTERN int TclMacOSXMatchType(Tcl_Interp *interp, - const char *pathName, const char *fileName, - Tcl_StatBuf *statBufPtr, - Tcl_GlobTypeData *types); +/* Slot 15 is reserved */ +/* Slot 16 is reserved */ +/* Slot 17 is reserved */ +/* Slot 18 is reserved */ /* 19 */ EXTERN void TclMacOSXNotifierAddRunLoopMode( const void *runLoopMode); /* Slot 20 is reserved */ /* Slot 21 is reserved */ /* 22 */ -EXTERN TclFile TclpCreateTempFile_(const char *contents); +EXTERN TclFile TclpCreateTempFile(const char *contents); /* Slot 23 is reserved */ /* Slot 24 is reserved */ /* Slot 25 is reserved */ @@ -176,12 +168,12 @@ EXTERN int TclUnixOpenTemporaryFile(Tcl_Obj *dirObj, #endif /* WIN */ #ifdef MAC_OSX_TCL /* MACOSX */ /* 0 */ -EXTERN void TclGetAndDetachPids(Tcl_Interp *interp, +EXTERN void TclGetAndDetachPids_(Tcl_Interp *interp, Tcl_Channel chan); /* 1 */ EXTERN int TclpCloseFile(TclFile file); /* 2 */ -EXTERN Tcl_Channel TclpCreateCommandChannel(TclFile readFile, +EXTERN Tcl_Channel TclpCreateCommandChannel_(TclFile readFile, TclFile writeFile, TclFile errorFile, int numPids, Tcl_Pid *pidPtr); /* 3 */ @@ -192,47 +184,39 @@ EXTERN int TclpCreateProcess(Tcl_Interp *interp, int argc, TclFile outputFile, TclFile errorFile, Tcl_Pid *pidPtr); /* 5 */ -EXTERN int TclUnixWaitForFile_(int fd, int mask, int timeout); +EXTERN int TclUnixWaitForFile(int fd, int mask, int timeout); /* 6 */ EXTERN TclFile TclpMakeFile(Tcl_Channel channel, int direction); /* 7 */ EXTERN TclFile TclpOpenFile(const char *fname, int mode); /* 8 */ -EXTERN int TclUnixWaitForFile(int fd, int mask, int timeout); +EXTERN int TclUnixWaitForFile_(int fd, int mask, int timeout); /* 9 */ -EXTERN TclFile TclpCreateTempFile(const char *contents); +EXTERN TclFile TclpCreateTempFile_(const char *contents); /* Slot 10 is reserved */ -/* Slot 11 is reserved */ +/* 11 */ +EXTERN void TclGetAndDetachPids(Tcl_Interp *interp, + Tcl_Channel chan); /* Slot 12 is reserved */ -/* Slot 13 is reserved */ +/* 13 */ +EXTERN Tcl_Channel TclpCreateCommandChannel(TclFile readFile, + TclFile writeFile, TclFile errorFile, + int numPids, Tcl_Pid *pidPtr); /* 14 */ EXTERN int TclUnixCopyFile(const char *src, const char *dst, const Tcl_StatBuf *statBufPtr, int dontCopyAtts); -/* 15 */ -EXTERN int TclMacOSXGetFileAttribute(Tcl_Interp *interp, - int objIndex, Tcl_Obj *fileName, - Tcl_Obj **attributePtrPtr); -/* 16 */ -EXTERN int TclMacOSXSetFileAttribute(Tcl_Interp *interp, - int objIndex, Tcl_Obj *fileName, - Tcl_Obj *attributePtr); -/* 17 */ -EXTERN int TclMacOSXCopyFileAttributes(const char *src, - const char *dst, - const Tcl_StatBuf *statBufPtr); -/* 18 */ -EXTERN int TclMacOSXMatchType(Tcl_Interp *interp, - const char *pathName, const char *fileName, - Tcl_StatBuf *statBufPtr, - Tcl_GlobTypeData *types); +/* Slot 15 is reserved */ +/* Slot 16 is reserved */ +/* Slot 17 is reserved */ +/* Slot 18 is reserved */ /* 19 */ EXTERN void TclMacOSXNotifierAddRunLoopMode( const void *runLoopMode); /* Slot 20 is reserved */ /* Slot 21 is reserved */ /* 22 */ -EXTERN TclFile TclpCreateTempFile_(const char *contents); +EXTERN TclFile TclpCreateTempFile(const char *contents); /* Slot 23 is reserved */ /* Slot 24 is reserved */ /* Slot 25 is reserved */ @@ -252,29 +236,29 @@ typedef struct TclIntPlatStubs { void *hooks; #if !defined(_WIN32) && !defined(__CYGWIN__) && !defined(MAC_OSX_TCL) /* UNIX */ - void (*tclGetAndDetachPids) (Tcl_Interp *interp, Tcl_Channel chan); /* 0 */ + void (*tclGetAndDetachPids_) (Tcl_Interp *interp, Tcl_Channel chan); /* 0 */ int (*tclpCloseFile) (TclFile file); /* 1 */ - Tcl_Channel (*tclpCreateCommandChannel) (TclFile readFile, TclFile writeFile, TclFile errorFile, int numPids, Tcl_Pid *pidPtr); /* 2 */ + Tcl_Channel (*tclpCreateCommandChannel_) (TclFile readFile, TclFile writeFile, TclFile errorFile, int numPids, Tcl_Pid *pidPtr); /* 2 */ int (*tclpCreatePipe) (TclFile *readPipe, TclFile *writePipe); /* 3 */ int (*tclpCreateProcess) (Tcl_Interp *interp, int argc, const char **argv, TclFile inputFile, TclFile outputFile, TclFile errorFile, Tcl_Pid *pidPtr); /* 4 */ - int (*tclUnixWaitForFile_) (int fd, int mask, int timeout); /* 5 */ + int (*tclUnixWaitForFile) (int fd, int mask, int timeout); /* 5 */ TclFile (*tclpMakeFile) (Tcl_Channel channel, int direction); /* 6 */ TclFile (*tclpOpenFile) (const char *fname, int mode); /* 7 */ - int (*tclUnixWaitForFile) (int fd, int mask, int timeout); /* 8 */ - TclFile (*tclpCreateTempFile) (const char *contents); /* 9 */ + int (*tclUnixWaitForFile_) (int fd, int mask, int timeout); /* 8 */ + TclFile (*tclpCreateTempFile_) (const char *contents); /* 9 */ void (*reserved10)(void); - void (*reserved11)(void); + void (*tclGetAndDetachPids) (Tcl_Interp *interp, Tcl_Channel chan); /* 11 */ void (*reserved12)(void); - void (*reserved13)(void); + Tcl_Channel (*tclpCreateCommandChannel) (TclFile readFile, TclFile writeFile, TclFile errorFile, int numPids, Tcl_Pid *pidPtr); /* 13 */ int (*tclUnixCopyFile) (const char *src, const char *dst, const Tcl_StatBuf *statBufPtr, int dontCopyAtts); /* 14 */ - int (*tclMacOSXGetFileAttribute) (Tcl_Interp *interp, int objIndex, Tcl_Obj *fileName, Tcl_Obj **attributePtrPtr); /* 15 */ - int (*tclMacOSXSetFileAttribute) (Tcl_Interp *interp, int objIndex, Tcl_Obj *fileName, Tcl_Obj *attributePtr); /* 16 */ - int (*tclMacOSXCopyFileAttributes) (const char *src, const char *dst, const Tcl_StatBuf *statBufPtr); /* 17 */ - int (*tclMacOSXMatchType) (Tcl_Interp *interp, const char *pathName, const char *fileName, Tcl_StatBuf *statBufPtr, Tcl_GlobTypeData *types); /* 18 */ + void (*reserved15)(void); + void (*reserved16)(void); + void (*reserved17)(void); + void (*reserved18)(void); void (*tclMacOSXNotifierAddRunLoopMode) (const void *runLoopMode); /* 19 */ void (*reserved20)(void); void (*reserved21)(void); - TclFile (*tclpCreateTempFile_) (const char *contents); /* 22 */ + TclFile (*tclpCreateTempFile) (const char *contents); /* 22 */ void (*reserved23)(void); void (*reserved24)(void); void (*reserved25)(void); @@ -318,29 +302,29 @@ typedef struct TclIntPlatStubs { int (*tclUnixOpenTemporaryFile) (Tcl_Obj *dirObj, Tcl_Obj *basenameObj, Tcl_Obj *extensionObj, Tcl_Obj *resultingNameObj); /* 30 */ #endif /* WIN */ #ifdef MAC_OSX_TCL /* MACOSX */ - void (*tclGetAndDetachPids) (Tcl_Interp *interp, Tcl_Channel chan); /* 0 */ + void (*tclGetAndDetachPids_) (Tcl_Interp *interp, Tcl_Channel chan); /* 0 */ int (*tclpCloseFile) (TclFile file); /* 1 */ - Tcl_Channel (*tclpCreateCommandChannel) (TclFile readFile, TclFile writeFile, TclFile errorFile, int numPids, Tcl_Pid *pidPtr); /* 2 */ + Tcl_Channel (*tclpCreateCommandChannel_) (TclFile readFile, TclFile writeFile, TclFile errorFile, int numPids, Tcl_Pid *pidPtr); /* 2 */ int (*tclpCreatePipe) (TclFile *readPipe, TclFile *writePipe); /* 3 */ int (*tclpCreateProcess) (Tcl_Interp *interp, int argc, const char **argv, TclFile inputFile, TclFile outputFile, TclFile errorFile, Tcl_Pid *pidPtr); /* 4 */ - int (*tclUnixWaitForFile_) (int fd, int mask, int timeout); /* 5 */ + int (*tclUnixWaitForFile) (int fd, int mask, int timeout); /* 5 */ TclFile (*tclpMakeFile) (Tcl_Channel channel, int direction); /* 6 */ TclFile (*tclpOpenFile) (const char *fname, int mode); /* 7 */ - int (*tclUnixWaitForFile) (int fd, int mask, int timeout); /* 8 */ - TclFile (*tclpCreateTempFile) (const char *contents); /* 9 */ + int (*tclUnixWaitForFile_) (int fd, int mask, int timeout); /* 8 */ + TclFile (*tclpCreateTempFile_) (const char *contents); /* 9 */ void (*reserved10)(void); - void (*reserved11)(void); + void (*tclGetAndDetachPids) (Tcl_Interp *interp, Tcl_Channel chan); /* 11 */ void (*reserved12)(void); - void (*reserved13)(void); + Tcl_Channel (*tclpCreateCommandChannel) (TclFile readFile, TclFile writeFile, TclFile errorFile, int numPids, Tcl_Pid *pidPtr); /* 13 */ int (*tclUnixCopyFile) (const char *src, const char *dst, const Tcl_StatBuf *statBufPtr, int dontCopyAtts); /* 14 */ - int (*tclMacOSXGetFileAttribute) (Tcl_Interp *interp, int objIndex, Tcl_Obj *fileName, Tcl_Obj **attributePtrPtr); /* 15 */ - int (*tclMacOSXSetFileAttribute) (Tcl_Interp *interp, int objIndex, Tcl_Obj *fileName, Tcl_Obj *attributePtr); /* 16 */ - int (*tclMacOSXCopyFileAttributes) (const char *src, const char *dst, const Tcl_StatBuf *statBufPtr); /* 17 */ - int (*tclMacOSXMatchType) (Tcl_Interp *interp, const char *pathName, const char *fileName, Tcl_StatBuf *statBufPtr, Tcl_GlobTypeData *types); /* 18 */ + void (*reserved15)(void); + void (*reserved16)(void); + void (*reserved17)(void); + void (*reserved18)(void); void (*tclMacOSXNotifierAddRunLoopMode) (const void *runLoopMode); /* 19 */ void (*reserved20)(void); void (*reserved21)(void); - TclFile (*tclpCreateTempFile_) (const char *contents); /* 22 */ + TclFile (*tclpCreateTempFile) (const char *contents); /* 22 */ void (*reserved23)(void); void (*reserved24)(void); void (*reserved25)(void); @@ -365,46 +349,44 @@ extern const TclIntPlatStubs *tclIntPlatStubsPtr; */ #if !defined(_WIN32) && !defined(__CYGWIN__) && !defined(MAC_OSX_TCL) /* UNIX */ -#define TclGetAndDetachPids \ - (tclIntPlatStubsPtr->tclGetAndDetachPids) /* 0 */ +#define TclGetAndDetachPids_ \ + (tclIntPlatStubsPtr->tclGetAndDetachPids_) /* 0 */ #define TclpCloseFile \ (tclIntPlatStubsPtr->tclpCloseFile) /* 1 */ -#define TclpCreateCommandChannel \ - (tclIntPlatStubsPtr->tclpCreateCommandChannel) /* 2 */ +#define TclpCreateCommandChannel_ \ + (tclIntPlatStubsPtr->tclpCreateCommandChannel_) /* 2 */ #define TclpCreatePipe \ (tclIntPlatStubsPtr->tclpCreatePipe) /* 3 */ #define TclpCreateProcess \ (tclIntPlatStubsPtr->tclpCreateProcess) /* 4 */ -#define TclUnixWaitForFile_ \ - (tclIntPlatStubsPtr->tclUnixWaitForFile_) /* 5 */ +#define TclUnixWaitForFile \ + (tclIntPlatStubsPtr->tclUnixWaitForFile) /* 5 */ #define TclpMakeFile \ (tclIntPlatStubsPtr->tclpMakeFile) /* 6 */ #define TclpOpenFile \ (tclIntPlatStubsPtr->tclpOpenFile) /* 7 */ -#define TclUnixWaitForFile \ - (tclIntPlatStubsPtr->tclUnixWaitForFile) /* 8 */ -#define TclpCreateTempFile \ - (tclIntPlatStubsPtr->tclpCreateTempFile) /* 9 */ +#define TclUnixWaitForFile_ \ + (tclIntPlatStubsPtr->tclUnixWaitForFile_) /* 8 */ +#define TclpCreateTempFile_ \ + (tclIntPlatStubsPtr->tclpCreateTempFile_) /* 9 */ /* Slot 10 is reserved */ -/* Slot 11 is reserved */ +#define TclGetAndDetachPids \ + (tclIntPlatStubsPtr->tclGetAndDetachPids) /* 11 */ /* Slot 12 is reserved */ -/* Slot 13 is reserved */ +#define TclpCreateCommandChannel \ + (tclIntPlatStubsPtr->tclpCreateCommandChannel) /* 13 */ #define TclUnixCopyFile \ (tclIntPlatStubsPtr->tclUnixCopyFile) /* 14 */ -#define TclMacOSXGetFileAttribute \ - (tclIntPlatStubsPtr->tclMacOSXGetFileAttribute) /* 15 */ -#define TclMacOSXSetFileAttribute \ - (tclIntPlatStubsPtr->tclMacOSXSetFileAttribute) /* 16 */ -#define TclMacOSXCopyFileAttributes \ - (tclIntPlatStubsPtr->tclMacOSXCopyFileAttributes) /* 17 */ -#define TclMacOSXMatchType \ - (tclIntPlatStubsPtr->tclMacOSXMatchType) /* 18 */ +/* Slot 15 is reserved */ +/* Slot 16 is reserved */ +/* Slot 17 is reserved */ +/* Slot 18 is reserved */ #define TclMacOSXNotifierAddRunLoopMode \ (tclIntPlatStubsPtr->tclMacOSXNotifierAddRunLoopMode) /* 19 */ /* Slot 20 is reserved */ /* Slot 21 is reserved */ -#define TclpCreateTempFile_ \ - (tclIntPlatStubsPtr->tclpCreateTempFile_) /* 22 */ +#define TclpCreateTempFile \ + (tclIntPlatStubsPtr->tclpCreateTempFile) /* 22 */ /* Slot 23 is reserved */ /* Slot 24 is reserved */ /* Slot 25 is reserved */ @@ -469,46 +451,44 @@ extern const TclIntPlatStubs *tclIntPlatStubsPtr; (tclIntPlatStubsPtr->tclUnixOpenTemporaryFile) /* 30 */ #endif /* WIN */ #ifdef MAC_OSX_TCL /* MACOSX */ -#define TclGetAndDetachPids \ - (tclIntPlatStubsPtr->tclGetAndDetachPids) /* 0 */ +#define TclGetAndDetachPids_ \ + (tclIntPlatStubsPtr->tclGetAndDetachPids_) /* 0 */ #define TclpCloseFile \ (tclIntPlatStubsPtr->tclpCloseFile) /* 1 */ -#define TclpCreateCommandChannel \ - (tclIntPlatStubsPtr->tclpCreateCommandChannel) /* 2 */ +#define TclpCreateCommandChannel_ \ + (tclIntPlatStubsPtr->tclpCreateCommandChannel_) /* 2 */ #define TclpCreatePipe \ (tclIntPlatStubsPtr->tclpCreatePipe) /* 3 */ #define TclpCreateProcess \ (tclIntPlatStubsPtr->tclpCreateProcess) /* 4 */ -#define TclUnixWaitForFile_ \ - (tclIntPlatStubsPtr->tclUnixWaitForFile_) /* 5 */ +#define TclUnixWaitForFile \ + (tclIntPlatStubsPtr->tclUnixWaitForFile) /* 5 */ #define TclpMakeFile \ (tclIntPlatStubsPtr->tclpMakeFile) /* 6 */ #define TclpOpenFile \ (tclIntPlatStubsPtr->tclpOpenFile) /* 7 */ -#define TclUnixWaitForFile \ - (tclIntPlatStubsPtr->tclUnixWaitForFile) /* 8 */ -#define TclpCreateTempFile \ - (tclIntPlatStubsPtr->tclpCreateTempFile) /* 9 */ +#define TclUnixWaitForFile_ \ + (tclIntPlatStubsPtr->tclUnixWaitForFile_) /* 8 */ +#define TclpCreateTempFile_ \ + (tclIntPlatStubsPtr->tclpCreateTempFile_) /* 9 */ /* Slot 10 is reserved */ -/* Slot 11 is reserved */ +#define TclGetAndDetachPids \ + (tclIntPlatStubsPtr->tclGetAndDetachPids) /* 11 */ /* Slot 12 is reserved */ -/* Slot 13 is reserved */ +#define TclpCreateCommandChannel \ + (tclIntPlatStubsPtr->tclpCreateCommandChannel) /* 13 */ #define TclUnixCopyFile \ (tclIntPlatStubsPtr->tclUnixCopyFile) /* 14 */ -#define TclMacOSXGetFileAttribute \ - (tclIntPlatStubsPtr->tclMacOSXGetFileAttribute) /* 15 */ -#define TclMacOSXSetFileAttribute \ - (tclIntPlatStubsPtr->tclMacOSXSetFileAttribute) /* 16 */ -#define TclMacOSXCopyFileAttributes \ - (tclIntPlatStubsPtr->tclMacOSXCopyFileAttributes) /* 17 */ -#define TclMacOSXMatchType \ - (tclIntPlatStubsPtr->tclMacOSXMatchType) /* 18 */ +/* Slot 15 is reserved */ +/* Slot 16 is reserved */ +/* Slot 17 is reserved */ +/* Slot 18 is reserved */ #define TclMacOSXNotifierAddRunLoopMode \ (tclIntPlatStubsPtr->tclMacOSXNotifierAddRunLoopMode) /* 19 */ /* Slot 20 is reserved */ /* Slot 21 is reserved */ -#define TclpCreateTempFile_ \ - (tclIntPlatStubsPtr->tclpCreateTempFile_) /* 22 */ +#define TclpCreateTempFile \ + (tclIntPlatStubsPtr->tclpCreateTempFile) /* 22 */ /* Slot 23 is reserved */ /* Slot 24 is reserved */ /* Slot 25 is reserved */ @@ -532,11 +512,23 @@ extern const TclIntPlatStubs *tclIntPlatStubsPtr; #undef TclpCreateTempFile_ #undef TclUnixWaitForFile_ #undef TclMacOSXNotifierAddRunLoopMode -#ifndef MAC_OSX_TCL /* not accessable on Win32/UNIX */ -#undef TclMacOSXGetFileAttribute /* 15 */ -#undef TclMacOSXSetFileAttribute /* 16 */ -#undef TclMacOSXCopyFileAttributes /* 17 */ -#undef TclMacOSXMatchType /* 18 */ +#ifdef MAC_OSX_TCL /* not accessable on Win32/UNIX */ +MODULE_SCOPE int TclMacOSXGetFileAttribute(Tcl_Interp *interp, + int objIndex, Tcl_Obj *fileName, + Tcl_Obj **attributePtrPtr); +/* 16 */ +MODULE_SCOPE int TclMacOSXSetFileAttribute(Tcl_Interp *interp, + int objIndex, Tcl_Obj *fileName, + Tcl_Obj *attributePtr); +/* 17 */ +MODULE_SCOPE int TclMacOSXCopyFileAttributes(const char *src, + const char *dst, + const Tcl_StatBuf *statBufPtr); +/* 18 */ +MODULE_SCOPE int TclMacOSXMatchType(Tcl_Interp *interp, + const char *pathName, const char *fileName, + Tcl_StatBuf *statBufPtr, + Tcl_GlobTypeData *types); #endif #if !defined(_WIN32) diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c index 577c05a..54001b2 100644 --- a/generic/tclStubInit.c +++ b/generic/tclStubInit.c @@ -146,6 +146,8 @@ static void uniCodePanic() { #define TclpCreateTempFile_ TclpCreateTempFile #define TclUnixWaitForFile_ TclUnixWaitForFile +#define TclGetAndDetachPids_ TclGetAndDetachPids +#define TclpCreateCommandChannel_ TclpCreateCommandChannel #ifndef MAC_OSX_TCL /* On UNIX, fill with other stub entries */ # define TclMacOSXGetFileAttribute (int (*)(Tcl_Interp *, int, Tcl_Obj *, Tcl_Obj **))(void *)TclpCreateProcess # define TclMacOSXSetFileAttribute (int (*)(Tcl_Interp *, int, Tcl_Obj *, Tcl_Obj *))(void *)isatty @@ -546,29 +548,29 @@ static const TclIntPlatStubs tclIntPlatStubs = { TCL_STUB_MAGIC, 0, #if !defined(_WIN32) && !defined(__CYGWIN__) && !defined(MAC_OSX_TCL) /* UNIX */ - TclGetAndDetachPids, /* 0 */ + TclGetAndDetachPids_, /* 0 */ TclpCloseFile, /* 1 */ - TclpCreateCommandChannel, /* 2 */ + TclpCreateCommandChannel_, /* 2 */ TclpCreatePipe, /* 3 */ TclpCreateProcess, /* 4 */ - TclUnixWaitForFile_, /* 5 */ + TclUnixWaitForFile, /* 5 */ TclpMakeFile, /* 6 */ TclpOpenFile, /* 7 */ - TclUnixWaitForFile, /* 8 */ - TclpCreateTempFile, /* 9 */ + TclUnixWaitForFile_, /* 8 */ + TclpCreateTempFile_, /* 9 */ 0, /* 10 */ - 0, /* 11 */ + TclGetAndDetachPids, /* 11 */ 0, /* 12 */ - 0, /* 13 */ + TclpCreateCommandChannel, /* 13 */ TclUnixCopyFile, /* 14 */ - TclMacOSXGetFileAttribute, /* 15 */ - TclMacOSXSetFileAttribute, /* 16 */ - TclMacOSXCopyFileAttributes, /* 17 */ - TclMacOSXMatchType, /* 18 */ + 0, /* 15 */ + 0, /* 16 */ + 0, /* 17 */ + 0, /* 18 */ TclMacOSXNotifierAddRunLoopMode, /* 19 */ 0, /* 20 */ 0, /* 21 */ - TclpCreateTempFile_, /* 22 */ + TclpCreateTempFile, /* 22 */ 0, /* 23 */ 0, /* 24 */ 0, /* 25 */ @@ -612,29 +614,29 @@ static const TclIntPlatStubs tclIntPlatStubs = { TclUnixOpenTemporaryFile, /* 30 */ #endif /* WIN */ #ifdef MAC_OSX_TCL /* MACOSX */ - TclGetAndDetachPids, /* 0 */ + TclGetAndDetachPids_, /* 0 */ TclpCloseFile, /* 1 */ - TclpCreateCommandChannel, /* 2 */ + TclpCreateCommandChannel_, /* 2 */ TclpCreatePipe, /* 3 */ TclpCreateProcess, /* 4 */ - TclUnixWaitForFile_, /* 5 */ + TclUnixWaitForFile, /* 5 */ TclpMakeFile, /* 6 */ TclpOpenFile, /* 7 */ - TclUnixWaitForFile, /* 8 */ - TclpCreateTempFile, /* 9 */ + TclUnixWaitForFile_, /* 8 */ + TclpCreateTempFile_, /* 9 */ 0, /* 10 */ - 0, /* 11 */ + TclGetAndDetachPids, /* 11 */ 0, /* 12 */ - 0, /* 13 */ + TclpCreateCommandChannel, /* 13 */ TclUnixCopyFile, /* 14 */ - TclMacOSXGetFileAttribute, /* 15 */ - TclMacOSXSetFileAttribute, /* 16 */ - TclMacOSXCopyFileAttributes, /* 17 */ - TclMacOSXMatchType, /* 18 */ + 0, /* 15 */ + 0, /* 16 */ + 0, /* 17 */ + 0, /* 18 */ TclMacOSXNotifierAddRunLoopMode, /* 19 */ 0, /* 20 */ 0, /* 21 */ - TclpCreateTempFile_, /* 22 */ + TclpCreateTempFile, /* 22 */ 0, /* 23 */ 0, /* 24 */ 0, /* 25 */ -- cgit v0.12 From 35fa5da02e87e55c16745e3f11a109b7aff4b559 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 26 Jan 2021 10:58:19 +0000 Subject: Sort platform-dependant entries in tclInt.decls. No change in generated tcl*Decls.h --- generic/tcl.decls | 16 +------- generic/tclInt.decls | 113 ++++++++++++++++++++------------------------------- 2 files changed, 45 insertions(+), 84 deletions(-) diff --git a/generic/tcl.decls b/generic/tcl.decls index 30f5f69..2ce6ae2 100644 --- a/generic/tcl.decls +++ b/generic/tcl.decls @@ -2491,25 +2491,11 @@ interface tclPlat ################################ # Windows specific functions - -# Added in Tcl 8.1, Removed in Tcl 9.0 (converted to macro) - -#declare 0 win { -# TCHAR *Tcl_WinUtfToTChar(const char *str, size_t len, Tcl_DString *dsPtr) -#} -#declare 1 win { -# char *Tcl_WinTCharToUtf(const TCHAR *str, size_t len, Tcl_DString *dsPtr) -#} +# (none) ################################ # Mac OS X specific functions -# Removed in 9.0 -#declare 0 { -# int Tcl_MacOSXOpenBundleResources(Tcl_Interp *interp, -# const char *bundleName, int hasResourceFile, -# size_t maxPathLen, char *libraryPath) -#} declare 1 { int Tcl_MacOSXOpenVersionedBundleResources(Tcl_Interp *interp, const char *bundleName, const char *bundleVersion, diff --git a/generic/tclInt.decls b/generic/tclInt.decls index 59104cc..001fc96 100644 --- a/generic/tclInt.decls +++ b/generic/tclInt.decls @@ -597,30 +597,64 @@ declare 260 { interface tclIntPlat ################################ -# Windows specific functions +# Platform specific functions +declare 0 unix { + void TclGetAndDetachPids_(Tcl_Interp *interp, Tcl_Channel chan) +} declare 0 win { void TclWinConvertError(int errCode) } +declare 1 unix { + int TclpCloseFile(TclFile file) +} +declare 2 unix { + Tcl_Channel TclpCreateCommandChannel_(TclFile readFile, + TclFile writeFile, TclFile errorFile, int numPids, Tcl_Pid *pidPtr) +} +declare 3 unix { + int TclpCreatePipe(TclFile *readPipe, TclFile *writePipe) +} +declare 4 unix { + int TclpCreateProcess(Tcl_Interp *interp, int argc, + const char **argv, TclFile inputFile, TclFile outputFile, + TclFile errorFile, Tcl_Pid *pidPtr) +} declare 4 win { void *TclWinGetTclInstance(void) } -declare 5 win { +declare 5 {unix win} { int TclUnixWaitForFile(int fd, int mask, int timeout) } +declare 6 unix { + TclFile TclpMakeFile(Tcl_Channel channel, int direction) +} +declare 7 unix { + TclFile TclpOpenFile(const char *fname, int mode) +} +declare 8 unix { + int TclUnixWaitForFile_(int fd, int mask, int timeout) +} declare 8 win { size_t TclpGetPid(Tcl_Pid pid) } -declare 11 win { +declare 9 unix { + TclFile TclpCreateTempFile_(const char *contents) +} +declare 11 {unix win} { void TclGetAndDetachPids(Tcl_Interp *interp, Tcl_Channel chan) } declare 12 win { int TclpCloseFile(TclFile file) } -declare 13 win { +declare 13 {unix win} { Tcl_Channel TclpCreateCommandChannel(TclFile readFile, TclFile writeFile, TclFile errorFile, int numPids, Tcl_Pid *pidPtr) } +declare 14 unix { + int TclUnixCopyFile(const char *src, const char *dst, + const Tcl_StatBuf *statBufPtr, int dontCopyAtts) +} declare 14 win { int TclpCreatePipe(TclFile *readPipe, TclFile *writePipe) } @@ -639,13 +673,16 @@ declare 17 win { declare 18 win { TclFile TclpMakeFile(Tcl_Channel channel, int direction) } +declare 19 unix { + void TclMacOSXNotifierAddRunLoopMode(const void *runLoopMode) +} declare 19 win { TclFile TclpOpenFile(const char *fname, int mode) } declare 20 win { void TclWinAddProcess(void *hProcess, size_t id) } -declare 22 win { +declare 22 {unix win} { TclFile TclpCreateTempFile(const char *contents) } declare 24 win { @@ -654,72 +691,10 @@ declare 24 win { declare 27 win { void TclWinFlushDirtyChannels(void) } - -################################ -# Unix specific functions - -# Pipe channel functions - -declare 0 unix { - void TclGetAndDetachPids_(Tcl_Interp *interp, Tcl_Channel chan) -} -declare 1 unix { - int TclpCloseFile(TclFile file) -} -declare 2 unix { - Tcl_Channel TclpCreateCommandChannel_(TclFile readFile, - TclFile writeFile, TclFile errorFile, int numPids, Tcl_Pid *pidPtr) -} -declare 3 unix { - int TclpCreatePipe(TclFile *readPipe, TclFile *writePipe) -} -declare 4 unix { - int TclpCreateProcess(Tcl_Interp *interp, int argc, - const char **argv, TclFile inputFile, TclFile outputFile, - TclFile errorFile, Tcl_Pid *pidPtr) -} -declare 5 unix { - int TclUnixWaitForFile(int fd, int mask, int timeout) -} -declare 6 unix { - TclFile TclpMakeFile(Tcl_Channel channel, int direction) -} -declare 7 unix { - TclFile TclpOpenFile(const char *fname, int mode) -} -declare 8 unix { - int TclUnixWaitForFile_(int fd, int mask, int timeout) -} -declare 9 unix { - TclFile TclpCreateTempFile_(const char *contents) -} -declare 11 unix { - void TclGetAndDetachPids(Tcl_Interp *interp, Tcl_Channel chan) -} -declare 13 unix { - Tcl_Channel TclpCreateCommandChannel(TclFile readFile, - TclFile writeFile, TclFile errorFile, int numPids, Tcl_Pid *pidPtr) -} -declare 14 unix { - int TclUnixCopyFile(const char *src, const char *dst, - const Tcl_StatBuf *statBufPtr, int dontCopyAtts) -} - -################################ -# Mac OS X specific functions - -declare 19 {unix macosx} { - void TclMacOSXNotifierAddRunLoopMode(const void *runLoopMode) -} -declare 22 {unix macosx} { - TclFile TclpCreateTempFile(const char *contents) -} - -declare 29 {win unix} { +declare 29 {unix win} { int TclWinCPUID(int index, int *regs) } -# Added in 8.6; core of TclpOpenTemporaryFile -declare 30 {win unix} { +declare 30 {unix win} { int TclUnixOpenTemporaryFile(Tcl_Obj *dirObj, Tcl_Obj *basenameObj, Tcl_Obj *extensionObj, Tcl_Obj *resultingNameObj) } -- cgit v0.12 From 1aade032020e2bb6cc04e0e487fe0a1c5e22f31a Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 26 Jan 2021 14:30:00 +0000 Subject: More more stub-entries, making the internal platform table more equal to each other. Old entries keps, so still binary compatible with Tcl 9.0a1 --- generic/tclInt.decls | 65 ++++----- generic/tclIntPlatDecls.h | 338 +++++++++++++++++++++++++--------------------- generic/tclStubInit.c | 102 +++++++------- 3 files changed, 264 insertions(+), 241 deletions(-) diff --git a/generic/tclInt.decls b/generic/tclInt.decls index 001fc96..42e6899 100644 --- a/generic/tclInt.decls +++ b/generic/tclInt.decls @@ -599,96 +599,81 @@ interface tclIntPlat ################################ # Platform specific functions -declare 0 unix { - void TclGetAndDetachPids_(Tcl_Interp *interp, Tcl_Channel chan) -} -declare 0 win { +declare 0 {unix win} { void TclWinConvertError(int errCode) } -declare 1 unix { +declare 1 {unix win} { int TclpCloseFile(TclFile file) } -declare 2 unix { - Tcl_Channel TclpCreateCommandChannel_(TclFile readFile, +declare 2 {unix win} { + Tcl_Channel TclpCreateCommandChannel(TclFile readFile, TclFile writeFile, TclFile errorFile, int numPids, Tcl_Pid *pidPtr) } -declare 3 unix { +declare 3 {unix win} { int TclpCreatePipe(TclFile *readPipe, TclFile *writePipe) } -declare 4 unix { - int TclpCreateProcess(Tcl_Interp *interp, int argc, - const char **argv, TclFile inputFile, TclFile outputFile, - TclFile errorFile, Tcl_Pid *pidPtr) -} -declare 4 win { +declare 4 {unix win} { void *TclWinGetTclInstance(void) } declare 5 {unix win} { int TclUnixWaitForFile(int fd, int mask, int timeout) } -declare 6 unix { +declare 6 {unix win} { TclFile TclpMakeFile(Tcl_Channel channel, int direction) } -declare 7 unix { +declare 7 {unix win} { TclFile TclpOpenFile(const char *fname, int mode) } -declare 8 unix { - int TclUnixWaitForFile_(int fd, int mask, int timeout) -} -declare 8 win { +declare 8 {unix win} { size_t TclpGetPid(Tcl_Pid pid) } -declare 9 unix { - TclFile TclpCreateTempFile_(const char *contents) +declare 9 {unix win} { + TclFile TclpCreateTempFile(const char *contents) } declare 11 {unix win} { void TclGetAndDetachPids(Tcl_Interp *interp, Tcl_Channel chan) } declare 12 win { - int TclpCloseFile(TclFile file) + int TclpCloseFile_(TclFile file) } -declare 13 {unix win} { - Tcl_Channel TclpCreateCommandChannel(TclFile readFile, +declare 13 win { + Tcl_Channel TclpCreateCommandChannel_(TclFile readFile, TclFile writeFile, TclFile errorFile, int numPids, Tcl_Pid *pidPtr) } -declare 14 unix { - int TclUnixCopyFile(const char *src, const char *dst, - const Tcl_StatBuf *statBufPtr, int dontCopyAtts) -} -declare 14 win { - int TclpCreatePipe(TclFile *readPipe, TclFile *writePipe) +declare 14 {unix win} { + int TclpCreatePipe_(TclFile *readPipe, TclFile *writePipe) } -declare 15 win { +declare 15 {unix win} { int TclpCreateProcess(Tcl_Interp *interp, int argc, const char **argv, TclFile inputFile, TclFile outputFile, TclFile errorFile, Tcl_Pid *pidPtr) } -declare 16 win { +declare 16 {unix win} { int TclpIsAtty(int fd) } -declare 17 win { +declare 17 {unix win} { int TclUnixCopyFile(const char *src, const char *dst, const Tcl_StatBuf *statBufPtr, int dontCopyAtts) } declare 18 win { - TclFile TclpMakeFile(Tcl_Channel channel, int direction) + TclFile TclpMakeFile_(Tcl_Channel channel, int direction) } declare 19 unix { void TclMacOSXNotifierAddRunLoopMode(const void *runLoopMode) } declare 19 win { - TclFile TclpOpenFile(const char *fname, int mode) + TclFile TclpOpenFile_(const char *fname, int mode) } -declare 20 win { +declare 20 {unix win} { void TclWinAddProcess(void *hProcess, size_t id) } declare 22 {unix win} { - TclFile TclpCreateTempFile(const char *contents) + TclFile TclpCreateTempFile_(const char *contents) } -declare 24 win { +declare 24 {unix win} { char *TclWinNoBackslash(char *path) } -declare 27 win { +declare 27 {unix win} { void TclWinFlushDirtyChannels(void) } declare 29 {unix win} { diff --git a/generic/tclIntPlatDecls.h b/generic/tclIntPlatDecls.h index 1ce68b3..c8941e5 100644 --- a/generic/tclIntPlatDecls.h +++ b/generic/tclIntPlatDecls.h @@ -42,21 +42,17 @@ extern "C" { #if !defined(_WIN32) && !defined(__CYGWIN__) && !defined(MAC_OSX_TCL) /* UNIX */ /* 0 */ -EXTERN void TclGetAndDetachPids_(Tcl_Interp *interp, - Tcl_Channel chan); +EXTERN void TclWinConvertError(int errCode); /* 1 */ EXTERN int TclpCloseFile(TclFile file); /* 2 */ -EXTERN Tcl_Channel TclpCreateCommandChannel_(TclFile readFile, +EXTERN Tcl_Channel TclpCreateCommandChannel(TclFile readFile, TclFile writeFile, TclFile errorFile, int numPids, Tcl_Pid *pidPtr); /* 3 */ EXTERN int TclpCreatePipe(TclFile *readPipe, TclFile *writePipe); /* 4 */ -EXTERN int TclpCreateProcess(Tcl_Interp *interp, int argc, - const char **argv, TclFile inputFile, - TclFile outputFile, TclFile errorFile, - Tcl_Pid *pidPtr); +EXTERN void * TclWinGetTclInstance(void); /* 5 */ EXTERN int TclUnixWaitForFile(int fd, int mask, int timeout); /* 6 */ @@ -64,38 +60,45 @@ EXTERN TclFile TclpMakeFile(Tcl_Channel channel, int direction); /* 7 */ EXTERN TclFile TclpOpenFile(const char *fname, int mode); /* 8 */ -EXTERN int TclUnixWaitForFile_(int fd, int mask, int timeout); +EXTERN size_t TclpGetPid(Tcl_Pid pid); /* 9 */ -EXTERN TclFile TclpCreateTempFile_(const char *contents); +EXTERN TclFile TclpCreateTempFile(const char *contents); /* Slot 10 is reserved */ /* 11 */ EXTERN void TclGetAndDetachPids(Tcl_Interp *interp, Tcl_Channel chan); /* Slot 12 is reserved */ -/* 13 */ -EXTERN Tcl_Channel TclpCreateCommandChannel(TclFile readFile, - TclFile writeFile, TclFile errorFile, - int numPids, Tcl_Pid *pidPtr); +/* Slot 13 is reserved */ /* 14 */ +EXTERN int TclpCreatePipe_(TclFile *readPipe, + TclFile *writePipe); +/* 15 */ +EXTERN int TclpCreateProcess(Tcl_Interp *interp, int argc, + const char **argv, TclFile inputFile, + TclFile outputFile, TclFile errorFile, + Tcl_Pid *pidPtr); +/* 16 */ +EXTERN int TclpIsAtty(int fd); +/* 17 */ EXTERN int TclUnixCopyFile(const char *src, const char *dst, const Tcl_StatBuf *statBufPtr, int dontCopyAtts); -/* Slot 15 is reserved */ -/* Slot 16 is reserved */ -/* Slot 17 is reserved */ /* Slot 18 is reserved */ /* 19 */ EXTERN void TclMacOSXNotifierAddRunLoopMode( const void *runLoopMode); -/* Slot 20 is reserved */ +/* 20 */ +EXTERN void TclWinAddProcess(void *hProcess, size_t id); /* Slot 21 is reserved */ /* 22 */ -EXTERN TclFile TclpCreateTempFile(const char *contents); +EXTERN TclFile TclpCreateTempFile_(const char *contents); /* Slot 23 is reserved */ -/* Slot 24 is reserved */ +/* 24 */ +EXTERN char * TclWinNoBackslash(char *path); /* Slot 25 is reserved */ /* Slot 26 is reserved */ -/* Slot 27 is reserved */ +/* 27 */ +EXTERN void TclWinFlushDirtyChannels(void); /* Slot 28 is reserved */ /* 29 */ EXTERN int TclWinCPUID(int index, int *regs); @@ -107,30 +110,39 @@ EXTERN int TclUnixOpenTemporaryFile(Tcl_Obj *dirObj, #if defined(_WIN32) || defined(__CYGWIN__) /* WIN */ /* 0 */ EXTERN void TclWinConvertError(int errCode); -/* Slot 1 is reserved */ -/* Slot 2 is reserved */ -/* Slot 3 is reserved */ +/* 1 */ +EXTERN int TclpCloseFile(TclFile file); +/* 2 */ +EXTERN Tcl_Channel TclpCreateCommandChannel(TclFile readFile, + TclFile writeFile, TclFile errorFile, + int numPids, Tcl_Pid *pidPtr); +/* 3 */ +EXTERN int TclpCreatePipe(TclFile *readPipe, TclFile *writePipe); /* 4 */ EXTERN void * TclWinGetTclInstance(void); /* 5 */ EXTERN int TclUnixWaitForFile(int fd, int mask, int timeout); -/* Slot 6 is reserved */ -/* Slot 7 is reserved */ +/* 6 */ +EXTERN TclFile TclpMakeFile(Tcl_Channel channel, int direction); +/* 7 */ +EXTERN TclFile TclpOpenFile(const char *fname, int mode); /* 8 */ EXTERN size_t TclpGetPid(Tcl_Pid pid); -/* Slot 9 is reserved */ +/* 9 */ +EXTERN TclFile TclpCreateTempFile(const char *contents); /* Slot 10 is reserved */ /* 11 */ EXTERN void TclGetAndDetachPids(Tcl_Interp *interp, Tcl_Channel chan); /* 12 */ -EXTERN int TclpCloseFile(TclFile file); +EXTERN int TclpCloseFile_(TclFile file); /* 13 */ -EXTERN Tcl_Channel TclpCreateCommandChannel(TclFile readFile, +EXTERN Tcl_Channel TclpCreateCommandChannel_(TclFile readFile, TclFile writeFile, TclFile errorFile, int numPids, Tcl_Pid *pidPtr); /* 14 */ -EXTERN int TclpCreatePipe(TclFile *readPipe, TclFile *writePipe); +EXTERN int TclpCreatePipe_(TclFile *readPipe, + TclFile *writePipe); /* 15 */ EXTERN int TclpCreateProcess(Tcl_Interp *interp, int argc, const char **argv, TclFile inputFile, @@ -143,14 +155,14 @@ EXTERN int TclUnixCopyFile(const char *src, const char *dst, const Tcl_StatBuf *statBufPtr, int dontCopyAtts); /* 18 */ -EXTERN TclFile TclpMakeFile(Tcl_Channel channel, int direction); +EXTERN TclFile TclpMakeFile_(Tcl_Channel channel, int direction); /* 19 */ -EXTERN TclFile TclpOpenFile(const char *fname, int mode); +EXTERN TclFile TclpOpenFile_(const char *fname, int mode); /* 20 */ EXTERN void TclWinAddProcess(void *hProcess, size_t id); /* Slot 21 is reserved */ /* 22 */ -EXTERN TclFile TclpCreateTempFile(const char *contents); +EXTERN TclFile TclpCreateTempFile_(const char *contents); /* Slot 23 is reserved */ /* 24 */ EXTERN char * TclWinNoBackslash(char *path); @@ -168,21 +180,17 @@ EXTERN int TclUnixOpenTemporaryFile(Tcl_Obj *dirObj, #endif /* WIN */ #ifdef MAC_OSX_TCL /* MACOSX */ /* 0 */ -EXTERN void TclGetAndDetachPids_(Tcl_Interp *interp, - Tcl_Channel chan); +EXTERN void TclWinConvertError(int errCode); /* 1 */ EXTERN int TclpCloseFile(TclFile file); /* 2 */ -EXTERN Tcl_Channel TclpCreateCommandChannel_(TclFile readFile, +EXTERN Tcl_Channel TclpCreateCommandChannel(TclFile readFile, TclFile writeFile, TclFile errorFile, int numPids, Tcl_Pid *pidPtr); /* 3 */ EXTERN int TclpCreatePipe(TclFile *readPipe, TclFile *writePipe); /* 4 */ -EXTERN int TclpCreateProcess(Tcl_Interp *interp, int argc, - const char **argv, TclFile inputFile, - TclFile outputFile, TclFile errorFile, - Tcl_Pid *pidPtr); +EXTERN void * TclWinGetTclInstance(void); /* 5 */ EXTERN int TclUnixWaitForFile(int fd, int mask, int timeout); /* 6 */ @@ -190,38 +198,45 @@ EXTERN TclFile TclpMakeFile(Tcl_Channel channel, int direction); /* 7 */ EXTERN TclFile TclpOpenFile(const char *fname, int mode); /* 8 */ -EXTERN int TclUnixWaitForFile_(int fd, int mask, int timeout); +EXTERN size_t TclpGetPid(Tcl_Pid pid); /* 9 */ -EXTERN TclFile TclpCreateTempFile_(const char *contents); +EXTERN TclFile TclpCreateTempFile(const char *contents); /* Slot 10 is reserved */ /* 11 */ EXTERN void TclGetAndDetachPids(Tcl_Interp *interp, Tcl_Channel chan); /* Slot 12 is reserved */ -/* 13 */ -EXTERN Tcl_Channel TclpCreateCommandChannel(TclFile readFile, - TclFile writeFile, TclFile errorFile, - int numPids, Tcl_Pid *pidPtr); +/* Slot 13 is reserved */ /* 14 */ +EXTERN int TclpCreatePipe_(TclFile *readPipe, + TclFile *writePipe); +/* 15 */ +EXTERN int TclpCreateProcess(Tcl_Interp *interp, int argc, + const char **argv, TclFile inputFile, + TclFile outputFile, TclFile errorFile, + Tcl_Pid *pidPtr); +/* 16 */ +EXTERN int TclpIsAtty(int fd); +/* 17 */ EXTERN int TclUnixCopyFile(const char *src, const char *dst, const Tcl_StatBuf *statBufPtr, int dontCopyAtts); -/* Slot 15 is reserved */ -/* Slot 16 is reserved */ -/* Slot 17 is reserved */ /* Slot 18 is reserved */ /* 19 */ EXTERN void TclMacOSXNotifierAddRunLoopMode( const void *runLoopMode); -/* Slot 20 is reserved */ +/* 20 */ +EXTERN void TclWinAddProcess(void *hProcess, size_t id); /* Slot 21 is reserved */ /* 22 */ -EXTERN TclFile TclpCreateTempFile(const char *contents); +EXTERN TclFile TclpCreateTempFile_(const char *contents); /* Slot 23 is reserved */ -/* Slot 24 is reserved */ +/* 24 */ +EXTERN char * TclWinNoBackslash(char *path); /* Slot 25 is reserved */ /* Slot 26 is reserved */ -/* Slot 27 is reserved */ +/* 27 */ +EXTERN void TclWinFlushDirtyChannels(void); /* Slot 28 is reserved */ /* 29 */ EXTERN int TclWinCPUID(int index, int *regs); @@ -236,62 +251,62 @@ typedef struct TclIntPlatStubs { void *hooks; #if !defined(_WIN32) && !defined(__CYGWIN__) && !defined(MAC_OSX_TCL) /* UNIX */ - void (*tclGetAndDetachPids_) (Tcl_Interp *interp, Tcl_Channel chan); /* 0 */ + void (*tclWinConvertError) (int errCode); /* 0 */ int (*tclpCloseFile) (TclFile file); /* 1 */ - Tcl_Channel (*tclpCreateCommandChannel_) (TclFile readFile, TclFile writeFile, TclFile errorFile, int numPids, Tcl_Pid *pidPtr); /* 2 */ + Tcl_Channel (*tclpCreateCommandChannel) (TclFile readFile, TclFile writeFile, TclFile errorFile, int numPids, Tcl_Pid *pidPtr); /* 2 */ int (*tclpCreatePipe) (TclFile *readPipe, TclFile *writePipe); /* 3 */ - int (*tclpCreateProcess) (Tcl_Interp *interp, int argc, const char **argv, TclFile inputFile, TclFile outputFile, TclFile errorFile, Tcl_Pid *pidPtr); /* 4 */ + void * (*tclWinGetTclInstance) (void); /* 4 */ int (*tclUnixWaitForFile) (int fd, int mask, int timeout); /* 5 */ TclFile (*tclpMakeFile) (Tcl_Channel channel, int direction); /* 6 */ TclFile (*tclpOpenFile) (const char *fname, int mode); /* 7 */ - int (*tclUnixWaitForFile_) (int fd, int mask, int timeout); /* 8 */ - TclFile (*tclpCreateTempFile_) (const char *contents); /* 9 */ + size_t (*tclpGetPid) (Tcl_Pid pid); /* 8 */ + TclFile (*tclpCreateTempFile) (const char *contents); /* 9 */ void (*reserved10)(void); void (*tclGetAndDetachPids) (Tcl_Interp *interp, Tcl_Channel chan); /* 11 */ void (*reserved12)(void); - Tcl_Channel (*tclpCreateCommandChannel) (TclFile readFile, TclFile writeFile, TclFile errorFile, int numPids, Tcl_Pid *pidPtr); /* 13 */ - int (*tclUnixCopyFile) (const char *src, const char *dst, const Tcl_StatBuf *statBufPtr, int dontCopyAtts); /* 14 */ - void (*reserved15)(void); - void (*reserved16)(void); - void (*reserved17)(void); + void (*reserved13)(void); + int (*tclpCreatePipe_) (TclFile *readPipe, TclFile *writePipe); /* 14 */ + int (*tclpCreateProcess) (Tcl_Interp *interp, int argc, const char **argv, TclFile inputFile, TclFile outputFile, TclFile errorFile, Tcl_Pid *pidPtr); /* 15 */ + int (*tclpIsAtty) (int fd); /* 16 */ + int (*tclUnixCopyFile) (const char *src, const char *dst, const Tcl_StatBuf *statBufPtr, int dontCopyAtts); /* 17 */ void (*reserved18)(void); void (*tclMacOSXNotifierAddRunLoopMode) (const void *runLoopMode); /* 19 */ - void (*reserved20)(void); + void (*tclWinAddProcess) (void *hProcess, size_t id); /* 20 */ void (*reserved21)(void); - TclFile (*tclpCreateTempFile) (const char *contents); /* 22 */ + TclFile (*tclpCreateTempFile_) (const char *contents); /* 22 */ void (*reserved23)(void); - void (*reserved24)(void); + char * (*tclWinNoBackslash) (char *path); /* 24 */ void (*reserved25)(void); void (*reserved26)(void); - void (*reserved27)(void); + void (*tclWinFlushDirtyChannels) (void); /* 27 */ void (*reserved28)(void); int (*tclWinCPUID) (int index, int *regs); /* 29 */ int (*tclUnixOpenTemporaryFile) (Tcl_Obj *dirObj, Tcl_Obj *basenameObj, Tcl_Obj *extensionObj, Tcl_Obj *resultingNameObj); /* 30 */ #endif /* UNIX */ #if defined(_WIN32) || defined(__CYGWIN__) /* WIN */ void (*tclWinConvertError) (int errCode); /* 0 */ - void (*reserved1)(void); - void (*reserved2)(void); - void (*reserved3)(void); + int (*tclpCloseFile) (TclFile file); /* 1 */ + Tcl_Channel (*tclpCreateCommandChannel) (TclFile readFile, TclFile writeFile, TclFile errorFile, int numPids, Tcl_Pid *pidPtr); /* 2 */ + int (*tclpCreatePipe) (TclFile *readPipe, TclFile *writePipe); /* 3 */ void * (*tclWinGetTclInstance) (void); /* 4 */ int (*tclUnixWaitForFile) (int fd, int mask, int timeout); /* 5 */ - void (*reserved6)(void); - void (*reserved7)(void); + TclFile (*tclpMakeFile) (Tcl_Channel channel, int direction); /* 6 */ + TclFile (*tclpOpenFile) (const char *fname, int mode); /* 7 */ size_t (*tclpGetPid) (Tcl_Pid pid); /* 8 */ - void (*reserved9)(void); + TclFile (*tclpCreateTempFile) (const char *contents); /* 9 */ void (*reserved10)(void); void (*tclGetAndDetachPids) (Tcl_Interp *interp, Tcl_Channel chan); /* 11 */ - int (*tclpCloseFile) (TclFile file); /* 12 */ - Tcl_Channel (*tclpCreateCommandChannel) (TclFile readFile, TclFile writeFile, TclFile errorFile, int numPids, Tcl_Pid *pidPtr); /* 13 */ - int (*tclpCreatePipe) (TclFile *readPipe, TclFile *writePipe); /* 14 */ + int (*tclpCloseFile_) (TclFile file); /* 12 */ + Tcl_Channel (*tclpCreateCommandChannel_) (TclFile readFile, TclFile writeFile, TclFile errorFile, int numPids, Tcl_Pid *pidPtr); /* 13 */ + int (*tclpCreatePipe_) (TclFile *readPipe, TclFile *writePipe); /* 14 */ int (*tclpCreateProcess) (Tcl_Interp *interp, int argc, const char **argv, TclFile inputFile, TclFile outputFile, TclFile errorFile, Tcl_Pid *pidPtr); /* 15 */ int (*tclpIsAtty) (int fd); /* 16 */ int (*tclUnixCopyFile) (const char *src, const char *dst, const Tcl_StatBuf *statBufPtr, int dontCopyAtts); /* 17 */ - TclFile (*tclpMakeFile) (Tcl_Channel channel, int direction); /* 18 */ - TclFile (*tclpOpenFile) (const char *fname, int mode); /* 19 */ + TclFile (*tclpMakeFile_) (Tcl_Channel channel, int direction); /* 18 */ + TclFile (*tclpOpenFile_) (const char *fname, int mode); /* 19 */ void (*tclWinAddProcess) (void *hProcess, size_t id); /* 20 */ void (*reserved21)(void); - TclFile (*tclpCreateTempFile) (const char *contents); /* 22 */ + TclFile (*tclpCreateTempFile_) (const char *contents); /* 22 */ void (*reserved23)(void); char * (*tclWinNoBackslash) (char *path); /* 24 */ void (*reserved25)(void); @@ -302,34 +317,34 @@ typedef struct TclIntPlatStubs { int (*tclUnixOpenTemporaryFile) (Tcl_Obj *dirObj, Tcl_Obj *basenameObj, Tcl_Obj *extensionObj, Tcl_Obj *resultingNameObj); /* 30 */ #endif /* WIN */ #ifdef MAC_OSX_TCL /* MACOSX */ - void (*tclGetAndDetachPids_) (Tcl_Interp *interp, Tcl_Channel chan); /* 0 */ + void (*tclWinConvertError) (int errCode); /* 0 */ int (*tclpCloseFile) (TclFile file); /* 1 */ - Tcl_Channel (*tclpCreateCommandChannel_) (TclFile readFile, TclFile writeFile, TclFile errorFile, int numPids, Tcl_Pid *pidPtr); /* 2 */ + Tcl_Channel (*tclpCreateCommandChannel) (TclFile readFile, TclFile writeFile, TclFile errorFile, int numPids, Tcl_Pid *pidPtr); /* 2 */ int (*tclpCreatePipe) (TclFile *readPipe, TclFile *writePipe); /* 3 */ - int (*tclpCreateProcess) (Tcl_Interp *interp, int argc, const char **argv, TclFile inputFile, TclFile outputFile, TclFile errorFile, Tcl_Pid *pidPtr); /* 4 */ + void * (*tclWinGetTclInstance) (void); /* 4 */ int (*tclUnixWaitForFile) (int fd, int mask, int timeout); /* 5 */ TclFile (*tclpMakeFile) (Tcl_Channel channel, int direction); /* 6 */ TclFile (*tclpOpenFile) (const char *fname, int mode); /* 7 */ - int (*tclUnixWaitForFile_) (int fd, int mask, int timeout); /* 8 */ - TclFile (*tclpCreateTempFile_) (const char *contents); /* 9 */ + size_t (*tclpGetPid) (Tcl_Pid pid); /* 8 */ + TclFile (*tclpCreateTempFile) (const char *contents); /* 9 */ void (*reserved10)(void); void (*tclGetAndDetachPids) (Tcl_Interp *interp, Tcl_Channel chan); /* 11 */ void (*reserved12)(void); - Tcl_Channel (*tclpCreateCommandChannel) (TclFile readFile, TclFile writeFile, TclFile errorFile, int numPids, Tcl_Pid *pidPtr); /* 13 */ - int (*tclUnixCopyFile) (const char *src, const char *dst, const Tcl_StatBuf *statBufPtr, int dontCopyAtts); /* 14 */ - void (*reserved15)(void); - void (*reserved16)(void); - void (*reserved17)(void); + void (*reserved13)(void); + int (*tclpCreatePipe_) (TclFile *readPipe, TclFile *writePipe); /* 14 */ + int (*tclpCreateProcess) (Tcl_Interp *interp, int argc, const char **argv, TclFile inputFile, TclFile outputFile, TclFile errorFile, Tcl_Pid *pidPtr); /* 15 */ + int (*tclpIsAtty) (int fd); /* 16 */ + int (*tclUnixCopyFile) (const char *src, const char *dst, const Tcl_StatBuf *statBufPtr, int dontCopyAtts); /* 17 */ void (*reserved18)(void); void (*tclMacOSXNotifierAddRunLoopMode) (const void *runLoopMode); /* 19 */ - void (*reserved20)(void); + void (*tclWinAddProcess) (void *hProcess, size_t id); /* 20 */ void (*reserved21)(void); - TclFile (*tclpCreateTempFile) (const char *contents); /* 22 */ + TclFile (*tclpCreateTempFile_) (const char *contents); /* 22 */ void (*reserved23)(void); - void (*reserved24)(void); + char * (*tclWinNoBackslash) (char *path); /* 24 */ void (*reserved25)(void); void (*reserved26)(void); - void (*reserved27)(void); + void (*tclWinFlushDirtyChannels) (void); /* 27 */ void (*reserved28)(void); int (*tclWinCPUID) (int index, int *regs); /* 29 */ int (*tclUnixOpenTemporaryFile) (Tcl_Obj *dirObj, Tcl_Obj *basenameObj, Tcl_Obj *extensionObj, Tcl_Obj *resultingNameObj); /* 30 */ @@ -349,49 +364,54 @@ extern const TclIntPlatStubs *tclIntPlatStubsPtr; */ #if !defined(_WIN32) && !defined(__CYGWIN__) && !defined(MAC_OSX_TCL) /* UNIX */ -#define TclGetAndDetachPids_ \ - (tclIntPlatStubsPtr->tclGetAndDetachPids_) /* 0 */ +#define TclWinConvertError \ + (tclIntPlatStubsPtr->tclWinConvertError) /* 0 */ #define TclpCloseFile \ (tclIntPlatStubsPtr->tclpCloseFile) /* 1 */ -#define TclpCreateCommandChannel_ \ - (tclIntPlatStubsPtr->tclpCreateCommandChannel_) /* 2 */ +#define TclpCreateCommandChannel \ + (tclIntPlatStubsPtr->tclpCreateCommandChannel) /* 2 */ #define TclpCreatePipe \ (tclIntPlatStubsPtr->tclpCreatePipe) /* 3 */ -#define TclpCreateProcess \ - (tclIntPlatStubsPtr->tclpCreateProcess) /* 4 */ +#define TclWinGetTclInstance \ + (tclIntPlatStubsPtr->tclWinGetTclInstance) /* 4 */ #define TclUnixWaitForFile \ (tclIntPlatStubsPtr->tclUnixWaitForFile) /* 5 */ #define TclpMakeFile \ (tclIntPlatStubsPtr->tclpMakeFile) /* 6 */ #define TclpOpenFile \ (tclIntPlatStubsPtr->tclpOpenFile) /* 7 */ -#define TclUnixWaitForFile_ \ - (tclIntPlatStubsPtr->tclUnixWaitForFile_) /* 8 */ -#define TclpCreateTempFile_ \ - (tclIntPlatStubsPtr->tclpCreateTempFile_) /* 9 */ +#define TclpGetPid \ + (tclIntPlatStubsPtr->tclpGetPid) /* 8 */ +#define TclpCreateTempFile \ + (tclIntPlatStubsPtr->tclpCreateTempFile) /* 9 */ /* Slot 10 is reserved */ #define TclGetAndDetachPids \ (tclIntPlatStubsPtr->tclGetAndDetachPids) /* 11 */ /* Slot 12 is reserved */ -#define TclpCreateCommandChannel \ - (tclIntPlatStubsPtr->tclpCreateCommandChannel) /* 13 */ +/* Slot 13 is reserved */ +#define TclpCreatePipe_ \ + (tclIntPlatStubsPtr->tclpCreatePipe_) /* 14 */ +#define TclpCreateProcess \ + (tclIntPlatStubsPtr->tclpCreateProcess) /* 15 */ +#define TclpIsAtty \ + (tclIntPlatStubsPtr->tclpIsAtty) /* 16 */ #define TclUnixCopyFile \ - (tclIntPlatStubsPtr->tclUnixCopyFile) /* 14 */ -/* Slot 15 is reserved */ -/* Slot 16 is reserved */ -/* Slot 17 is reserved */ + (tclIntPlatStubsPtr->tclUnixCopyFile) /* 17 */ /* Slot 18 is reserved */ #define TclMacOSXNotifierAddRunLoopMode \ (tclIntPlatStubsPtr->tclMacOSXNotifierAddRunLoopMode) /* 19 */ -/* Slot 20 is reserved */ +#define TclWinAddProcess \ + (tclIntPlatStubsPtr->tclWinAddProcess) /* 20 */ /* Slot 21 is reserved */ -#define TclpCreateTempFile \ - (tclIntPlatStubsPtr->tclpCreateTempFile) /* 22 */ +#define TclpCreateTempFile_ \ + (tclIntPlatStubsPtr->tclpCreateTempFile_) /* 22 */ /* Slot 23 is reserved */ -/* Slot 24 is reserved */ +#define TclWinNoBackslash \ + (tclIntPlatStubsPtr->tclWinNoBackslash) /* 24 */ /* Slot 25 is reserved */ /* Slot 26 is reserved */ -/* Slot 27 is reserved */ +#define TclWinFlushDirtyChannels \ + (tclIntPlatStubsPtr->tclWinFlushDirtyChannels) /* 27 */ /* Slot 28 is reserved */ #define TclWinCPUID \ (tclIntPlatStubsPtr->tclWinCPUID) /* 29 */ @@ -401,42 +421,48 @@ extern const TclIntPlatStubs *tclIntPlatStubsPtr; #if defined(_WIN32) || defined(__CYGWIN__) /* WIN */ #define TclWinConvertError \ (tclIntPlatStubsPtr->tclWinConvertError) /* 0 */ -/* Slot 1 is reserved */ -/* Slot 2 is reserved */ -/* Slot 3 is reserved */ +#define TclpCloseFile \ + (tclIntPlatStubsPtr->tclpCloseFile) /* 1 */ +#define TclpCreateCommandChannel \ + (tclIntPlatStubsPtr->tclpCreateCommandChannel) /* 2 */ +#define TclpCreatePipe \ + (tclIntPlatStubsPtr->tclpCreatePipe) /* 3 */ #define TclWinGetTclInstance \ (tclIntPlatStubsPtr->tclWinGetTclInstance) /* 4 */ #define TclUnixWaitForFile \ (tclIntPlatStubsPtr->tclUnixWaitForFile) /* 5 */ -/* Slot 6 is reserved */ -/* Slot 7 is reserved */ +#define TclpMakeFile \ + (tclIntPlatStubsPtr->tclpMakeFile) /* 6 */ +#define TclpOpenFile \ + (tclIntPlatStubsPtr->tclpOpenFile) /* 7 */ #define TclpGetPid \ (tclIntPlatStubsPtr->tclpGetPid) /* 8 */ -/* Slot 9 is reserved */ +#define TclpCreateTempFile \ + (tclIntPlatStubsPtr->tclpCreateTempFile) /* 9 */ /* Slot 10 is reserved */ #define TclGetAndDetachPids \ (tclIntPlatStubsPtr->tclGetAndDetachPids) /* 11 */ -#define TclpCloseFile \ - (tclIntPlatStubsPtr->tclpCloseFile) /* 12 */ -#define TclpCreateCommandChannel \ - (tclIntPlatStubsPtr->tclpCreateCommandChannel) /* 13 */ -#define TclpCreatePipe \ - (tclIntPlatStubsPtr->tclpCreatePipe) /* 14 */ +#define TclpCloseFile_ \ + (tclIntPlatStubsPtr->tclpCloseFile_) /* 12 */ +#define TclpCreateCommandChannel_ \ + (tclIntPlatStubsPtr->tclpCreateCommandChannel_) /* 13 */ +#define TclpCreatePipe_ \ + (tclIntPlatStubsPtr->tclpCreatePipe_) /* 14 */ #define TclpCreateProcess \ (tclIntPlatStubsPtr->tclpCreateProcess) /* 15 */ #define TclpIsAtty \ (tclIntPlatStubsPtr->tclpIsAtty) /* 16 */ #define TclUnixCopyFile \ (tclIntPlatStubsPtr->tclUnixCopyFile) /* 17 */ -#define TclpMakeFile \ - (tclIntPlatStubsPtr->tclpMakeFile) /* 18 */ -#define TclpOpenFile \ - (tclIntPlatStubsPtr->tclpOpenFile) /* 19 */ +#define TclpMakeFile_ \ + (tclIntPlatStubsPtr->tclpMakeFile_) /* 18 */ +#define TclpOpenFile_ \ + (tclIntPlatStubsPtr->tclpOpenFile_) /* 19 */ #define TclWinAddProcess \ (tclIntPlatStubsPtr->tclWinAddProcess) /* 20 */ /* Slot 21 is reserved */ -#define TclpCreateTempFile \ - (tclIntPlatStubsPtr->tclpCreateTempFile) /* 22 */ +#define TclpCreateTempFile_ \ + (tclIntPlatStubsPtr->tclpCreateTempFile_) /* 22 */ /* Slot 23 is reserved */ #define TclWinNoBackslash \ (tclIntPlatStubsPtr->tclWinNoBackslash) /* 24 */ @@ -451,49 +477,54 @@ extern const TclIntPlatStubs *tclIntPlatStubsPtr; (tclIntPlatStubsPtr->tclUnixOpenTemporaryFile) /* 30 */ #endif /* WIN */ #ifdef MAC_OSX_TCL /* MACOSX */ -#define TclGetAndDetachPids_ \ - (tclIntPlatStubsPtr->tclGetAndDetachPids_) /* 0 */ +#define TclWinConvertError \ + (tclIntPlatStubsPtr->tclWinConvertError) /* 0 */ #define TclpCloseFile \ (tclIntPlatStubsPtr->tclpCloseFile) /* 1 */ -#define TclpCreateCommandChannel_ \ - (tclIntPlatStubsPtr->tclpCreateCommandChannel_) /* 2 */ +#define TclpCreateCommandChannel \ + (tclIntPlatStubsPtr->tclpCreateCommandChannel) /* 2 */ #define TclpCreatePipe \ (tclIntPlatStubsPtr->tclpCreatePipe) /* 3 */ -#define TclpCreateProcess \ - (tclIntPlatStubsPtr->tclpCreateProcess) /* 4 */ +#define TclWinGetTclInstance \ + (tclIntPlatStubsPtr->tclWinGetTclInstance) /* 4 */ #define TclUnixWaitForFile \ (tclIntPlatStubsPtr->tclUnixWaitForFile) /* 5 */ #define TclpMakeFile \ (tclIntPlatStubsPtr->tclpMakeFile) /* 6 */ #define TclpOpenFile \ (tclIntPlatStubsPtr->tclpOpenFile) /* 7 */ -#define TclUnixWaitForFile_ \ - (tclIntPlatStubsPtr->tclUnixWaitForFile_) /* 8 */ -#define TclpCreateTempFile_ \ - (tclIntPlatStubsPtr->tclpCreateTempFile_) /* 9 */ +#define TclpGetPid \ + (tclIntPlatStubsPtr->tclpGetPid) /* 8 */ +#define TclpCreateTempFile \ + (tclIntPlatStubsPtr->tclpCreateTempFile) /* 9 */ /* Slot 10 is reserved */ #define TclGetAndDetachPids \ (tclIntPlatStubsPtr->tclGetAndDetachPids) /* 11 */ /* Slot 12 is reserved */ -#define TclpCreateCommandChannel \ - (tclIntPlatStubsPtr->tclpCreateCommandChannel) /* 13 */ +/* Slot 13 is reserved */ +#define TclpCreatePipe_ \ + (tclIntPlatStubsPtr->tclpCreatePipe_) /* 14 */ +#define TclpCreateProcess \ + (tclIntPlatStubsPtr->tclpCreateProcess) /* 15 */ +#define TclpIsAtty \ + (tclIntPlatStubsPtr->tclpIsAtty) /* 16 */ #define TclUnixCopyFile \ - (tclIntPlatStubsPtr->tclUnixCopyFile) /* 14 */ -/* Slot 15 is reserved */ -/* Slot 16 is reserved */ -/* Slot 17 is reserved */ + (tclIntPlatStubsPtr->tclUnixCopyFile) /* 17 */ /* Slot 18 is reserved */ #define TclMacOSXNotifierAddRunLoopMode \ (tclIntPlatStubsPtr->tclMacOSXNotifierAddRunLoopMode) /* 19 */ -/* Slot 20 is reserved */ +#define TclWinAddProcess \ + (tclIntPlatStubsPtr->tclWinAddProcess) /* 20 */ /* Slot 21 is reserved */ -#define TclpCreateTempFile \ - (tclIntPlatStubsPtr->tclpCreateTempFile) /* 22 */ +#define TclpCreateTempFile_ \ + (tclIntPlatStubsPtr->tclpCreateTempFile_) /* 22 */ /* Slot 23 is reserved */ -/* Slot 24 is reserved */ +#define TclWinNoBackslash \ + (tclIntPlatStubsPtr->tclWinNoBackslash) /* 24 */ /* Slot 25 is reserved */ /* Slot 26 is reserved */ -/* Slot 27 is reserved */ +#define TclWinFlushDirtyChannels \ + (tclIntPlatStubsPtr->tclWinFlushDirtyChannels) /* 27 */ /* Slot 28 is reserved */ #define TclWinCPUID \ (tclIntPlatStubsPtr->tclWinCPUID) /* 29 */ @@ -509,9 +540,6 @@ extern const TclIntPlatStubs *tclIntPlatStubsPtr; #define TCL_STORAGE_CLASS DLLIMPORT #define TclWinConvertWSAError TclWinConvertError -#undef TclpCreateTempFile_ -#undef TclUnixWaitForFile_ -#undef TclMacOSXNotifierAddRunLoopMode #ifdef MAC_OSX_TCL /* not accessable on Win32/UNIX */ MODULE_SCOPE int TclMacOSXGetFileAttribute(Tcl_Interp *interp, int objIndex, Tcl_Obj *fileName, diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c index 54001b2..aef2d23 100644 --- a/generic/tclStubInit.c +++ b/generic/tclStubInit.c @@ -145,14 +145,12 @@ static void uniCodePanic() { #define TclBN_mp_toom_sqr s_mp_toom_sqr #define TclpCreateTempFile_ TclpCreateTempFile -#define TclUnixWaitForFile_ TclUnixWaitForFile #define TclGetAndDetachPids_ TclGetAndDetachPids #define TclpCreateCommandChannel_ TclpCreateCommandChannel +#define TclpCloseFile_ TclpCloseFile +#define TclpMakeFile_ TclpMakeFile +#define TclpOpenFile_ TclpOpenFile #ifndef MAC_OSX_TCL /* On UNIX, fill with other stub entries */ -# define TclMacOSXGetFileAttribute (int (*)(Tcl_Interp *, int, Tcl_Obj *, Tcl_Obj **))(void *)TclpCreateProcess -# define TclMacOSXSetFileAttribute (int (*)(Tcl_Interp *, int, Tcl_Obj *, Tcl_Obj *))(void *)isatty -# define TclMacOSXCopyFileAttributes (int (*)(const char *, const char *, const Tcl_StatBuf *))(void *)TclUnixCopyFile -# define TclMacOSXMatchType (int (*)(Tcl_Interp *, const char *, const char *, Tcl_StatBuf *, Tcl_GlobTypeData *))(void *)TclpMakeFile # define Tcl_MacOSXOpenVersionedBundleResources 0 # define Tcl_MacOSXNotifierAddRunLoopMode 0 #endif @@ -161,6 +159,10 @@ static void uniCodePanic() { # define Tcl_CreateFileHandler 0 # define Tcl_DeleteFileHandler 0 # define Tcl_GetOpenFile 0 +# define TclpCreatePipe_ TclpCreatePipe +#else +# define TclpIsAtty isatty +# define TclpCreatePipe_ (int (*)(TclFile *, TclFile *))(void *)TclUnixCopyFile #endif #ifdef _WIN32 @@ -168,6 +170,7 @@ static void uniCodePanic() { # define TclUnixCopyFile 0 # define TclUnixOpenTemporaryFile 0 # define TclpReaddir 0 +# undef TclpIsAtty # define TclpIsAtty 0 #elif defined(__CYGWIN__) # define TclpIsAtty isatty @@ -256,7 +259,14 @@ static int utfNcasecmp(const char *s1, const char *s2, unsigned int n){ #endif /* TCL_WIDE_INT_IS_LONG */ -#endif /* __CYGWIN__ */ +#else /* __CYGWIN__ */ +# define TclWinGetTclInstance (void *(*)(void))(void *)TclpCreateProcess +# define TclpGetPid (size_t(*)(Tcl_Pid))(void *)TclUnixWaitForFile +# define TclWinConvertError (void(*)(int))(void *)TclGetAndDetachPids +# define TclWinFlushDirtyChannels 0 +# define TclWinNoBackslash 0 +# define TclWinAddProcess 0 +#endif /* * WARNING: The contents of this file is automatically generated by the @@ -548,62 +558,62 @@ static const TclIntPlatStubs tclIntPlatStubs = { TCL_STUB_MAGIC, 0, #if !defined(_WIN32) && !defined(__CYGWIN__) && !defined(MAC_OSX_TCL) /* UNIX */ - TclGetAndDetachPids_, /* 0 */ + TclWinConvertError, /* 0 */ TclpCloseFile, /* 1 */ - TclpCreateCommandChannel_, /* 2 */ + TclpCreateCommandChannel, /* 2 */ TclpCreatePipe, /* 3 */ - TclpCreateProcess, /* 4 */ + TclWinGetTclInstance, /* 4 */ TclUnixWaitForFile, /* 5 */ TclpMakeFile, /* 6 */ TclpOpenFile, /* 7 */ - TclUnixWaitForFile_, /* 8 */ - TclpCreateTempFile_, /* 9 */ + TclpGetPid, /* 8 */ + TclpCreateTempFile, /* 9 */ 0, /* 10 */ TclGetAndDetachPids, /* 11 */ 0, /* 12 */ - TclpCreateCommandChannel, /* 13 */ - TclUnixCopyFile, /* 14 */ - 0, /* 15 */ - 0, /* 16 */ - 0, /* 17 */ + 0, /* 13 */ + TclpCreatePipe_, /* 14 */ + TclpCreateProcess, /* 15 */ + TclpIsAtty, /* 16 */ + TclUnixCopyFile, /* 17 */ 0, /* 18 */ TclMacOSXNotifierAddRunLoopMode, /* 19 */ - 0, /* 20 */ + TclWinAddProcess, /* 20 */ 0, /* 21 */ - TclpCreateTempFile, /* 22 */ + TclpCreateTempFile_, /* 22 */ 0, /* 23 */ - 0, /* 24 */ + TclWinNoBackslash, /* 24 */ 0, /* 25 */ 0, /* 26 */ - 0, /* 27 */ + TclWinFlushDirtyChannels, /* 27 */ 0, /* 28 */ TclWinCPUID, /* 29 */ TclUnixOpenTemporaryFile, /* 30 */ #endif /* UNIX */ #if defined(_WIN32) || defined(__CYGWIN__) /* WIN */ TclWinConvertError, /* 0 */ - 0, /* 1 */ - 0, /* 2 */ - 0, /* 3 */ + TclpCloseFile, /* 1 */ + TclpCreateCommandChannel, /* 2 */ + TclpCreatePipe, /* 3 */ TclWinGetTclInstance, /* 4 */ TclUnixWaitForFile, /* 5 */ - 0, /* 6 */ - 0, /* 7 */ + TclpMakeFile, /* 6 */ + TclpOpenFile, /* 7 */ TclpGetPid, /* 8 */ - 0, /* 9 */ + TclpCreateTempFile, /* 9 */ 0, /* 10 */ TclGetAndDetachPids, /* 11 */ - TclpCloseFile, /* 12 */ - TclpCreateCommandChannel, /* 13 */ - TclpCreatePipe, /* 14 */ + TclpCloseFile_, /* 12 */ + TclpCreateCommandChannel_, /* 13 */ + TclpCreatePipe_, /* 14 */ TclpCreateProcess, /* 15 */ TclpIsAtty, /* 16 */ TclUnixCopyFile, /* 17 */ - TclpMakeFile, /* 18 */ - TclpOpenFile, /* 19 */ + TclpMakeFile_, /* 18 */ + TclpOpenFile_, /* 19 */ TclWinAddProcess, /* 20 */ 0, /* 21 */ - TclpCreateTempFile, /* 22 */ + TclpCreateTempFile_, /* 22 */ 0, /* 23 */ TclWinNoBackslash, /* 24 */ 0, /* 25 */ @@ -614,34 +624,34 @@ static const TclIntPlatStubs tclIntPlatStubs = { TclUnixOpenTemporaryFile, /* 30 */ #endif /* WIN */ #ifdef MAC_OSX_TCL /* MACOSX */ - TclGetAndDetachPids_, /* 0 */ + TclWinConvertError, /* 0 */ TclpCloseFile, /* 1 */ - TclpCreateCommandChannel_, /* 2 */ + TclpCreateCommandChannel, /* 2 */ TclpCreatePipe, /* 3 */ - TclpCreateProcess, /* 4 */ + TclWinGetTclInstance, /* 4 */ TclUnixWaitForFile, /* 5 */ TclpMakeFile, /* 6 */ TclpOpenFile, /* 7 */ - TclUnixWaitForFile_, /* 8 */ - TclpCreateTempFile_, /* 9 */ + TclpGetPid, /* 8 */ + TclpCreateTempFile, /* 9 */ 0, /* 10 */ TclGetAndDetachPids, /* 11 */ 0, /* 12 */ - TclpCreateCommandChannel, /* 13 */ - TclUnixCopyFile, /* 14 */ - 0, /* 15 */ - 0, /* 16 */ - 0, /* 17 */ + 0, /* 13 */ + TclpCreatePipe_, /* 14 */ + TclpCreateProcess, /* 15 */ + TclpIsAtty, /* 16 */ + TclUnixCopyFile, /* 17 */ 0, /* 18 */ TclMacOSXNotifierAddRunLoopMode, /* 19 */ - 0, /* 20 */ + TclWinAddProcess, /* 20 */ 0, /* 21 */ - TclpCreateTempFile, /* 22 */ + TclpCreateTempFile_, /* 22 */ 0, /* 23 */ - 0, /* 24 */ + TclWinNoBackslash, /* 24 */ 0, /* 25 */ 0, /* 26 */ - 0, /* 27 */ + TclWinFlushDirtyChannels, /* 27 */ 0, /* 28 */ TclWinCPUID, /* 29 */ TclUnixOpenTemporaryFile, /* 30 */ -- cgit v0.12 From 0d15664cbdafeb59a53986a6e646b79f7e5124da Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 18 Feb 2021 11:31:11 +0000 Subject: Change (internal) signatures for TclpGetClicks/TclpGetSeconds to use "unsigned long long" in stead of Tcl_WideUInt as return value. --- generic/tclClock.c | 4 ++-- generic/tclInt.decls | 4 ++-- generic/tclIntDecls.h | 8 ++++---- unix/tclUnixTime.c | 16 ++++++++-------- win/tclWinTime.c | 8 ++++---- 5 files changed, 20 insertions(+), 20 deletions(-) diff --git a/generic/tclClock.c b/generic/tclClock.c index f05a7a1..8cb1b40 100644 --- a/generic/tclClock.c +++ b/generic/tclClock.c @@ -1762,13 +1762,13 @@ ClockClicksObjCmd( switch (index) { case CLICKS_MILLIS: Tcl_GetTime(&now); - clicks = (Tcl_WideInt) now.sec * 1000 + now.usec / 1000; + clicks = (Tcl_WideInt)(unsigned long)now.sec * 1000 + now.usec / 1000; break; case CLICKS_NATIVE: #ifdef TCL_WIDE_CLICKS clicks = TclpGetWideClicks(); #else - clicks = (Tcl_WideInt) TclpGetClicks(); + clicks = (Tcl_WideInt)TclpGetClicks(); #endif break; case CLICKS_MICROS: diff --git a/generic/tclInt.decls b/generic/tclInt.decls index 42e6899..3fbc571 100644 --- a/generic/tclInt.decls +++ b/generic/tclInt.decls @@ -151,10 +151,10 @@ declare 74 { void TclpFree(void *ptr) } declare 75 { - Tcl_WideUInt TclpGetClicks(void) + unsigned long long TclpGetClicks(void) } declare 76 { - Tcl_WideUInt TclpGetSeconds(void) + unsigned long long TclpGetSeconds(void) } declare 81 { void *TclpRealloc(void *ptr, size_t size) diff --git a/generic/tclIntDecls.h b/generic/tclIntDecls.h index 2969f27..23cf3e6 100644 --- a/generic/tclIntDecls.h +++ b/generic/tclIntDecls.h @@ -186,9 +186,9 @@ EXTERN void * TclpAlloc(size_t size); /* 74 */ EXTERN void TclpFree(void *ptr); /* 75 */ -EXTERN Tcl_WideUInt TclpGetClicks(void); +EXTERN unsigned long long TclpGetClicks(void); /* 76 */ -EXTERN Tcl_WideUInt TclpGetSeconds(void); +EXTERN unsigned long long TclpGetSeconds(void); /* Slot 77 is reserved */ /* Slot 78 is reserved */ /* Slot 79 is reserved */ @@ -663,8 +663,8 @@ typedef struct TclIntStubs { void (*reserved72)(void); void (*reserved73)(void); void (*tclpFree) (void *ptr); /* 74 */ - Tcl_WideUInt (*tclpGetClicks) (void); /* 75 */ - Tcl_WideUInt (*tclpGetSeconds) (void); /* 76 */ + unsigned long long (*tclpGetClicks) (void); /* 75 */ + unsigned long long (*tclpGetSeconds) (void); /* 76 */ void (*reserved77)(void); void (*reserved78)(void); void (*reserved79)(void); diff --git a/unix/tclUnixTime.c b/unix/tclUnixTime.c index dc48a32..990503d 100644 --- a/unix/tclUnixTime.c +++ b/unix/tclUnixTime.c @@ -49,10 +49,10 @@ void *tclTimeClientData = NULL; *---------------------------------------------------------------------- */ -Tcl_WideUInt +unsigned long long TclpGetSeconds(void) { - return time(NULL); + return (unsigned long long)time(NULL); } /* @@ -78,7 +78,7 @@ TclpGetMicroseconds(void) Tcl_Time time; tclGetTimeProcPtr(&time, tclTimeClientData); - return ((long long)time.sec)*1000000 + time.usec; + return ((long long)(unsigned long)time.sec)*1000000 + time.usec; } /* @@ -100,30 +100,30 @@ TclpGetMicroseconds(void) *---------------------------------------------------------------------- */ -Tcl_WideUInt +unsigned long long TclpGetClicks(void) { - Tcl_WideUInt now; + unsigned long long now; #ifdef NO_GETTOD if (tclGetTimeProcPtr != NativeGetTime) { Tcl_Time time; tclGetTimeProcPtr(&time, tclTimeClientData); - now = (Tcl_WideUInt)time.sec*1000000 + time.usec; + now = (unsigned long long)(unsigned long)time.sec*1000000 + time.usec; } else { /* * A semi-NativeGetTime, specialized to clicks. */ struct tms dummy; - now = (Tcl_WideUInt) times(&dummy); + now = (unsigned long long)times(&dummy); } #else Tcl_Time time; tclGetTimeProcPtr(&time, tclTimeClientData); - now = (Tcl_WideUInt)time.sec*1000000 + time.usec; + now = (unsigned long long)time.sec*1000000 + time.usec; #endif return now; diff --git a/win/tclWinTime.c b/win/tclWinTime.c index 3c52451..0bd5b7e 100644 --- a/win/tclWinTime.c +++ b/win/tclWinTime.c @@ -144,7 +144,7 @@ ClientData tclTimeClientData = NULL; *---------------------------------------------------------------------- */ -Tcl_WideUInt +unsigned long long TclpGetSeconds(void) { long long usecSincePosixEpoch; @@ -158,7 +158,7 @@ TclpGetSeconds(void) Tcl_Time t; tclGetTimeProcPtr(&t, tclTimeClientData); /* Tcl_GetTime inlined. */ - return t.sec; + return (unsigned long long)(unsigned long)t.sec; } } @@ -181,7 +181,7 @@ TclpGetSeconds(void) *---------------------------------------------------------------------- */ -Tcl_WideUInt +unsigned long long TclpGetClicks(void) { long long usecSincePosixEpoch; @@ -200,7 +200,7 @@ TclpGetClicks(void) Tcl_Time now; /* Current Tcl time */ tclGetTimeProcPtr(&now, tclTimeClientData); /* Tcl_GetTime inlined */ - return (Tcl_WideUInt)(now.sec * 1000000) + now.usec; + return ((unsigned long long)(unsigned long)now.sec * 1000000ULL) + now.usec; } } -- cgit v0.12 From bd8b8ff3b710e8ae5f4750eadc84c9d96c3ea4c7 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 24 Feb 2021 10:14:01 +0000 Subject: Final implementation tweaks, fix comments, allow Tcl to load from /lib (or /bin on win32/cygwin) even when this is not in your PATH. --- doc/zipfs.3 | 4 ++-- generic/tclStubCall.c | 22 ++++++++++++++++++---- generic/tclStubLib.c | 2 +- generic/tclStubLibTbl.c | 2 +- unix/Makefile.in | 7 +++++-- unix/configure.ac | 4 ---- win/Makefile.in | 5 ++++- win/makefile.vc | 5 ++++- 8 files changed, 35 insertions(+), 16 deletions(-) diff --git a/doc/zipfs.3 b/doc/zipfs.3 index f1efc65..2db6d67 100644 --- a/doc/zipfs.3 +++ b/doc/zipfs.3 @@ -87,8 +87,8 @@ it uses WCHAR instead of char. As a result, it requires your application to be compiled with the UNICODE preprocessor symbol defined (e.g., via the \fB-DUNICODE\fR compiler flag). .PP -The result of \fBTclZipfs_AppHook\fR is the Tcl version string(e.g., \fB"9.0"\fR -when the function is successful). The function \fImay\fR modify the variables +The result of \fBTclZipfs_AppHook\fR is the full Tcl version string(e.g., +\fB"9.0.0"\fR). The function \fImay\fR modify the variables pointed to by \fIargcPtr\fR and \fIargvPtr\fR to remove arguments; the current implementation does not do so, but callers \fIshould not\fR assume that this will be true in the future. diff --git a/generic/tclStubCall.c b/generic/tclStubCall.c index 8fe7892..96e3837 100644 --- a/generic/tclStubCall.c +++ b/generic/tclStubCall.c @@ -59,7 +59,7 @@ static const char CANNOTFIND[] = "Cannot find %s: %s\n"; MODULE_SCOPE void * TclStubCall(void *arg) { - static void *stubFn[] = {NULL,NULL,NULL,NULL,NULL,NULL,NULL}; + static void *stubFn[] = {NULL,NULL,NULL,NULL,NULL,NULL,NULL,NULL,NULL}; unsigned index = PTR2UINT(arg); if (index >= sizeof(PROCNAME)/sizeof(PROCNAME[0])) { @@ -76,12 +76,26 @@ TclStubCall(void *arg) } if (!stubFn[index]) { if (!tclStubsHandle) { - tclStubsHandle = dlopen(TCL_DLL_FILE, RTLD_NOW|RTLD_LOCAL); + tclStubsHandle = dlopen(CFG_RUNTIME_DLLFILE, RTLD_NOW|RTLD_LOCAL); + if (!tclStubsHandle) { + tclStubsHandle = dlopen( +#if defined(_WIN32) || defined(__CYGWIN__) + CFG_RUNTIME_BINDIR +#else + CFG_RUNTIME_LIBDIR +#endif +#if defined(_WIN32) + "\\" +#else + "/" +#endif + CFG_RUNTIME_DLLFILE, RTLD_NOW|RTLD_LOCAL); + } if (!tclStubsHandle) { if ((index == 0) && (arg != NULL)) { - ((Tcl_PanicProc *)arg)(CANNOTFIND, TCL_DLL_FILE, dlerror()); + ((Tcl_PanicProc *)arg)(CANNOTFIND, CFG_RUNTIME_DLLFILE, dlerror()); } else { - fprintf(stderr, CANNOTFIND, TCL_DLL_FILE, dlerror()); + fprintf(stderr, CANNOTFIND, CFG_RUNTIME_DLLFILE, dlerror()); abort(); } } diff --git a/generic/tclStubLib.c b/generic/tclStubLib.c index 32ca1f1..697d92f 100644 --- a/generic/tclStubLib.c +++ b/generic/tclStubLib.c @@ -109,7 +109,7 @@ Tcl_InitStubs( stubsPtr = (TclStubs *)pkgData; } if (tclStubsHandle == NULL) { - tclStubsHandle = (void *) -1; + tclStubsHandle = INT2PTR(-1); } tclStubsPtr = stubsPtr; diff --git a/generic/tclStubLibTbl.c b/generic/tclStubLibTbl.c index 32b3869..ad34494 100644 --- a/generic/tclStubLibTbl.c +++ b/generic/tclStubLibTbl.c @@ -40,7 +40,7 @@ TclInitStubTable( if (tclStubsHandle == NULL) { /* This can only happen with -DBUILD_STATIC, so simulate * that the loading of Tcl succeeded, although we didn't - * actually loaded it dynamically */ + * actually load it dynamically */ tclStubsHandle = (void *)1; } tclStubsPtr = ((const TclStubs **) version)[-1]; diff --git a/unix/Makefile.in b/unix/Makefile.in index 4e7b06c..936f2f2 100644 --- a/unix/Makefile.in +++ b/unix/Makefile.in @@ -201,7 +201,6 @@ BUILD_DLTEST = @BUILD_DLTEST@ TCL_LIB_FILE = @TCL_LIB_FILE@ #TCL_LIB_FILE = libtcl.a -TCL_PREV_LIB_FILE = @TCL_PREV_LIB_FILE@ # Generic lib name used in rules that apply to tcl and tk LIB_FILE = ${TCL_LIB_FILE} @@ -1914,7 +1913,11 @@ tclStubLib.o: $(GENERIC_DIR)/tclStubLib.c $(CC) -c $(STUB_CC_SWITCHES) -DSTATIC_BUILD @CFLAGS_NOLTO@ $(GENERIC_DIR)/tclStubLib.c tclStubCall.o: $(GENERIC_DIR)/tclStubCall.c - $(CC) -c $(STUB_CC_SWITCHES) -DSTATIC_BUILD -DTCL_DLL_FILE="\"$(TCL_LIB_FILE)\"" $(GENERIC_DIR)/tclStubCall.c + $(CC) -c $(STUB_CC_SWITCHES) -DSTATIC_BUILD \ + -DCFG_RUNTIME_DLLFILE="\"$(TCL_LIB_FILE)\"" \ + -DCFG_RUNTIME_LIBDIR="\"$(libdir)\"" \ + -DCFG_RUNTIME_BINDIR="\"$(bindir)\"" \ + $(GENERIC_DIR)/tclStubCall.c tclStubLibTbl.o: $(GENERIC_DIR)/tclStubLibTbl.c $(CC) -c $(STUB_CC_SWITCHES) -DSTATIC_BUILD $(GENERIC_DIR)/tclStubLibTbl.c diff --git a/unix/configure.ac b/unix/configure.ac index 08aa2b3..685a335 100644 --- a/unix/configure.ac +++ b/unix/configure.ac @@ -864,9 +864,6 @@ else TCL_BUILD_LIB_SPEC="-L`pwd | sed -e 's/ /\\\\ /g'` ${TCL_LIB_FLAG}" TCL_LIB_SPEC="-L${libdir} ${TCL_LIB_FLAG}" fi -VERSION='8.5' -eval "TCL_PREV_LIB_FILE=libtcl${TCL_SHARED_LIB_SUFFIX}" -eval "TCL_PREV_LIB_FILE=${TCL_PREV_LIB_FILE}" VERSION='${VERSION}' eval "CFG_TCL_SHARED_LIB_SUFFIX=${TCL_SHARED_LIB_SUFFIX}" eval "CFG_TCL_UNSHARED_LIB_SUFFIX=${TCL_UNSHARED_LIB_SUFFIX}" @@ -974,7 +971,6 @@ AC_SUBST(PKG_CFG_ARGS) AC_SUBST(TCL_ZIP_FILE) AC_SUBST(TCL_LIB_FILE) -AC_SUBST(TCL_PREV_LIB_FILE) AC_SUBST(TCL_LIB_FLAG) AC_SUBST(TCL_LIB_SPEC) AC_SUBST(TCL_STUB_LIB_FILE) diff --git a/win/Makefile.in b/win/Makefile.in index 57cb7ef..1ce1c9d 100644 --- a/win/Makefile.in +++ b/win/Makefile.in @@ -682,7 +682,10 @@ tclStubLib.${OBJEXT}: tclStubLib.c $(CC) -c $(CC_SWITCHES) -DSTATIC_BUILD @CFLAGS_NOLTO@ @DEPARG@ $(CC_OBJNAME) tclStubCall.${OBJEXT}: tclStubCall.c - $(CC) -c $(CC_SWITCHES) -DSTATIC_BUILD -DTCL_DLL_FILE="\"$(TCL_DLL_FILE)\"" @DEPARG@ $(CC_OBJNAME) + $(CC) -c $(CC_SWITCHES) -DSTATIC_BUILD \ + -DCFG_RUNTIME_DLLFILE="\"$(TCL_DLL_FILE)\"" \ + -DCFG_RUNTIME_BINDIR="\"$(bindir_native)\"" \ + @DEPARG@ $(CC_OBJNAME) tclStubLibTbl.${OBJEXT}: tclStubLibTbl.c $(CC) -c $(CC_SWITCHES) -DSTATIC_BUILD @DEPARG@ $(CC_OBJNAME) diff --git a/win/makefile.vc b/win/makefile.vc index 67c7c36..03a4419 100644 --- a/win/makefile.vc +++ b/win/makefile.vc @@ -864,7 +864,10 @@ $(TMP_DIR)\tclStubLib.obj: $(GENERICDIR)\tclStubLib.c $(cc32) $(stubscflags) -Fo$@ $? $(TMP_DIR)\tclStubCall.obj: $(GENERICDIR)\tclStubCall.c - $(cc32) $(stubscflags) -DTCL_DLL_FILE="\"tcl$(TCL_VERSION)$(SUFX:t=).dll\"" $(TCL_INCLUDES) -Fo$@ $? + $(cc32) $(stubscflags) \ + /DCFG_RUNTIME_DLLFILE="\"$(TCLLIBNAME)\"" \ + /DCFG_RUNTIME_BINDIR="\"$(BIN_INSTALL_DIR:\=\\)\"" \ + $(TCL_INCLUDES) -Fo$@ $? $(TMP_DIR)\tclStubLibTbl.obj: $(GENERICDIR)\tclStubLibTbl.c $(cc32) $(stubscflags) $(TCL_INCLUDES) -Fo$@ $? -- cgit v0.12 From 6eb27e1aaa13ae6877fde25f4d1f2110e2809cde Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 26 Feb 2021 09:10:49 +0000 Subject: Try to fix Visual Studio build --- generic/tclStubCall.c | 15 +++++---------- 1 file changed, 5 insertions(+), 10 deletions(-) diff --git a/generic/tclStubCall.c b/generic/tclStubCall.c index 96e3837..8ec3155 100644 --- a/generic/tclStubCall.c +++ b/generic/tclStubCall.c @@ -60,7 +60,7 @@ MODULE_SCOPE void * TclStubCall(void *arg) { static void *stubFn[] = {NULL,NULL,NULL,NULL,NULL,NULL,NULL,NULL,NULL}; - unsigned index = PTR2UINT(arg); + size_t index = PTR2UINT(arg); if (index >= sizeof(PROCNAME)/sizeof(PROCNAME[0])) { /* Any other value means Tcl_SetPanicProc() with non-null panicProc */ @@ -78,18 +78,13 @@ TclStubCall(void *arg) if (!tclStubsHandle) { tclStubsHandle = dlopen(CFG_RUNTIME_DLLFILE, RTLD_NOW|RTLD_LOCAL); if (!tclStubsHandle) { - tclStubsHandle = dlopen( -#if defined(_WIN32) || defined(__CYGWIN__) - CFG_RUNTIME_BINDIR -#else - CFG_RUNTIME_LIBDIR -#endif #if defined(_WIN32) - "\\" + tclStubsHandle = dlopen(CFG_RUNTIME_BINDIR "\\" CFG_RUNTIME_DLLFILE, RTLD_NOW|RTLD_LOCAL); +#elif defined(__CYGWIN__) + tclStubsHandle = dlopen(CFG_RUNTIME_BINDIR "/" CFG_RUNTIME_DLLFILE, RTLD_NOW|RTLD_LOCAL); #else - "/" + tclStubsHandle = dlopen(CFG_RUNTIME_LIBDIR "/" CFG_RUNTIME_DLLFILE, RTLD_NOW|RTLD_LOCAL); #endif - CFG_RUNTIME_DLLFILE, RTLD_NOW|RTLD_LOCAL); } if (!tclStubsHandle) { if ((index == 0) && (arg != NULL)) { -- cgit v0.12 From 3cbac4bb5be49ca8f19243442343db01c08bb733 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 10 Mar 2021 07:51:34 +0000 Subject: Move internal stub entry 260 to 259, the same place it is in 8.7. --- generic/tclInt.decls | 16 +++++++++------- generic/tclIntDecls.h | 19 ++++++++----------- generic/tclStubInit.c | 5 ++--- 3 files changed, 19 insertions(+), 21 deletions(-) diff --git a/generic/tclInt.decls b/generic/tclInt.decls index d7ea540..eb18fd8 100644 --- a/generic/tclInt.decls +++ b/generic/tclInt.decls @@ -468,6 +468,7 @@ declare 232 { declare 233 { void TclGetSrcInfoForPc(CmdFrame *contextPtr) } + # Exports for VarReform compat: Itcl, XOTcl like to peek into our varTables :( declare 234 { Var *TclVarHashCreateVar(TclVarHashTable *tablePtr, const char *key, @@ -476,10 +477,17 @@ declare 234 { declare 235 { void TclInitVarHashTable(TclVarHashTable *tablePtr, Namespace *nsPtr) } +# TIP 542 +declare 236 { + void TclAppendUnicodeToObj(Tcl_Obj *objPtr, + const Tcl_UniChar *unicode, size_t length) +} + # TIP #285: Script cancellation support. declare 237 { int TclResetCancellation(Tcl_Interp *interp, int force) } + # NRE functions for "rogue" extensions to exploit NRE; they will need to # include NRE.h too. declare 238 { @@ -568,7 +576,6 @@ declare 256 { int TclPtrUnsetVar(Tcl_Interp *interp, Tcl_Var varPtr, Tcl_Var arrayPtr, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, const int flags) } - declare 257 { void TclStaticPackage(Tcl_Interp *interp, const char *pkgName, Tcl_PackageInitProc *initProc, Tcl_PackageInitProc *safeInitProc) @@ -579,13 +586,8 @@ declare 258 { Tcl_Obj *TclpCreateTemporaryDirectory(Tcl_Obj *dirObj, Tcl_Obj *basenameObj) } -# TIP 542 -declare 259 { - void TclAppendUnicodeToObj(Tcl_Obj *objPtr, - const Tcl_UniChar *unicode, size_t length) -} -declare 260 { +declare 259 { unsigned char *TclGetBytesFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr, size_t *lengthPtr) } diff --git a/generic/tclIntDecls.h b/generic/tclIntDecls.h index 23cf3e6..fc0a9a3 100644 --- a/generic/tclIntDecls.h +++ b/generic/tclIntDecls.h @@ -501,7 +501,9 @@ EXTERN Var * TclVarHashCreateVar(TclVarHashTable *tablePtr, /* 235 */ EXTERN void TclInitVarHashTable(TclVarHashTable *tablePtr, Namespace *nsPtr); -/* Slot 236 is reserved */ +/* 236 */ +EXTERN void TclAppendUnicodeToObj(Tcl_Obj *objPtr, + const Tcl_UniChar *unicode, size_t length); /* 237 */ EXTERN int TclResetCancellation(Tcl_Interp *interp, int force); /* 238 */ @@ -578,9 +580,6 @@ EXTERN void TclStaticPackage(Tcl_Interp *interp, EXTERN Tcl_Obj * TclpCreateTemporaryDirectory(Tcl_Obj *dirObj, Tcl_Obj *basenameObj); /* 259 */ -EXTERN void TclAppendUnicodeToObj(Tcl_Obj *objPtr, - const Tcl_UniChar *unicode, size_t length); -/* 260 */ EXTERN unsigned char * TclGetBytesFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr, size_t *lengthPtr); @@ -824,7 +823,7 @@ typedef struct TclIntStubs { void (*tclGetSrcInfoForPc) (CmdFrame *contextPtr); /* 233 */ Var * (*tclVarHashCreateVar) (TclVarHashTable *tablePtr, const char *key, int *newPtr); /* 234 */ void (*tclInitVarHashTable) (TclVarHashTable *tablePtr, Namespace *nsPtr); /* 235 */ - void (*reserved236)(void); + void (*tclAppendUnicodeToObj) (Tcl_Obj *objPtr, const Tcl_UniChar *unicode, size_t length); /* 236 */ int (*tclResetCancellation) (Tcl_Interp *interp, int force); /* 237 */ int (*tclNRInterpProc) (void *clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); /* 238 */ int (*tclNRInterpProcCore) (Tcl_Interp *interp, Tcl_Obj *procNameObj, int skip, ProcErrorProc *errorProc); /* 239 */ @@ -847,8 +846,7 @@ typedef struct TclIntStubs { int (*tclPtrUnsetVar) (Tcl_Interp *interp, Tcl_Var varPtr, Tcl_Var arrayPtr, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, const int flags); /* 256 */ void (*tclStaticPackage) (Tcl_Interp *interp, const char *pkgName, Tcl_PackageInitProc *initProc, Tcl_PackageInitProc *safeInitProc); /* 257 */ Tcl_Obj * (*tclpCreateTemporaryDirectory) (Tcl_Obj *dirObj, Tcl_Obj *basenameObj); /* 258 */ - void (*tclAppendUnicodeToObj) (Tcl_Obj *objPtr, const Tcl_UniChar *unicode, size_t length); /* 259 */ - unsigned char * (*tclGetBytesFromObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, size_t *lengthPtr); /* 260 */ + unsigned char * (*tclGetBytesFromObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, size_t *lengthPtr); /* 259 */ } TclIntStubs; extern const TclIntStubs *tclIntStubsPtr; @@ -1219,7 +1217,8 @@ extern const TclIntStubs *tclIntStubsPtr; (tclIntStubsPtr->tclVarHashCreateVar) /* 234 */ #define TclInitVarHashTable \ (tclIntStubsPtr->tclInitVarHashTable) /* 235 */ -/* Slot 236 is reserved */ +#define TclAppendUnicodeToObj \ + (tclIntStubsPtr->tclAppendUnicodeToObj) /* 236 */ #define TclResetCancellation \ (tclIntStubsPtr->tclResetCancellation) /* 237 */ #define TclNRInterpProc \ @@ -1264,10 +1263,8 @@ extern const TclIntStubs *tclIntStubsPtr; (tclIntStubsPtr->tclStaticPackage) /* 257 */ #define TclpCreateTemporaryDirectory \ (tclIntStubsPtr->tclpCreateTemporaryDirectory) /* 258 */ -#define TclAppendUnicodeToObj \ - (tclIntStubsPtr->tclAppendUnicodeToObj) /* 259 */ #define TclGetBytesFromObj \ - (tclIntStubsPtr->tclGetBytesFromObj) /* 260 */ + (tclIntStubsPtr->tclGetBytesFromObj) /* 259 */ #endif /* defined(USE_TCL_STUBS) */ diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c index f6b8b0d..e1ba73e 100644 --- a/generic/tclStubInit.c +++ b/generic/tclStubInit.c @@ -527,7 +527,7 @@ static const TclIntStubs tclIntStubs = { TclGetSrcInfoForPc, /* 233 */ TclVarHashCreateVar, /* 234 */ TclInitVarHashTable, /* 235 */ - 0, /* 236 */ + TclAppendUnicodeToObj, /* 236 */ TclResetCancellation, /* 237 */ TclNRInterpProc, /* 238 */ TclNRInterpProcCore, /* 239 */ @@ -550,8 +550,7 @@ static const TclIntStubs tclIntStubs = { TclPtrUnsetVar, /* 256 */ TclStaticPackage, /* 257 */ TclpCreateTemporaryDirectory, /* 258 */ - TclAppendUnicodeToObj, /* 259 */ - TclGetBytesFromObj, /* 260 */ + TclGetBytesFromObj, /* 259 */ }; static const TclIntPlatStubs tclIntPlatStubs = { -- cgit v0.12 From 7429625aafffe2055c21ac133cb885cccb0b8ad2 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 22 Mar 2021 12:36:02 +0000 Subject: test tweaks --- tests/load.test | 16 ++++++++-------- 1 file changed, 8 insertions(+), 8 deletions(-) diff --git a/tests/load.test b/tests/load.test index 857d1b3..c419bfb 100644 --- a/tests/load.test +++ b/tests/load.test @@ -174,7 +174,7 @@ test load-7.3 {Tcl_StaticLibrary procedure} [list teststaticlibrary] { catch {load [file join $testDir pkga$ext] Pkga} catch {load [file join $testDir pkgb$ext] Pkgb} catch {load [file join $testDir pkge$ext] Pkge} -set currentRealPackages [list [list [file join $testDir pkge$ext] Pkge] [list [file join $testDir pkgb$ext] Pkgb] [list [file join $testDir pkga$ext] Pkga]] +set currentRealLibraries [list [list [file join $testDir pkge$ext] Pkge] [list [file join $testDir pkgb$ext] Pkgb] [list [file join $testDir pkga$ext] Pkga]] test load-7.4 {Tcl_StaticLibrary procedure, redundant calls} -setup { teststaticlibrary Test 1 0 teststaticlibrary Another 0 0 @@ -183,7 +183,7 @@ test load-7.4 {Tcl_StaticLibrary procedure, redundant calls} -setup { teststaticlibrary Double 0 1 teststaticlibrary Double 0 1 info loaded -} -result [list {{} Double} {{} More} {{} Another} {{} Test} {*}$currentRealPackages {*}$alreadyTotalLoaded] +} -result [list {{} Double} {{} More} {{} Another} {{} Test} {*}$currentRealLibraries {*}$alreadyTotalLoaded] testConstraint teststaticlibrary_8.x 0 if {[testConstraint teststaticlibrary]} { @@ -196,19 +196,19 @@ if {[testConstraint teststaticlibrary]} { } } -test load-8.1 {TclGetLoadedPackages procedure} [list teststaticlibrary_8.x $dll $loaded] { +test load-8.1 {TclGetLoadedLibraries procedure} [list teststaticlibrary_8.x $dll $loaded] { lsort -index 1 [info loaded] -} [lsort -index 1 [list {{} Double} {{} More} {{} Another} {{} Test} {*}$currentRealPackages {*}$alreadyTotalLoaded]] -test load-8.2 {TclGetLoadedPackages procedure} -constraints {teststaticlibrary_8.x} -body { +} [lsort -index 1 [list {{} Double} {{} More} {{} Another} {{} Test} {*}$currentRealLibraries {*}$alreadyTotalLoaded]] +test load-8.2 {TclGetLoadedLibraries procedure} -constraints {teststaticlibrary_8.x} -body { info loaded gorp } -returnCodes error -result {could not find interpreter "gorp"} -test load-8.3a {TclGetLoadedPackages procedure} [list teststaticlibrary_8.x $dll $loaded] { +test load-8.3a {TclGetLoadedLibraries procedure} [list teststaticlibrary_8.x $dll $loaded] { lsort -index 1 [info loaded {}] } [lsort -index 1 [list {{} Double} {{} More} {{} Another} {{} Test} [list [file join $testDir pkga$ext] Pkga] [list [file join $testDir pkgb$ext] Pkgb] {*}$alreadyLoaded]] -test load-8.3b {TclGetLoadedPackages procedure} [list teststaticlibrary_8.x $dll $loaded] { +test load-8.3b {TclGetLoadedLibraries procedure} [list teststaticlibrary_8.x $dll $loaded] { lsort -index 1 [info loaded child] } [lsort -index 1 [list {{} Test} [list [file join $testDir pkgb$ext] Pkgb]]] -test load-8.4 {TclGetLoadedPackages procedure} [list teststaticlibrary_8.x $dll $loaded] { +test load-8.4 {TclGetLoadedLibraries procedure} [list teststaticlibrary_8.x $dll $loaded] { load [file join $testDir pkgb$ext] Pkgb list [lsort -index 1 [info loaded {}]] [lsort [info commands pkgb_*]] } [list [lsort -index 1 [concat [list [list [file join $testDir pkgb$ext] Pkgb] {{} Double} {{} More} {{} Another} {{} Test} [list [file join $testDir pkga$ext] Pkga]] $alreadyLoaded]] {pkgb_demo pkgb_sub pkgb_unsafe}] -- cgit v0.12 From 73019a8bbd67347ff72a37a7a57b7eb001689c8a Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 22 Mar 2021 17:20:23 +0000 Subject: indenting --- generic/tclLoad.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/generic/tclLoad.c b/generic/tclLoad.c index 4ab26bd..b565eba 100644 --- a/generic/tclLoad.c +++ b/generic/tclLoad.c @@ -332,7 +332,7 @@ Tcl_LoadObjCmd( for (p = pkgGuess; *p != 0; p += offset) { offset = TclUtfToUniChar(p, &ch); if (!Tcl_UniCharIsWordChar(UCHAR(ch)) - || Tcl_UniCharIsDigit(UCHAR(ch))) { + || Tcl_UniCharIsDigit(UCHAR(ch))) { break; } } -- cgit v0.12 From fa1e5ce70ab2eb900b31b03f0fddf2cc8c5243e8 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 23 Mar 2021 20:35:29 +0000 Subject: New Tcl_ExternalToUtfDStringEx/Tcl_UtfToExternalDStringEx functions. Not used yet --- generic/tcl.decls | 10 ++++++++++ generic/tclDecls.h | 14 ++++++++++++++ generic/tclEncoding.c | 53 ++++++++++++++++++++++++++++++++++++++++----------- generic/tclStubInit.c | 2 ++ 4 files changed, 68 insertions(+), 11 deletions(-) diff --git a/generic/tcl.decls b/generic/tcl.decls index c39847b..c2a4abd 100644 --- a/generic/tcl.decls +++ b/generic/tcl.decls @@ -2424,6 +2424,16 @@ declare 656 { const char *Tcl_UtfPrev(const char *src, const char *start) } +declare 657 { + int Tcl_ExternalToUtfDStringEx(Tcl_Encoding encoding, + const char *src, int srcLen, Tcl_DString *dsPtr, int flags) +} +declare 658 { + int Tcl_UtfToExternalDStringEx(Tcl_Encoding encoding, + const char *src, int srcLen, Tcl_DString *dsPtr, int flags) +} + + # ----- BASELINE -- FOR -- 8.7.0 ----- # ############################################################################## diff --git a/generic/tclDecls.h b/generic/tclDecls.h index e509c2b..6ba39d5 100644 --- a/generic/tclDecls.h +++ b/generic/tclDecls.h @@ -1937,6 +1937,14 @@ EXTERN int Tcl_UtfCharComplete(const char *src, int length); EXTERN const char * Tcl_UtfNext(const char *src); /* 656 */ EXTERN const char * Tcl_UtfPrev(const char *src, const char *start); +/* 657 */ +EXTERN int Tcl_ExternalToUtfDStringEx(Tcl_Encoding encoding, + const char *src, int srcLen, + Tcl_DString *dsPtr, int flags); +/* 658 */ +EXTERN int Tcl_UtfToExternalDStringEx(Tcl_Encoding encoding, + const char *src, int srcLen, + Tcl_DString *dsPtr, int flags); typedef struct { const struct TclPlatStubs *tclPlatStubs; @@ -2629,6 +2637,8 @@ typedef struct TclStubs { int (*tcl_UtfCharComplete) (const char *src, int length); /* 654 */ const char * (*tcl_UtfNext) (const char *src); /* 655 */ const char * (*tcl_UtfPrev) (const char *src, const char *start); /* 656 */ + int (*tcl_ExternalToUtfDStringEx) (Tcl_Encoding encoding, const char *src, int srcLen, Tcl_DString *dsPtr, int flags); /* 657 */ + int (*tcl_UtfToExternalDStringEx) (Tcl_Encoding encoding, const char *src, int srcLen, Tcl_DString *dsPtr, int flags); /* 658 */ } TclStubs; extern const TclStubs *tclStubsPtr; @@ -3971,6 +3981,10 @@ extern const TclStubs *tclStubsPtr; (tclStubsPtr->tcl_UtfNext) /* 655 */ #define Tcl_UtfPrev \ (tclStubsPtr->tcl_UtfPrev) /* 656 */ +#define Tcl_ExternalToUtfDStringEx \ + (tclStubsPtr->tcl_ExternalToUtfDStringEx) /* 657 */ +#define Tcl_UtfToExternalDStringEx \ + (tclStubsPtr->tcl_UtfToExternalDStringEx) /* 658 */ #endif /* defined(USE_TCL_STUBS) */ diff --git a/generic/tclEncoding.c b/generic/tclEncoding.c index 4eabbda..fd5c52b 100644 --- a/generic/tclEncoding.c +++ b/generic/tclEncoding.c @@ -1089,7 +1089,7 @@ Tcl_CreateEncoding( /* *------------------------------------------------------------------------- * - * Tcl_ExternalToUtfDString -- + * Tcl_ExternalToUtfDString/Tcl_ExternalToUtfDStringEx -- * * Convert a source buffer from the specified encoding into UTF-8. If any * of the bytes in the source buffer are invalid or cannot be represented @@ -1099,7 +1099,7 @@ Tcl_CreateEncoding( * Results: * The converted bytes are stored in the DString, which is then NULL * terminated. The return value is a pointer to the value stored in the - * DString. + * DString resp. an error code. * * Side effects: * None. @@ -1117,10 +1117,26 @@ Tcl_ExternalToUtfDString( Tcl_DString *dstPtr) /* Uninitialized or free DString in which the * converted string is stored. */ { + Tcl_ExternalToUtfDStringEx(encoding, src, srcLen, dstPtr, 0); + return Tcl_DStringValue(dstPtr); +} + + +int +Tcl_ExternalToUtfDStringEx( + Tcl_Encoding encoding, /* The encoding for the source string, or NULL + * for the default system encoding. */ + const char *src, /* Source string in specified encoding. */ + int srcLen, /* Source string length in bytes, or < 0 for + * encoding-specific string length. */ + Tcl_DString *dstPtr, /* Uninitialized or free DString in which the + * converted string is stored. */ + int flags) /* Conversion control flags. */ +{ char *dst; Tcl_EncodingState state; const Encoding *encodingPtr; - int flags, dstLen, result, soFar, srcRead, dstWrote, dstChars; + int dstLen, result, soFar, srcRead, dstWrote, dstChars; Tcl_DStringInit(dstPtr); dst = Tcl_DStringValue(dstPtr); @@ -1137,7 +1153,7 @@ Tcl_ExternalToUtfDString( srcLen = encodingPtr->lengthProc(src); } - flags = TCL_ENCODING_START | TCL_ENCODING_END; + flags |= TCL_ENCODING_START | TCL_ENCODING_END; while (1) { result = encodingPtr->toUtfProc(encodingPtr->clientData, src, srcLen, @@ -1146,7 +1162,7 @@ Tcl_ExternalToUtfDString( if (result != TCL_CONVERT_NOSPACE) { Tcl_DStringSetLength(dstPtr, soFar); - return Tcl_DStringValue(dstPtr); + return result; } flags &= ~TCL_ENCODING_START; @@ -1279,7 +1295,7 @@ Tcl_ExternalToUtf( /* *------------------------------------------------------------------------- * - * Tcl_UtfToExternalDString -- + * Tcl_UtfToExternalDString/Tcl_UtfToExternalDStringEx -- * * Convert a source buffer from UTF-8 to the specified encoding. If any * of the bytes in the source buffer are invalid or cannot be represented @@ -1288,7 +1304,7 @@ Tcl_ExternalToUtf( * Results: * The converted bytes are stored in the DString, which is then NULL * terminated in an encoding-specific manner. The return value is a - * pointer to the value stored in the DString. + * pointer to the value stored in the DString resp. an error code. * * Side effects: * None. @@ -1306,10 +1322,25 @@ Tcl_UtfToExternalDString( Tcl_DString *dstPtr) /* Uninitialized or free DString in which the * converted string is stored. */ { + Tcl_UtfToExternalDStringEx(encoding, src, srcLen, dstPtr, 0); + return Tcl_DStringValue(dstPtr); +} + +int +Tcl_UtfToExternalDStringEx( + Tcl_Encoding encoding, /* The encoding for the converted string, or + * NULL for the default system encoding. */ + const char *src, /* Source string in UTF-8. */ + int srcLen, /* Source string length in bytes, or < 0 for + * strlen(). */ + Tcl_DString *dstPtr, /* Uninitialized or free DString in which the + * converted string is stored. */ + int flags) /* Conversion control flags. */ +{ char *dst; Tcl_EncodingState state; const Encoding *encodingPtr; - int flags, dstLen, result, soFar, srcRead, dstWrote, dstChars; + int dstLen, result, soFar, srcRead, dstWrote, dstChars; Tcl_DStringInit(dstPtr); dst = Tcl_DStringValue(dstPtr); @@ -1325,10 +1356,10 @@ Tcl_UtfToExternalDString( } else if (srcLen < 0) { srcLen = strlen(src); } - flags = TCL_ENCODING_START | TCL_ENCODING_END; + flags |= TCL_ENCODING_START | TCL_ENCODING_END | TCL_ENCODING_EXTERNAL; while (1) { result = encodingPtr->fromUtfProc(encodingPtr->clientData, src, - srcLen, flags | TCL_ENCODING_EXTERNAL, &state, dst, dstLen, + srcLen, flags, &state, dst, dstLen, &srcRead, &dstWrote, &dstChars); soFar = dst + dstWrote - Tcl_DStringValue(dstPtr); @@ -1337,7 +1368,7 @@ Tcl_UtfToExternalDString( Tcl_DStringSetLength(dstPtr, soFar + 1); } Tcl_DStringSetLength(dstPtr, soFar); - return Tcl_DStringValue(dstPtr); + return result; } flags &= ~TCL_ENCODING_START; diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c index b66af58..0473bb1 100644 --- a/generic/tclStubInit.c +++ b/generic/tclStubInit.c @@ -1932,6 +1932,8 @@ const TclStubs tclStubs = { Tcl_UtfCharComplete, /* 654 */ Tcl_UtfNext, /* 655 */ Tcl_UtfPrev, /* 656 */ + Tcl_ExternalToUtfDStringEx, /* 657 */ + Tcl_UtfToExternalDStringEx, /* 658 */ }; /* !END!: Do not edit above this line. */ -- cgit v0.12 From 9fb8027cf65024e499873614e710122af9044cf0 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 26 Mar 2021 16:47:51 +0000 Subject: More WIP: Add -stoponerror flag to "encoding convertfrom/converto" --- generic/tclCmdAH.c | 48 ++++++++++++++++++++++++++++++++++++++++-------- tests/cmdAH.test | 4 ++-- tests/encoding.test | 15 +++++++++++++++ tests/safe.test | 8 ++++---- 4 files changed, 61 insertions(+), 14 deletions(-) diff --git a/generic/tclCmdAH.c b/generic/tclCmdAH.c index c09ad95..ee329ec 100644 --- a/generic/tclCmdAH.c +++ b/generic/tclCmdAH.c @@ -513,8 +513,8 @@ TclInitEncodingCmd( Tcl_Interp* interp) /* Tcl interpreter */ { static const EnsembleImplMap encodingImplMap[] = { - {"convertfrom", EncodingConvertfromObjCmd, TclCompileBasic1Or2ArgCmd, NULL, NULL, 0}, - {"convertto", EncodingConverttoObjCmd, TclCompileBasic1Or2ArgCmd, NULL, NULL, 0}, + {"convertfrom", EncodingConvertfromObjCmd, TclCompileBasic1To3ArgCmd, NULL, NULL, 0}, + {"convertto", EncodingConverttoObjCmd, TclCompileBasic1To3ArgCmd, NULL, NULL, 0}, {"dirs", EncodingDirsObjCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 1}, {"names", EncodingNamesObjCmd, TclCompileBasic0ArgCmd, NULL, NULL, 0}, {"system", EncodingSystemObjCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 1}, @@ -550,17 +550,27 @@ EncodingConvertfromObjCmd( Tcl_Encoding encoding; /* Encoding to use */ int length; /* Length of the byte array being converted */ const char *bytesPtr; /* Pointer to the first byte of the array */ + const char *stopOnError = NULL; + int result; if (objc == 2) { encoding = Tcl_GetEncoding(interp, NULL); data = objv[1]; - } else if (objc == 3) { + } else if ((unsigned)(objc - 3) < 2) { if (Tcl_GetEncodingFromObj(interp, objv[1], &encoding) != TCL_OK) { return TCL_ERROR; } data = objv[2]; + if (objc > 3) { + stopOnError = Tcl_GetString(objv[3]); + if (stopOnError[0] != '-' || stopOnError[1] != 's' + || strncmp(stopOnError, "-stoponerror", strlen(stopOnError))) { + goto encConvFromError; + } + } } else { - Tcl_WrongNumArgs(interp, 1, objv, "?encoding? data"); + encConvFromError: + Tcl_WrongNumArgs(interp, 1, objv, "?encoding? data ?-stoponerror?"); return TCL_ERROR; } @@ -568,7 +578,13 @@ EncodingConvertfromObjCmd( * Convert the string into a byte array in 'ds' */ bytesPtr = (char *) Tcl_GetByteArrayFromObj(data, &length); - Tcl_ExternalToUtfDString(encoding, bytesPtr, length, &ds); + result = Tcl_ExternalToUtfDStringEx(encoding, bytesPtr, length, &ds, + stopOnError ? TCL_ENCODING_STOPONERROR : 0); + if (stopOnError && (result != TCL_OK)) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf("encoding error after producing %d characters", Tcl_DStringLength(&ds))); + Tcl_DStringFree(&ds); + return TCL_ERROR; + } /* * Note that we cannot use Tcl_DStringResult here because it will @@ -612,19 +628,29 @@ EncodingConverttoObjCmd( Tcl_Encoding encoding; /* Encoding to use */ int length; /* Length of the string being converted */ const char *stringPtr; /* Pointer to the first byte of the string */ + int result; + const char *stopOnError = NULL; /* TODO - ADJUST OBJ INDICES WHEN ENSEMBLIFYING THIS */ if (objc == 2) { encoding = Tcl_GetEncoding(interp, NULL); data = objv[1]; - } else if (objc == 3) { + } else if ((unsigned)(objc - 3) < 2) { if (Tcl_GetEncodingFromObj(interp, objv[1], &encoding) != TCL_OK) { return TCL_ERROR; } data = objv[2]; + if (objc > 3) { + stopOnError = Tcl_GetString(objv[3]); + if (stopOnError[0] != '-' || stopOnError[1] != 's' + || strncmp(stopOnError, "-stoponerror", strlen(stopOnError))) { + goto encConvToError; + } + } } else { - Tcl_WrongNumArgs(interp, 1, objv, "?encoding? data"); + encConvToError: + Tcl_WrongNumArgs(interp, 1, objv, "?encoding? data ?-stoponerror?"); return TCL_ERROR; } @@ -633,7 +659,13 @@ EncodingConverttoObjCmd( */ stringPtr = TclGetStringFromObj(data, &length); - Tcl_UtfToExternalDString(encoding, stringPtr, length, &ds); + result = Tcl_UtfToExternalDStringEx(encoding, stringPtr, length, &ds, + stopOnError ? TCL_ENCODING_STOPONERROR : 0); + if (stopOnError && (result != TCL_OK)) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf("encoding error after producing %d bytes", Tcl_DStringLength(&ds))); + Tcl_DStringFree(&ds); + return TCL_ERROR; + } Tcl_SetObjResult(interp, Tcl_NewByteArrayObj((unsigned char*) Tcl_DStringValue(&ds), Tcl_DStringLength(&ds))); diff --git a/tests/cmdAH.test b/tests/cmdAH.test index baa148e..29adeae 100644 --- a/tests/cmdAH.test +++ b/tests/cmdAH.test @@ -178,7 +178,7 @@ test cmdAH-4.2 {Tcl_EncodingObjCmd} -returnCodes error -body { } -result {unknown or ambiguous subcommand "foo": must be convertfrom, convertto, dirs, names, or system} test cmdAH-4.3 {Tcl_EncodingObjCmd} -returnCodes error -body { encoding convertto -} -result {wrong # args: should be "encoding convertto ?encoding? data"} +} -result {wrong # args: should be "encoding convertto ?encoding? data ?-stoponerror?"} test cmdAH-4.4 {Tcl_EncodingObjCmd} -returnCodes error -body { encoding convertto foo bar } -result {unknown encoding "foo"} @@ -200,7 +200,7 @@ test cmdAH-4.6 {Tcl_EncodingObjCmd} -setup { } -result 8C test cmdAH-4.7 {Tcl_EncodingObjCmd} -returnCodes error -body { encoding convertfrom -} -result {wrong # args: should be "encoding convertfrom ?encoding? data"} +} -result {wrong # args: should be "encoding convertfrom ?encoding? data ?-stoponerror?"} test cmdAH-4.8 {Tcl_EncodingObjCmd} -returnCodes error -body { encoding convertfrom foo bar } -result {unknown encoding "foo"} diff --git a/tests/encoding.test b/tests/encoding.test index b1150c6..f881d4f 100644 --- a/tests/encoding.test +++ b/tests/encoding.test @@ -580,6 +580,21 @@ test encoding-24.10 {Parse valid or invalid utf-8} { test encoding-24.11 {Parse valid or invalid utf-8} { string length [encoding convertfrom utf-8 "\xEF\xBF\xBF"] } 1 +test encoding-24.12 {Parse valid or invalid utf-8} { + string length [encoding convertfrom utf-8 "\xC0\x80" -stoponerror] +} 1 +test encoding-24.13 {Parse valid or invalid utf-8} -body { + encoding convertfrom utf-8 "\xC0\x81" -stoponerror +} -returnCodes 1 -result {encoding error after producing 0 characters} +test encoding-24.14 {Parse valid or invalid utf-8} -body { + encoding convertfrom utf-8 "\xC1\xBF" -stoponerror +} -returnCodes 1 -result {encoding error after producing 0 characters} +test encoding-24.15 {Parse valid or invalid utf-8} { + string length [encoding convertfrom utf-8 "\xC2\x80" -stoponerror] +} 1 +test encoding-24.16 {Parse valid or invalid utf-8} -body { + encoding convertfrom utf-8 "Z\xE0\x80" -stoponerror +} -returnCodes 1 -result {encoding error after producing 1 characters} file delete [file join [temporaryDirectory] iso2022.txt] diff --git a/tests/safe.test b/tests/safe.test index 8fca594..e2a9b83 100644 --- a/tests/safe.test +++ b/tests/safe.test @@ -1267,7 +1267,7 @@ test safe-11.7 {testing safe encoding} -setup { interp eval $i encoding convertfrom } -returnCodes error -cleanup { safe::interpDelete $i -} -result {wrong # args: should be "encoding convertfrom ?encoding? data"} +} -result {wrong # args: should be "encoding convertfrom ?encoding? data ?-stoponerror?"} test safe-11.7.1 {testing safe encoding} -setup { set i [safe::interpCreate] } -body { @@ -1276,7 +1276,7 @@ test safe-11.7.1 {testing safe encoding} -setup { } -returnCodes ok -match glob -cleanup { unset -nocomplain m o safe::interpDelete $i -} -result {wrong # args: should be "encoding convertfrom ?encoding? data" +} -result {wrong # args: should be "encoding convertfrom ?encoding? data ?-stoponerror?" while executing "encoding convertfrom" invoked from within @@ -1289,7 +1289,7 @@ test safe-11.8 {testing safe encoding} -setup { interp eval $i encoding convertto } -returnCodes error -cleanup { safe::interpDelete $i -} -result {wrong # args: should be "encoding convertto ?encoding? data"} +} -result {wrong # args: should be "encoding convertto ?encoding? data ?-stoponerror?"} test safe-11.8.1 {testing safe encoding} -setup { set i [safe::interpCreate] } -body { @@ -1298,7 +1298,7 @@ test safe-11.8.1 {testing safe encoding} -setup { } -returnCodes ok -match glob -cleanup { unset -nocomplain m o safe::interpDelete $i -} -result {wrong # args: should be "encoding convertto ?encoding? data" +} -result {wrong # args: should be "encoding convertto ?encoding? data ?-stoponerror?" while executing "encoding convertto" invoked from within -- cgit v0.12 From 664b7500abd51bfa6257c7e3e8fc5846d18d522b Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 30 Mar 2021 11:26:36 +0000 Subject: Add documentation. Do a better job of counting exactly which byte/character caused the encoding/decoding error --- doc/Encoding.3 | 20 +++++++++++++++++++- generic/tcl.decls | 8 ++++---- generic/tcl.h | 5 +++++ generic/tclCmdAH.c | 31 +++++++++++++++++++------------ generic/tclDecls.h | 16 ++++++++-------- generic/tclEncoding.c | 30 +++++++++++++++--------------- tests/encoding.test | 6 +++--- 7 files changed, 73 insertions(+), 43 deletions(-) diff --git a/doc/Encoding.3 b/doc/Encoding.3 index 2d2461e..c33878a 100644 --- a/doc/Encoding.3 +++ b/doc/Encoding.3 @@ -26,8 +26,14 @@ char * \fBTcl_ExternalToUtfDString\fR(\fIencoding, src, srcLen, dstPtr\fR) .sp char * +\fBTcl_ExternalToUtfDStringEx\fR(\fIencoding, src, srcLen, flags, dstPtr\fR) +.sp +char * \fBTcl_UtfToExternalDString\fR(\fIencoding, src, srcLen, dstPtr\fR) .sp +char * +\fBTcl_UtfToExternalDStringEx\fR(\fIencoding, src, srcLen, flags, dstPtr\fR) +.sp int \fBTcl_ExternalToUtf\fR(\fIinterp, encoding, src, srcLen, flags, statePtr, dst, dstLen, srcReadPtr, dstWrotePtr, dstCharsPtr\fR) @@ -108,7 +114,9 @@ byte is converted and then to reset to an initial state. \fBTCL_ENCODING_STOPONERROR\fR signifies that the conversion routine should return immediately upon reading a source character that does not exist in the target encoding; otherwise a default fallback character will -automatically be substituted. +automatically be substituted. The flag \fBTCL_ENCODING_MODIFIED\fR makes +\fBTcl_UtfToExternalDStringEx\fR and \fBTcl_UtfToExternal\fR produce the +byte sequence \exC0\ex80 in stead of \ex00, for the utf-8/wtf-8/cesu-8 encoders. .AP Tcl_EncodingState *statePtr in/out Used when converting a (generally long or indefinite length) byte stream in a piece-by-piece fashion. The conversion routine stores its current @@ -208,6 +216,11 @@ When converting, if any of the characters in the source buffer cannot be represented in the target encoding, a default fallback character will be used. The return value is a pointer to the value stored in the DString. .PP +\fBTcl_ExternalToUtfDStringEx\fR is the same as \fBTcl_ExternalToUtfDString\fR, +but it has an additional flags parameter. The return value is the index of +the first byte in the input string causing a conversion error. +Or (size_t)-1 if all is OK. +.PP \fBTcl_ExternalToUtf\fR converts a source buffer \fIsrc\fR from the specified \fIencoding\fR into UTF-8. Up to \fIsrcLen\fR bytes are converted from the source buffer and up to \fIdstLen\fR converted bytes are stored in \fIdst\fR. @@ -246,6 +259,11 @@ characters in the source buffer cannot be represented in the target encoding, a default fallback character will be used. The return value is a pointer to the value stored in the DString. .PP +\fBTcl_UtfToExternalDStringEx\fR is the same as \fBTcl_UtfToExternalDString\fR, +but it has an additional flags parameter. The return value is the index of +the first byte in the input string causing a conversion error. +Or (size_t)-1 if all is OK. +.PP \fBTcl_UtfToExternal\fR converts a source buffer \fIsrc\fR from UTF-8 into the specified \fIencoding\fR. Up to \fIsrcLen\fR bytes are converted from the source buffer and up to \fIdstLen\fR converted bytes are stored in diff --git a/generic/tcl.decls b/generic/tcl.decls index c2a4abd..8cd5bc9 100644 --- a/generic/tcl.decls +++ b/generic/tcl.decls @@ -2425,12 +2425,12 @@ declare 656 { } declare 657 { - int Tcl_ExternalToUtfDStringEx(Tcl_Encoding encoding, - const char *src, int srcLen, Tcl_DString *dsPtr, int flags) + size_t Tcl_ExternalToUtfDStringEx(Tcl_Encoding encoding, + const char *src, int srcLen, int flags, Tcl_DString *dsPtr) } declare 658 { - int Tcl_UtfToExternalDStringEx(Tcl_Encoding encoding, - const char *src, int srcLen, Tcl_DString *dsPtr, int flags) + size_t Tcl_UtfToExternalDStringEx(Tcl_Encoding encoding, + const char *src, int srcLen, int flags, Tcl_DString *dsPtr) } diff --git a/generic/tcl.h b/generic/tcl.h index 38dda28..f783f4f 100644 --- a/generic/tcl.h +++ b/generic/tcl.h @@ -2069,6 +2069,10 @@ typedef struct Tcl_EncodingType { * content. Otherwise, the number of chars * produced is controlled only by other limiting * factors. + * TCL_ENCODING_MODIFIED - Convert NULL bytes to \xC0\x80 in stead of + * 0x00. Only valid for "utf-8", "wtf-8 and "cesu-8". + * This flag is implicit for external -> internal conversions, + * optional for internal -> external conversions. */ #define TCL_ENCODING_START 0x01 @@ -2076,6 +2080,7 @@ typedef struct Tcl_EncodingType { #define TCL_ENCODING_STOPONERROR 0x04 #define TCL_ENCODING_NO_TERMINATE 0x08 #define TCL_ENCODING_CHAR_LIMIT 0x10 +#define TCL_ENCODING_MODIFIED 0x20 /* * The following definitions are the error codes returned by the conversion diff --git a/generic/tclCmdAH.c b/generic/tclCmdAH.c index ee329ec..cd77e06 100644 --- a/generic/tclCmdAH.c +++ b/generic/tclCmdAH.c @@ -551,7 +551,7 @@ EncodingConvertfromObjCmd( int length; /* Length of the byte array being converted */ const char *bytesPtr; /* Pointer to the first byte of the array */ const char *stopOnError = NULL; - int result; + size_t result; if (objc == 2) { encoding = Tcl_GetEncoding(interp, NULL); @@ -563,7 +563,9 @@ EncodingConvertfromObjCmd( data = objv[2]; if (objc > 3) { stopOnError = Tcl_GetString(objv[3]); - if (stopOnError[0] != '-' || stopOnError[1] != 's' + if (!stopOnError[0]) { + stopOnError = NULL; + } else if (stopOnError[0] != '-' || stopOnError[1] != 's' || strncmp(stopOnError, "-stoponerror", strlen(stopOnError))) { goto encConvFromError; } @@ -578,10 +580,11 @@ EncodingConvertfromObjCmd( * Convert the string into a byte array in 'ds' */ bytesPtr = (char *) Tcl_GetByteArrayFromObj(data, &length); - result = Tcl_ExternalToUtfDStringEx(encoding, bytesPtr, length, &ds, - stopOnError ? TCL_ENCODING_STOPONERROR : 0); - if (stopOnError && (result != TCL_OK)) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf("encoding error after producing %d characters", Tcl_DStringLength(&ds))); + result = Tcl_ExternalToUtfDStringEx(encoding, bytesPtr, length, + stopOnError ? TCL_ENCODING_STOPONERROR : 0, &ds); + if (stopOnError && (result != (size_t)-1)) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf("encoding error after reading %" + TCL_LL_MODIFIER "u byte%s", (long long)result, (result != 1)?"s":"")); Tcl_DStringFree(&ds); return TCL_ERROR; } @@ -628,7 +631,7 @@ EncodingConverttoObjCmd( Tcl_Encoding encoding; /* Encoding to use */ int length; /* Length of the string being converted */ const char *stringPtr; /* Pointer to the first byte of the string */ - int result; + size_t result; const char *stopOnError = NULL; /* TODO - ADJUST OBJ INDICES WHEN ENSEMBLIFYING THIS */ @@ -643,7 +646,9 @@ EncodingConverttoObjCmd( data = objv[2]; if (objc > 3) { stopOnError = Tcl_GetString(objv[3]); - if (stopOnError[0] != '-' || stopOnError[1] != 's' + if (!stopOnError[0]) { + stopOnError = NULL; + } else if (stopOnError[0] != '-' || stopOnError[1] != 's' || strncmp(stopOnError, "-stoponerror", strlen(stopOnError))) { goto encConvToError; } @@ -659,10 +664,12 @@ EncodingConverttoObjCmd( */ stringPtr = TclGetStringFromObj(data, &length); - result = Tcl_UtfToExternalDStringEx(encoding, stringPtr, length, &ds, - stopOnError ? TCL_ENCODING_STOPONERROR : 0); - if (stopOnError && (result != TCL_OK)) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf("encoding error after producing %d bytes", Tcl_DStringLength(&ds))); + result = Tcl_UtfToExternalDStringEx(encoding, stringPtr, length, + stopOnError ? TCL_ENCODING_STOPONERROR : 0, &ds); + if (stopOnError && (result != (size_t)-1)) { + result = Tcl_NumUtfChars(stringPtr, result); + Tcl_SetObjResult(interp, Tcl_ObjPrintf("encoding error after reading %" + TCL_LL_MODIFIER "u character%s", (long long)result, (result != 1)?"s":"")); Tcl_DStringFree(&ds); return TCL_ERROR; } diff --git a/generic/tclDecls.h b/generic/tclDecls.h index 6ba39d5..24760f9 100644 --- a/generic/tclDecls.h +++ b/generic/tclDecls.h @@ -1938,13 +1938,13 @@ EXTERN const char * Tcl_UtfNext(const char *src); /* 656 */ EXTERN const char * Tcl_UtfPrev(const char *src, const char *start); /* 657 */ -EXTERN int Tcl_ExternalToUtfDStringEx(Tcl_Encoding encoding, - const char *src, int srcLen, - Tcl_DString *dsPtr, int flags); +EXTERN size_t Tcl_ExternalToUtfDStringEx(Tcl_Encoding encoding, + const char *src, int srcLen, int flags, + Tcl_DString *dsPtr); /* 658 */ -EXTERN int Tcl_UtfToExternalDStringEx(Tcl_Encoding encoding, - const char *src, int srcLen, - Tcl_DString *dsPtr, int flags); +EXTERN size_t Tcl_UtfToExternalDStringEx(Tcl_Encoding encoding, + const char *src, int srcLen, int flags, + Tcl_DString *dsPtr); typedef struct { const struct TclPlatStubs *tclPlatStubs; @@ -2637,8 +2637,8 @@ typedef struct TclStubs { int (*tcl_UtfCharComplete) (const char *src, int length); /* 654 */ const char * (*tcl_UtfNext) (const char *src); /* 655 */ const char * (*tcl_UtfPrev) (const char *src, const char *start); /* 656 */ - int (*tcl_ExternalToUtfDStringEx) (Tcl_Encoding encoding, const char *src, int srcLen, Tcl_DString *dsPtr, int flags); /* 657 */ - int (*tcl_UtfToExternalDStringEx) (Tcl_Encoding encoding, const char *src, int srcLen, Tcl_DString *dsPtr, int flags); /* 658 */ + size_t (*tcl_ExternalToUtfDStringEx) (Tcl_Encoding encoding, const char *src, int srcLen, int flags, Tcl_DString *dsPtr); /* 657 */ + size_t (*tcl_UtfToExternalDStringEx) (Tcl_Encoding encoding, const char *src, int srcLen, int flags, Tcl_DString *dsPtr); /* 658 */ } TclStubs; extern const TclStubs *tclStubsPtr; diff --git a/generic/tclEncoding.c b/generic/tclEncoding.c index 72f7690..0bce51b 100644 --- a/generic/tclEncoding.c +++ b/generic/tclEncoding.c @@ -511,7 +511,6 @@ FillEncodingFileMap(void) */ /* Those flags must not conflict with other TCL_ENCODING_* flags in tcl.h */ -#define TCL_ENCODING_MODIFIED 0x20 /* Converting NULL bytes to 0xC0 0x80 */ #define TCL_ENCODING_LE 0x80 /* Little-endian encoding, for ucs-2/utf-16 only */ void @@ -1117,26 +1116,27 @@ Tcl_ExternalToUtfDString( Tcl_DString *dstPtr) /* Uninitialized or free DString in which the * converted string is stored. */ { - Tcl_ExternalToUtfDStringEx(encoding, src, srcLen, dstPtr, 0); + Tcl_ExternalToUtfDStringEx(encoding, src, srcLen, 0, dstPtr); return Tcl_DStringValue(dstPtr); } -int +size_t Tcl_ExternalToUtfDStringEx( Tcl_Encoding encoding, /* The encoding for the source string, or NULL * for the default system encoding. */ const char *src, /* Source string in specified encoding. */ int srcLen, /* Source string length in bytes, or < 0 for * encoding-specific string length. */ - Tcl_DString *dstPtr, /* Uninitialized or free DString in which the + int flags, /* Conversion control flags. */ + Tcl_DString *dstPtr) /* Uninitialized or free DString in which the * converted string is stored. */ - int flags) /* Conversion control flags. */ { char *dst; Tcl_EncodingState state; const Encoding *encodingPtr; int dstLen, result, soFar, srcRead, dstWrote, dstChars; + const char *srcStart = src; Tcl_DStringInit(dstPtr); dst = Tcl_DStringValue(dstPtr); @@ -1160,13 +1160,12 @@ Tcl_ExternalToUtfDStringEx( flags, &state, dst, dstLen, &srcRead, &dstWrote, &dstChars); soFar = dst + dstWrote - Tcl_DStringValue(dstPtr); + src += srcRead; if (result != TCL_CONVERT_NOSPACE) { Tcl_DStringSetLength(dstPtr, soFar); - return result; + return (result == TCL_OK) ? (size_t)-1 : (size_t)(src - srcStart); } - flags &= ~TCL_ENCODING_START; - src += srcRead; srcLen -= srcRead; if (Tcl_DStringLength(dstPtr) == 0) { Tcl_DStringSetLength(dstPtr, dstLen); @@ -1321,25 +1320,26 @@ Tcl_UtfToExternalDString( Tcl_DString *dstPtr) /* Uninitialized or free DString in which the * converted string is stored. */ { - Tcl_UtfToExternalDStringEx(encoding, src, srcLen, dstPtr, 0); + Tcl_UtfToExternalDStringEx(encoding, src, srcLen, 0, dstPtr); return Tcl_DStringValue(dstPtr); } -int +size_t Tcl_UtfToExternalDStringEx( Tcl_Encoding encoding, /* The encoding for the converted string, or * NULL for the default system encoding. */ const char *src, /* Source string in UTF-8. */ int srcLen, /* Source string length in bytes, or < 0 for * strlen(). */ - Tcl_DString *dstPtr, /* Uninitialized or free DString in which the + int flags, /* Conversion control flags. */ + Tcl_DString *dstPtr) /* Uninitialized or free DString in which the * converted string is stored. */ - int flags) /* Conversion control flags. */ { char *dst; Tcl_EncodingState state; const Encoding *encodingPtr; int dstLen, result, soFar, srcRead, dstWrote, dstChars; + const char *srcStart = src; Tcl_DStringInit(dstPtr); dst = Tcl_DStringValue(dstPtr); @@ -1355,23 +1355,23 @@ Tcl_UtfToExternalDStringEx( } else if (srcLen < 0) { srcLen = strlen(src); } - flags |= TCL_ENCODING_START | TCL_ENCODING_END | TCL_ENCODING_EXTERNAL; + flags |= TCL_ENCODING_START | TCL_ENCODING_END; while (1) { result = encodingPtr->fromUtfProc(encodingPtr->clientData, src, srcLen, flags, &state, dst, dstLen, &srcRead, &dstWrote, &dstChars); soFar = dst + dstWrote - Tcl_DStringValue(dstPtr); + src += srcRead; if (result != TCL_CONVERT_NOSPACE) { if (encodingPtr->nullSize == 2) { Tcl_DStringSetLength(dstPtr, soFar + 1); } Tcl_DStringSetLength(dstPtr, soFar); - return result; + return (result == TCL_OK) ? (size_t)-1 : (size_t)(src - srcStart); } flags &= ~TCL_ENCODING_START; - src += srcRead; srcLen -= srcRead; if (Tcl_DStringLength(dstPtr) == 0) { Tcl_DStringSetLength(dstPtr, dstLen); diff --git a/tests/encoding.test b/tests/encoding.test index 76e2ca4..63f0fa6 100644 --- a/tests/encoding.test +++ b/tests/encoding.test @@ -585,16 +585,16 @@ test encoding-24.12 {Parse valid or invalid utf-8} { } 1 test encoding-24.13 {Parse valid or invalid utf-8} -body { encoding convertfrom utf-8 "\xC0\x81" -stoponerror -} -returnCodes 1 -result {encoding error after producing 0 characters} +} -returnCodes 1 -result {encoding error after reading 0 bytes} test encoding-24.14 {Parse valid or invalid utf-8} -body { encoding convertfrom utf-8 "\xC1\xBF" -stoponerror -} -returnCodes 1 -result {encoding error after producing 0 characters} +} -returnCodes 1 -result {encoding error after reading 0 bytes} test encoding-24.15 {Parse valid or invalid utf-8} { string length [encoding convertfrom utf-8 "\xC2\x80" -stoponerror] } 1 test encoding-24.16 {Parse valid or invalid utf-8} -body { encoding convertfrom utf-8 "Z\xE0\x80" -stoponerror -} -returnCodes 1 -result {encoding error after producing 1 characters} +} -returnCodes 1 -result {encoding error after reading 1 byte} file delete [file join [temporaryDirectory] iso2022.txt] -- cgit v0.12 From 41533dc84a21444a1885476d2b4ac780b6581a44 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 30 Mar 2021 11:54:50 +0000 Subject: add testcase for "encoding convertto". Move stub table one positions --- generic/tcl.decls | 4 ++-- generic/tcl.h | 2 +- generic/tclCmdAH.c | 2 +- generic/tclDecls.h | 15 +++++++++------ generic/tclStubInit.c | 5 +++-- tests/encoding.test | 9 ++++++--- 6 files changed, 22 insertions(+), 15 deletions(-) diff --git a/generic/tcl.decls b/generic/tcl.decls index 8cd5bc9..0dfa415 100644 --- a/generic/tcl.decls +++ b/generic/tcl.decls @@ -2424,11 +2424,11 @@ declare 656 { const char *Tcl_UtfPrev(const char *src, const char *start) } -declare 657 { +declare 658 { size_t Tcl_ExternalToUtfDStringEx(Tcl_Encoding encoding, const char *src, int srcLen, int flags, Tcl_DString *dsPtr) } -declare 658 { +declare 659 { size_t Tcl_UtfToExternalDStringEx(Tcl_Encoding encoding, const char *src, int srcLen, int flags, Tcl_DString *dsPtr) } diff --git a/generic/tcl.h b/generic/tcl.h index f783f4f..e1b6066 100644 --- a/generic/tcl.h +++ b/generic/tcl.h @@ -2080,7 +2080,7 @@ typedef struct Tcl_EncodingType { #define TCL_ENCODING_STOPONERROR 0x04 #define TCL_ENCODING_NO_TERMINATE 0x08 #define TCL_ENCODING_CHAR_LIMIT 0x10 -#define TCL_ENCODING_MODIFIED 0x20 +#define TCL_ENCODING_MODIFIED 0x20 /* * The following definitions are the error codes returned by the conversion diff --git a/generic/tclCmdAH.c b/generic/tclCmdAH.c index cd77e06..df80d3c 100644 --- a/generic/tclCmdAH.c +++ b/generic/tclCmdAH.c @@ -583,7 +583,7 @@ EncodingConvertfromObjCmd( result = Tcl_ExternalToUtfDStringEx(encoding, bytesPtr, length, stopOnError ? TCL_ENCODING_STOPONERROR : 0, &ds); if (stopOnError && (result != (size_t)-1)) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf("encoding error after reading %" + Tcl_SetObjResult(interp, Tcl_ObjPrintf("decoding error after reading %" TCL_LL_MODIFIER "u byte%s", (long long)result, (result != 1)?"s":"")); Tcl_DStringFree(&ds); return TCL_ERROR; diff --git a/generic/tclDecls.h b/generic/tclDecls.h index 24760f9..6ee645d 100644 --- a/generic/tclDecls.h +++ b/generic/tclDecls.h @@ -1937,11 +1937,12 @@ EXTERN int Tcl_UtfCharComplete(const char *src, int length); EXTERN const char * Tcl_UtfNext(const char *src); /* 656 */ EXTERN const char * Tcl_UtfPrev(const char *src, const char *start); -/* 657 */ +/* Slot 657 is reserved */ +/* 658 */ EXTERN size_t Tcl_ExternalToUtfDStringEx(Tcl_Encoding encoding, const char *src, int srcLen, int flags, Tcl_DString *dsPtr); -/* 658 */ +/* 659 */ EXTERN size_t Tcl_UtfToExternalDStringEx(Tcl_Encoding encoding, const char *src, int srcLen, int flags, Tcl_DString *dsPtr); @@ -2637,8 +2638,9 @@ typedef struct TclStubs { int (*tcl_UtfCharComplete) (const char *src, int length); /* 654 */ const char * (*tcl_UtfNext) (const char *src); /* 655 */ const char * (*tcl_UtfPrev) (const char *src, const char *start); /* 656 */ - size_t (*tcl_ExternalToUtfDStringEx) (Tcl_Encoding encoding, const char *src, int srcLen, int flags, Tcl_DString *dsPtr); /* 657 */ - size_t (*tcl_UtfToExternalDStringEx) (Tcl_Encoding encoding, const char *src, int srcLen, int flags, Tcl_DString *dsPtr); /* 658 */ + void (*reserved657)(void); + size_t (*tcl_ExternalToUtfDStringEx) (Tcl_Encoding encoding, const char *src, int srcLen, int flags, Tcl_DString *dsPtr); /* 658 */ + size_t (*tcl_UtfToExternalDStringEx) (Tcl_Encoding encoding, const char *src, int srcLen, int flags, Tcl_DString *dsPtr); /* 659 */ } TclStubs; extern const TclStubs *tclStubsPtr; @@ -3981,10 +3983,11 @@ extern const TclStubs *tclStubsPtr; (tclStubsPtr->tcl_UtfNext) /* 655 */ #define Tcl_UtfPrev \ (tclStubsPtr->tcl_UtfPrev) /* 656 */ +/* Slot 657 is reserved */ #define Tcl_ExternalToUtfDStringEx \ - (tclStubsPtr->tcl_ExternalToUtfDStringEx) /* 657 */ + (tclStubsPtr->tcl_ExternalToUtfDStringEx) /* 658 */ #define Tcl_UtfToExternalDStringEx \ - (tclStubsPtr->tcl_UtfToExternalDStringEx) /* 658 */ + (tclStubsPtr->tcl_UtfToExternalDStringEx) /* 659 */ #endif /* defined(USE_TCL_STUBS) */ diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c index 0473bb1..54ab4b6 100644 --- a/generic/tclStubInit.c +++ b/generic/tclStubInit.c @@ -1932,8 +1932,9 @@ const TclStubs tclStubs = { Tcl_UtfCharComplete, /* 654 */ Tcl_UtfNext, /* 655 */ Tcl_UtfPrev, /* 656 */ - Tcl_ExternalToUtfDStringEx, /* 657 */ - Tcl_UtfToExternalDStringEx, /* 658 */ + 0, /* 657 */ + Tcl_ExternalToUtfDStringEx, /* 658 */ + Tcl_UtfToExternalDStringEx, /* 659 */ }; /* !END!: Do not edit above this line. */ diff --git a/tests/encoding.test b/tests/encoding.test index 63f0fa6..1c12be0 100644 --- a/tests/encoding.test +++ b/tests/encoding.test @@ -585,16 +585,19 @@ test encoding-24.12 {Parse valid or invalid utf-8} { } 1 test encoding-24.13 {Parse valid or invalid utf-8} -body { encoding convertfrom utf-8 "\xC0\x81" -stoponerror -} -returnCodes 1 -result {encoding error after reading 0 bytes} +} -returnCodes 1 -result {decoding error after reading 0 bytes} test encoding-24.14 {Parse valid or invalid utf-8} -body { encoding convertfrom utf-8 "\xC1\xBF" -stoponerror -} -returnCodes 1 -result {encoding error after reading 0 bytes} +} -returnCodes 1 -result {decoding error after reading 0 bytes} test encoding-24.15 {Parse valid or invalid utf-8} { string length [encoding convertfrom utf-8 "\xC2\x80" -stoponerror] } 1 test encoding-24.16 {Parse valid or invalid utf-8} -body { encoding convertfrom utf-8 "Z\xE0\x80" -stoponerror -} -returnCodes 1 -result {encoding error after reading 1 byte} +} -returnCodes 1 -result {decoding error after reading 1 byte} +test encoding-24.17 {Parse valid or invalid utf-8} -constraints testbytestring -body { + encoding convertto utf-8 [testbytestring "Z\xE0\x80"] -stoponerror +} -returnCodes 1 -result {encoding error after reading 1 character} file delete [file join [temporaryDirectory] iso2022.txt] -- cgit v0.12 From 78a0992b4431f976641f3d08f63c13fab742e1b9 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 30 Mar 2021 13:35:15 +0000 Subject: Better error-messages --- generic/tclCmdAH.c | 23 ++++++++++++++++------- tests/encoding.test | 11 +++++++---- 2 files changed, 23 insertions(+), 11 deletions(-) diff --git a/generic/tclCmdAH.c b/generic/tclCmdAH.c index df80d3c..0c0a4a4 100644 --- a/generic/tclCmdAH.c +++ b/generic/tclCmdAH.c @@ -579,12 +579,19 @@ EncodingConvertfromObjCmd( /* * Convert the string into a byte array in 'ds' */ - bytesPtr = (char *) Tcl_GetByteArrayFromObj(data, &length); + if (stopOnError) { + bytesPtr = (char *) TclGetBytesFromObj(interp, data, &length); + if (bytesPtr == NULL) { + return TCL_ERROR; + } + } else { + bytesPtr = (char *) Tcl_GetByteArrayFromObj(data, &length); + } result = Tcl_ExternalToUtfDStringEx(encoding, bytesPtr, length, stopOnError ? TCL_ENCODING_STOPONERROR : 0, &ds); if (stopOnError && (result != (size_t)-1)) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf("decoding error after reading %" - TCL_LL_MODIFIER "u byte%s", (long long)result, (result != 1)?"s":"")); + Tcl_SetObjResult(interp, Tcl_ObjPrintf("unexpected byte at index %" + TCL_LL_MODIFIER "u: '%c' (\\x%X)", (long long)result, UCHAR(bytesPtr[result]), UCHAR(bytesPtr[result]))); Tcl_DStringFree(&ds); return TCL_ERROR; } @@ -667,10 +674,12 @@ EncodingConverttoObjCmd( result = Tcl_UtfToExternalDStringEx(encoding, stringPtr, length, stopOnError ? TCL_ENCODING_STOPONERROR : 0, &ds); if (stopOnError && (result != (size_t)-1)) { - result = Tcl_NumUtfChars(stringPtr, result); - Tcl_SetObjResult(interp, Tcl_ObjPrintf("encoding error after reading %" - TCL_LL_MODIFIER "u character%s", (long long)result, (result != 1)?"s":"")); - Tcl_DStringFree(&ds); + size_t pos = Tcl_NumUtfChars(stringPtr, result); + int ucs4; + TclUtfToUCS4(&stringPtr[result], &ucs4); + Tcl_SetObjResult(interp, Tcl_ObjPrintf("unexpected character at index %" + TCL_LL_MODIFIER "u: '%1s' (U+%06X)", (long long)pos, &stringPtr[result], ucs4)); + Tcl_DStringFree(&ds); return TCL_ERROR; } Tcl_SetObjResult(interp, diff --git a/tests/encoding.test b/tests/encoding.test index 1c12be0..114b296 100644 --- a/tests/encoding.test +++ b/tests/encoding.test @@ -585,19 +585,22 @@ test encoding-24.12 {Parse valid or invalid utf-8} { } 1 test encoding-24.13 {Parse valid or invalid utf-8} -body { encoding convertfrom utf-8 "\xC0\x81" -stoponerror -} -returnCodes 1 -result {decoding error after reading 0 bytes} +} -returnCodes 1 -result {unexpected byte at index 0: 'À' (\xC0)} test encoding-24.14 {Parse valid or invalid utf-8} -body { encoding convertfrom utf-8 "\xC1\xBF" -stoponerror -} -returnCodes 1 -result {decoding error after reading 0 bytes} +} -returnCodes 1 -result {unexpected byte at index 0: 'Á' (\xC1)} test encoding-24.15 {Parse valid or invalid utf-8} { string length [encoding convertfrom utf-8 "\xC2\x80" -stoponerror] } 1 test encoding-24.16 {Parse valid or invalid utf-8} -body { encoding convertfrom utf-8 "Z\xE0\x80" -stoponerror -} -returnCodes 1 -result {decoding error after reading 1 byte} +} -returnCodes 1 -result {unexpected byte at index 1: 'à' (\xE0)} test encoding-24.17 {Parse valid or invalid utf-8} -constraints testbytestring -body { + encoding convertto utf-8 [testbytestring "Z\u4343\x80"] -stoponerror +} -returnCodes 1 -result {expected byte sequence but character 1 was '䍃€' (U+004343)} +test encoding-24.18 {Parse valid or invalid utf-8} -constraints testbytestring -body { encoding convertto utf-8 [testbytestring "Z\xE0\x80"] -stoponerror -} -returnCodes 1 -result {encoding error after reading 1 character} +} -returnCodes 1 -match glob -result {unexpected character at index 1: '*' (U+0000E0)} file delete [file join [temporaryDirectory] iso2022.txt] -- cgit v0.12 From 975d478bfaf46abfe1b34bdbd82dd0dc9556d864 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 1 Apr 2021 09:10:13 +0000 Subject: More bugfixes (and testcases showing this) --- generic/tclCmdAH.c | 2 +- generic/tclEncoding.c | 17 +++++++++++------ tests/encoding.test | 5 ++++- 3 files changed, 16 insertions(+), 8 deletions(-) diff --git a/generic/tclCmdAH.c b/generic/tclCmdAH.c index 0c0a4a4..1dfabd2 100644 --- a/generic/tclCmdAH.c +++ b/generic/tclCmdAH.c @@ -678,7 +678,7 @@ EncodingConverttoObjCmd( int ucs4; TclUtfToUCS4(&stringPtr[result], &ucs4); Tcl_SetObjResult(interp, Tcl_ObjPrintf("unexpected character at index %" - TCL_LL_MODIFIER "u: '%1s' (U+%06X)", (long long)pos, &stringPtr[result], ucs4)); + TCL_LL_MODIFIER "u: '%c' (U+%06X)", (long long)pos, ucs4, ucs4)); Tcl_DStringFree(&ds); return TCL_ERROR; } diff --git a/generic/tclEncoding.c b/generic/tclEncoding.c index d28fc8c..6cf0d76 100644 --- a/generic/tclEncoding.c +++ b/generic/tclEncoding.c @@ -2303,18 +2303,23 @@ UtfToUtfProc( * unless the user has explicitly asked to be told. */ - if (flags & TCL_ENCODING_STOPONERROR) { - result = TCL_CONVERT_MULTIBYTE; - break; + if (flags & TCL_ENCODING_MODIFIED) { + if (flags & TCL_ENCODING_STOPONERROR) { + result = TCL_CONVERT_MULTIBYTE; + break; + } + ch = UCHAR(*src++); + } else { + char chbuf[2]; + chbuf[0] = UCHAR(*src++); chbuf[1] = 0; + TclUtfToUCS4(chbuf, &ch); } - ch = UCHAR(*src); - src += 1; dst += Tcl_UniCharToUtf(ch, dst); } else { int low; const char *saveSrc = src; size_t len = TclUtfToUCS4(src, &ch); - if ((len < 2) && (ch != 0) && (flags & TCL_ENCODING_STOPONERROR)) { + if ((len < 2) && (ch != 0) && (flags & TCL_ENCODING_STOPONERROR) && (flags & TCL_ENCODING_MODIFIED)) { result = TCL_CONVERT_SYNTAX; break; } diff --git a/tests/encoding.test b/tests/encoding.test index 45b5f49..3b3f42c 100644 --- a/tests/encoding.test +++ b/tests/encoding.test @@ -671,8 +671,11 @@ test encoding-24.17 {Parse valid or invalid utf-8} -constraints testbytestring - } -returnCodes 1 -result {expected byte sequence but character 1 was '䍃€' (U+004343)} test encoding-24.18 {Parse valid or invalid utf-8} -constraints testbytestring -body { encoding convertto utf-8 [testbytestring "Z\xE0\x80"] -stoponerror -} -returnCodes 1 -match glob -result {unexpected character at index 1: '*' (U+0000E0)} +} -result "Z\xC3\xA0\xE2\x82\xAC" test encoding-24.19 {Parse valid or invalid utf-8} -constraints testbytestring -body { + encoding convertto utf-8 [testbytestring "Z\xE0\x80xxxxxx"] -stoponerror +} -result "Z\xC3\xA0\xE2\x82\xACxxxxxx" +test encoding-24.20 {Parse valid or invalid utf-8} -constraints testbytestring -body { encoding convertto utf-8 "ZX\uD800" -stoponerror } -returnCodes 1 -match glob -result "unexpected character at index 2: '\uD800' (U+00D800)" -- cgit v0.12 From 6941f99c78c730b92f232078e1aa3bad1b84ae1c Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 1 Apr 2021 13:50:21 +0000 Subject: Add experimental "-nothrow" option to encoding convertfrom|convertto. If compiled with -DTCL_NO_DEPRECATED (meant for Tcl 9.0), -stoponerror is the default for all IO --- generic/tcl.h | 13 +++++++++++-- generic/tclCmdAH.c | 36 ++++++++++++++++++++++++++++-------- generic/tclEncoding.c | 26 ++++++++++++++++---------- tests/chanio.test | 8 +++++--- tests/cmdAH.test | 4 ++-- tests/encoding.test | 40 ++++++++++++++++++++-------------------- tests/http.test | 4 +++- tests/io.test | 11 ++++++----- tests/main.test | 4 +++- tests/safe.test | 8 ++++---- tests/source.test | 4 +++- 11 files changed, 101 insertions(+), 57 deletions(-) diff --git a/generic/tcl.h b/generic/tcl.h index dfb4c3a..f6c6730 100644 --- a/generic/tcl.h +++ b/generic/tcl.h @@ -2056,10 +2056,10 @@ typedef struct Tcl_EncodingType { * encountering an invalid byte sequence or a * source character that has no mapping in the * target encoding. If clear, the converter - * substitues the problematic character(s) with + * substitutes the problematic character(s) with * one or more "close" characters in the * destination buffer and then continues to - * convert the source. + * convert the source. Only for Tcl 8.x. * TCL_ENCODING_NO_TERMINATE - If set, Tcl_ExternalToUtf does not append a * terminating NUL byte. Since it does not need * an extra byte for a terminating NUL, it fills @@ -2078,6 +2078,14 @@ typedef struct Tcl_EncodingType { * 0x00. Only valid for "utf-8", "wtf-8 and "cesu-8". * This flag is implicit for external -> internal conversions, * optional for internal -> external conversions. + * TCL_ENCODING_NO_THROW - If set, the converter + * substitutes the problematic character(s) with + * one or more "close" characters in the + * destination buffer and then continues to + * convert the source. If clear, the converter returns + * immediately upon encountering an invalid byte sequence + * or a source character that has no mapping in the + * target encoding. Only for Tcl 9.x. */ #define TCL_ENCODING_START 0x01 @@ -2086,6 +2094,7 @@ typedef struct Tcl_EncodingType { #define TCL_ENCODING_NO_TERMINATE 0x08 #define TCL_ENCODING_CHAR_LIMIT 0x10 #define TCL_ENCODING_MODIFIED 0x20 +#define TCL_ENCODING_NO_THROW 0x40 /* * The following definitions are the error codes returned by the conversion diff --git a/generic/tclCmdAH.c b/generic/tclCmdAH.c index 1dfabd2..ca8e939 100644 --- a/generic/tclCmdAH.c +++ b/generic/tclCmdAH.c @@ -564,15 +564,25 @@ EncodingConvertfromObjCmd( if (objc > 3) { stopOnError = Tcl_GetString(objv[3]); if (!stopOnError[0]) { +#if TCL_MAJOR_VERSION < 9 && !defined(TCL_NO_DEPRECATED) stopOnError = NULL; - } else if (stopOnError[0] != '-' || stopOnError[1] != 's' - || strncmp(stopOnError, "-stoponerror", strlen(stopOnError))) { +#endif + } else if (stopOnError[0] == '-' && stopOnError[1] == 'n' + && !strncmp(stopOnError, "-nothrow", strlen(stopOnError))) { + stopOnError = NULL; + } else if (stopOnError[0] == '-' && stopOnError[1] == 's' + && !strncmp(stopOnError, "-stoponerror", strlen(stopOnError))) { + } else { goto encConvFromError; } +#if TCL_MAJOR_VERSION > 8 || defined(TCL_NO_DEPRECATED) + } else { + stopOnError = ""; +#endif } } else { encConvFromError: - Tcl_WrongNumArgs(interp, 1, objv, "?encoding? data ?-stoponerror?"); + Tcl_WrongNumArgs(interp, 1, objv, "?encoding? data ?-stoponerror|-nothrow?"); return TCL_ERROR; } @@ -588,7 +598,7 @@ EncodingConvertfromObjCmd( bytesPtr = (char *) Tcl_GetByteArrayFromObj(data, &length); } result = Tcl_ExternalToUtfDStringEx(encoding, bytesPtr, length, - stopOnError ? TCL_ENCODING_STOPONERROR : 0, &ds); + stopOnError ? TCL_ENCODING_STOPONERROR : TCL_ENCODING_NO_THROW, &ds); if (stopOnError && (result != (size_t)-1)) { Tcl_SetObjResult(interp, Tcl_ObjPrintf("unexpected byte at index %" TCL_LL_MODIFIER "u: '%c' (\\x%X)", (long long)result, UCHAR(bytesPtr[result]), UCHAR(bytesPtr[result]))); @@ -654,15 +664,25 @@ EncodingConverttoObjCmd( if (objc > 3) { stopOnError = Tcl_GetString(objv[3]); if (!stopOnError[0]) { +#if TCL_MAJOR_VERSION < 9 && !defined(TCL_NO_DEPRECATED) stopOnError = NULL; - } else if (stopOnError[0] != '-' || stopOnError[1] != 's' - || strncmp(stopOnError, "-stoponerror", strlen(stopOnError))) { +#endif + } else if (stopOnError[0] == '-' && stopOnError[1] == 'n' + && !strncmp(stopOnError, "-nothrow", strlen(stopOnError))) { + stopOnError = NULL; + } else if (stopOnError[0] == '-' && stopOnError[1] == 's' + && !strncmp(stopOnError, "-stoponerror", strlen(stopOnError))) { + } else { goto encConvToError; } +#if TCL_MAJOR_VERSION > 8 || defined(TCL_NO_DEPRECATED) + } else { + stopOnError = ""; +#endif } } else { encConvToError: - Tcl_WrongNumArgs(interp, 1, objv, "?encoding? data ?-stoponerror?"); + Tcl_WrongNumArgs(interp, 1, objv, "?encoding? data ?-stoponerror|-nothrow?"); return TCL_ERROR; } @@ -672,7 +692,7 @@ EncodingConverttoObjCmd( stringPtr = TclGetStringFromObj(data, &length); result = Tcl_UtfToExternalDStringEx(encoding, stringPtr, length, - stopOnError ? TCL_ENCODING_STOPONERROR : 0, &ds); + stopOnError ? TCL_ENCODING_STOPONERROR : TCL_ENCODING_NO_THROW, &ds); if (stopOnError && (result != (size_t)-1)) { size_t pos = Tcl_NumUtfChars(stringPtr, result); int ucs4; diff --git a/generic/tclEncoding.c b/generic/tclEncoding.c index b7c0a4f..76dbe7f 100644 --- a/generic/tclEncoding.c +++ b/generic/tclEncoding.c @@ -2223,6 +2223,12 @@ BinaryProc( *------------------------------------------------------------------------- */ +#if TCL_MAJOR_VERSION > 8 || defined(TCL_NO_DEPRECATED) +# define STOPONERROR !(flags & TCL_ENCODING_NO_THROW) +#else +# define STOPONERROR (flags & TCL_ENCODING_STOPONERROR) +#endif + static int UtfToUtfProc( ClientData clientData, /* additional flags, e.g. TCL_ENCODING_MODIFIED */ @@ -2305,7 +2311,7 @@ UtfToUtfProc( */ if (flags & TCL_ENCODING_MODIFIED) { - if (flags & TCL_ENCODING_STOPONERROR) { + if (STOPONERROR) { result = TCL_CONVERT_MULTIBYTE; break; } @@ -2320,7 +2326,7 @@ UtfToUtfProc( int low; const char *saveSrc = src; size_t len = TclUtfToUCS4(src, &ch); - if ((len < 2) && (ch != 0) && (flags & TCL_ENCODING_STOPONERROR) + if ((len < 2) && (ch != 0) && STOPONERROR && (flags & TCL_ENCODING_MODIFIED)) { result = TCL_CONVERT_SYNTAX; break; @@ -2346,7 +2352,7 @@ UtfToUtfProc( if (((low & ~0x3FF) != 0xDC00) || (ch & 0x400)) { if (!(flags & TCL_ENCODING_WTF)) { - if (flags & TCL_ENCODING_STOPONERROR) { + if (STOPONERROR) { result = TCL_CONVERT_UNKNOWN; src = saveSrc; break; @@ -2365,7 +2371,7 @@ UtfToUtfProc( dst += Tcl_UniCharToUtf(ch, dst); ch = low; } else if (!(flags & TCL_ENCODING_WTF) && !Tcl_UniCharIsUnicode(ch)) { - if (flags & TCL_ENCODING_STOPONERROR) { + if (STOPONERROR) { result = TCL_CONVERT_UNKNOWN; src = saveSrc; break; @@ -2561,7 +2567,7 @@ UtfToUtf16Proc( } len = TclUtfToUCS4(src, &ch); if (!(flags & TCL_ENCODING_WTF) && !Tcl_UniCharIsUnicode(ch)) { - if (flags & TCL_ENCODING_STOPONERROR) { + if (STOPONERROR) { result = TCL_CONVERT_UNKNOWN; break; } @@ -2781,7 +2787,7 @@ TableToUtfProc( ch = pageZero[byte]; } if ((ch == 0) && (byte != 0)) { - if (flags & TCL_ENCODING_STOPONERROR) { + if (STOPONERROR) { result = TCL_CONVERT_SYNTAX; break; } @@ -2901,7 +2907,7 @@ TableFromUtfProc( word = fromUnicode[(ch >> 8)][ch & 0xFF]; if ((word == 0) && (ch != 0)) { - if (flags & TCL_ENCODING_STOPONERROR) { + if (STOPONERROR) { result = TCL_CONVERT_UNKNOWN; break; } @@ -3089,7 +3095,7 @@ Iso88591FromUtfProc( || ((ch >= 0xD800) && (len < 3)) #endif ) { - if (flags & TCL_ENCODING_STOPONERROR) { + if (STOPONERROR) { result = TCL_CONVERT_UNKNOWN; break; } @@ -3316,7 +3322,7 @@ EscapeToUtfProc( if ((checked == dataPtr->numSubTables + 2) || (flags & TCL_ENCODING_END)) { - if ((flags & TCL_ENCODING_STOPONERROR) == 0) { + if (!STOPONERROR) { /* * Skip the unknown escape sequence. */ @@ -3491,7 +3497,7 @@ EscapeFromUtfProc( if (word == 0) { state = oldState; - if (flags & TCL_ENCODING_STOPONERROR) { + if (STOPONERROR) { result = TCL_CONVERT_UNKNOWN; break; } diff --git a/tests/chanio.test b/tests/chanio.test index 8dfefb7..64d67d1 100644 --- a/tests/chanio.test +++ b/tests/chanio.test @@ -18,6 +18,8 @@ if {"::tcltest" ni [namespace children]} { namespace import -force ::tcltest::* } +testConstraint nodep [info exists tcl_precision] + namespace eval ::tcl::test::io { if {"::tcltest" ni [namespace children]} { @@ -248,7 +250,7 @@ test chan-io-3.3 {WriteChars: compatibility with WriteBytes: flush on line} -bod } -cleanup { chan close $f } -result "\r\n12" -test chan-io-3.4 {WriteChars: loop over stage buffer} { +test chan-io-3.4 {WriteChars: loop over stage buffer} nodep { # stage buffer maps to more than can be queued at once. set f [open $path(test1) w] chan configure $f -encoding jis0208 -buffersize 16 @@ -257,7 +259,7 @@ test chan-io-3.4 {WriteChars: loop over stage buffer} { chan close $f lappend x [contents $path(test1)] } [list "!)!)!)!)!)!)!)!)" "!)!)!)!)!)!)!)!)!)!)!)!)!)!)!)"] -test chan-io-3.5 {WriteChars: saved != 0} { +test chan-io-3.5 {WriteChars: saved != 0} nodep { # Bytes produced by UtfToExternal from end of last channel buffer had to # be moved to beginning of next channel buffer to preserve requested # buffersize. @@ -284,7 +286,7 @@ test chan-io-3.6 {WriteChars: (stageRead + dstWrote == 0)} { chan close $f lappend x [contents $path(test1)] } [list "12345678901234\x82\x60" "12345678901234\x82\x60\x82\x61"] -test chan-io-3.7 {WriteChars: (bufPtr->nextAdded > bufPtr->length)} { +test chan-io-3.7 {WriteChars: (bufPtr->nextAdded > bufPtr->length)} nodep { # When translating UTF-8 to external, the produced bytes went past end of # the channel buffer. This is done on purpose - we then truncate the bytes # at the end of the partial character to preserve the requested blocksize diff --git a/tests/cmdAH.test b/tests/cmdAH.test index f60068d..e9973a9 100644 --- a/tests/cmdAH.test +++ b/tests/cmdAH.test @@ -178,7 +178,7 @@ test cmdAH-4.2 {Tcl_EncodingObjCmd} -returnCodes error -body { } -result {unknown or ambiguous subcommand "foo": must be convertfrom, convertto, dirs, names, or system} test cmdAH-4.3 {Tcl_EncodingObjCmd} -returnCodes error -body { encoding convertto -} -result {wrong # args: should be "encoding convertto ?encoding? data ?-stoponerror?"} +} -result {wrong # args: should be "encoding convertto ?encoding? data ?-stoponerror|-nothrow?"} test cmdAH-4.4 {Tcl_EncodingObjCmd} -returnCodes error -body { encoding convertto foo bar } -result {unknown encoding "foo"} @@ -200,7 +200,7 @@ test cmdAH-4.6 {Tcl_EncodingObjCmd} -setup { } -result 8C test cmdAH-4.7 {Tcl_EncodingObjCmd} -returnCodes error -body { encoding convertfrom -} -result {wrong # args: should be "encoding convertfrom ?encoding? data ?-stoponerror?"} +} -result {wrong # args: should be "encoding convertfrom ?encoding? data ?-stoponerror|-nothrow?"} test cmdAH-4.8 {Tcl_EncodingObjCmd} -returnCodes error -body { encoding convertfrom foo bar } -result {unknown encoding "foo"} diff --git a/tests/encoding.test b/tests/encoding.test index 3b3f42c..0a5417e 100644 --- a/tests/encoding.test +++ b/tests/encoding.test @@ -291,7 +291,7 @@ test encoding-11.9 {encoding: extended Unicode UTF-16} { test encoding-12.1 {LoadTableEncoding: normal encoding} { set x [encoding convertto iso8859-3 Ġ] - append x [encoding convertto iso8859-3 Õ] + append x [encoding convertto iso8859-3 Õ -nothrow] append x [encoding convertfrom iso8859-3 Õ] } "Õ?Ġ" test encoding-12.2 {LoadTableEncoding: single-byte encoding} { @@ -400,7 +400,7 @@ test encoding-15.15 {UtfToUtfProc low surrogate character output} { } {1 3 eda882} test encoding-15.16 {UtfToUtfProc: Invalid 4-byte UTF-8, see [ed29806ba]} { set x \xF0\xA0\xA1\xC2 - set y [encoding convertfrom utf-8 \xF0\xA0\xA1\xC2] + set y [encoding convertfrom utf-8 \xF0\xA0\xA1\xC2 -nothrow] list [string length $x] $y } "4 \xF0\xA0\xA1\xC2" test encoding-15.17 {UtfToUtfProc emoji character output} { @@ -411,61 +411,61 @@ test encoding-15.17 {UtfToUtfProc emoji character output} { } {4 f09f9882} test encoding-15.18 {UtfToUtfProc emoji character output} { set x \uDE02\uD83D\uDE02\uD83D - set y [encoding convertto utf-8 \uDE02\uD83D\uDE02\uD83D] + set y [encoding convertto utf-8 \uDE02\uD83D\uDE02\uD83D -nothrow] binary scan $y H* z list [string length $y] $z } {10 efbfbdf09f9882efbfbd} test encoding-15.19 {UtfToUtfProc emoji character output} { set x \uDE02\uD83D\uD83D - set y [encoding convertto utf-8 \uDE02\uD83D\uD83D] + set y [encoding convertto utf-8 \uDE02\uD83D\uD83D -nothrow] binary scan $y H* z list [string length $x] [string length $y] $z } {3 9 efbfbdefbfbdefbfbd} test encoding-15.20 {UtfToUtfProc emoji character output} { set x \uDE02\uD83D\xE9 - set y [encoding convertto utf-8 \uDE02\uD83D\xE9] + set y [encoding convertto utf-8 \uDE02\uD83D\xE9 -nothrow] binary scan $y H* z list [string length $x] [string length $y] $z } {3 8 efbfbdefbfbdc3a9} test encoding-15.21 {UtfToUtfProc emoji character output} { set x \uDE02\uD83DX - set y [encoding convertto utf-8 \uDE02\uD83DX] + set y [encoding convertto utf-8 \uDE02\uD83DX -nothrow] binary scan $y H* z list [string length $x] [string length $y] $z } {3 7 efbfbdefbfbd58} test encoding-15.22 {UtfToUtfProc high surrogate character output} { set x \uDE02\xE9 - set y [encoding convertto utf-8 \uDE02\xE9] + set y [encoding convertto utf-8 \uDE02\xE9 -nothrow] binary scan $y H* z list [string length $x] [string length $y] $z } {2 5 efbfbdc3a9} test encoding-15.23 {UtfToUtfProc low surrogate character output} { set x \uDA02\xE9 - set y [encoding convertto utf-8 \uDA02\xE9] + set y [encoding convertto utf-8 \uDA02\xE9 -nothrow] binary scan $y H* z list [string length $x] [string length $y] $z } {2 5 efbfbdc3a9} test encoding-15.24 {UtfToUtfProc high surrogate character output} { set x \uDE02Y - set y [encoding convertto utf-8 \uDE02Y] + set y [encoding convertto utf-8 \uDE02Y -nothrow] binary scan $y H* z list [string length $x] [string length $y] $z } {2 4 efbfbd59} test encoding-15.25 {UtfToUtfProc low surrogate character output} { set x \uDA02Y - set y [encoding convertto utf-8 \uDA02Y] + set y [encoding convertto utf-8 \uDA02Y -nothrow] binary scan $y H* z list [string length $x] [string length $y] $z } {2 4 efbfbd59} test encoding-15.26 {UtfToUtfProc high surrogate character output} { set x \uDE02 - set y [encoding convertto utf-8 \uDE02] + set y [encoding convertto utf-8 \uDE02 -nothrow] binary scan $y H* z list [string length $x] [string length $y] $z } {1 3 efbfbd} test encoding-15.27 {UtfToUtfProc low surrogate character output} { set x \uDA02 - set y [encoding convertto utf-8 \uDA02] + set y [encoding convertto utf-8 \uDA02 -nothrow] binary scan $y H* z list [string length $x] [string length $y] $z } {1 3 efbfbd} @@ -509,10 +509,10 @@ test encoding-17.4 {UtfToUcs2Proc} -body { encoding convertfrom utf-16 [encoding convertto ucs-2 "\U460DC"] } -result "\uFFFD" test encoding-17.5 {UtfToUtf16Proc} -body { - encoding convertto utf-16be "\uDCDC" + encoding convertto utf-16be "\uDCDC" -nothrow } -result "\xFF\xFD" test encoding-17.6 {UtfToUtf16Proc} -body { - encoding convertto utf-16le "\uD8D8" + encoding convertto utf-16le "\uD8D8" -nothrow } -result "\xFD\xFF" test encoding-18.1 {TableToUtfProc} { @@ -631,25 +631,25 @@ test encoding-24.4 {Parse valid or invalid utf-8} { string length [encoding convertfrom utf-8 "\xC0\x80"] } 1 test encoding-24.5 {Parse valid or invalid utf-8} { - string length [encoding convertfrom utf-8 "\xC0\x81"] + string length [encoding convertfrom utf-8 "\xC0\x81" -nothrow] } 2 test encoding-24.6 {Parse valid or invalid utf-8} { - string length [encoding convertfrom utf-8 "\xC1\xBF"] + string length [encoding convertfrom utf-8 "\xC1\xBF" -nothrow] } 2 test encoding-24.7 {Parse valid or invalid utf-8} { string length [encoding convertfrom utf-8 "\xC2\x80"] } 1 test encoding-24.8 {Parse valid or invalid utf-8} { - string length [encoding convertfrom utf-8 "\xE0\x80\x80"] + string length [encoding convertfrom utf-8 "\xE0\x80\x80" -nothrow] } 3 test encoding-24.9 {Parse valid or invalid utf-8} { - string length [encoding convertfrom utf-8 "\xE0\x9F\xBF"] + string length [encoding convertfrom utf-8 "\xE0\x9F\xBF" -nothrow] } 3 test encoding-24.10 {Parse valid or invalid utf-8} { string length [encoding convertfrom utf-8 "\xE0\xA0\x80"] } 1 test encoding-24.11 {Parse valid or invalid utf-8} { - string length [encoding convertfrom utf-8 "\xEF\xBF\xBF"] + string length [encoding convertfrom utf-8 "\xEF\xBF\xBF" -nothrow] } 1 test encoding-24.12 {Parse valid or invalid utf-8} { string length [encoding convertfrom utf-8 "\xC0\x80" -stoponerror] @@ -833,7 +833,7 @@ test encoding-28.0 {all encodings load} -body { set string hello foreach name [encoding names] { incr count - encoding convertto $name $string + encoding convertto $name $string -nothrow # discard the cached internal representation of Tcl_Encoding # Unfortunately, without this, encoding 2-1 fails. diff --git a/tests/http.test b/tests/http.test index 2fd5af4..1275984 100644 --- a/tests/http.test +++ b/tests/http.test @@ -31,6 +31,8 @@ if {[catch {package require http 2} version]} { } } +testConstraint nodep [info exists tcl_precision] + proc bgerror {args} { global errorInfo puts stderr "http.test bgerror" @@ -661,7 +663,7 @@ test http-7.3 {http::formatQuery} -setup { } -cleanup { http::config -urlencoding $enc } -result "can't read \"formMap(∈)\": no such element in array" -test http-7.4 {http::formatQuery} -setup { +test http-7.4 {http::formatQuery} -constraints nodep -setup { set enc [http::config -urlencoding] } -body { # this would be reverting to http <=2.4 behavior w/o errors diff --git a/tests/io.test b/tests/io.test index e0a2389..329d041 100644 --- a/tests/io.test +++ b/tests/io.test @@ -48,6 +48,7 @@ testConstraint testservicemode [llength [info commands testservicemode]] testConstraint notWinCI [expr { $::tcl_platform(platform) ne "windows" || ![info exists ::env(CI)]}] testConstraint notOSX [expr {$::tcl_platform(os) ne "Darwin"}] +testConstraint nodep [info exists tcl_precision] # You need a *very* special environment to do some tests. In # particular, many file systems do not support large-files... @@ -268,7 +269,7 @@ test io-3.3 {WriteChars: compatibility with WriteBytes: flush on line} { close $f set x } "\r\n12" -test io-3.4 {WriteChars: loop over stage buffer} { +test io-3.4 {WriteChars: loop over stage buffer} nodep { # stage buffer maps to more than can be queued at once. set f [open $path(test1) w] @@ -278,7 +279,7 @@ test io-3.4 {WriteChars: loop over stage buffer} { close $f lappend x [contents $path(test1)] } [list "!)!)!)!)!)!)!)!)" "!)!)!)!)!)!)!)!)!)!)!)!)!)!)!)"] -test io-3.5 {WriteChars: saved != 0} { +test io-3.5 {WriteChars: saved != 0} nodep { # Bytes produced by UtfToExternal from end of last channel buffer # had to be moved to beginning of next channel buffer to preserve # requested buffersize. @@ -307,7 +308,7 @@ test io-3.6 {WriteChars: (stageRead + dstWrote == 0)} { close $f lappend x [contents $path(test1)] } [list "12345678901234\x82\x60" "12345678901234\x82\x60\x82\x61"] -test io-3.7 {WriteChars: (bufPtr->nextAdded > bufPtr->length)} { +test io-3.7 {WriteChars: (bufPtr->nextAdded > bufPtr->length)} nodep { # When translating UTF-8 to external, the produced bytes went past end # of the channel buffer. This is done purpose -- we then truncate the # bytes at the end of the partial character to preserve the requested @@ -1532,7 +1533,7 @@ test io-12.8 {ReadChars: multibyte chars split} { close $f scan [string index $in end] %c } 160 -test io-12.9 {ReadChars: multibyte chars split} { +test io-12.9 {ReadChars: multibyte chars split} nodep { set f [open $path(test1) w] fconfigure $f -translation binary puts -nonewline $f [string repeat a 9]\xC2 @@ -1543,7 +1544,7 @@ test io-12.9 {ReadChars: multibyte chars split} { close $f scan [string index $in end] %c } 194 -test io-12.10 {ReadChars: multibyte chars split} { +test io-12.10 {ReadChars: multibyte chars split} nodep { set f [open $path(test1) w] fconfigure $f -translation binary puts -nonewline $f [string repeat a 9]\xC2 diff --git a/tests/main.test b/tests/main.test index 2d3f63c..1480bc2 100644 --- a/tests/main.test +++ b/tests/main.test @@ -5,6 +5,8 @@ if {"::tcltest" ni [namespace children]} { namespace import -force ::tcltest::* } +testConstraint nodep [info exists tcl_precision] + namespace eval ::tcl::test::main { namespace import ::tcltest::* @@ -143,7 +145,7 @@ namespace eval ::tcl::test::main { test Tcl_Main-1.8 { Tcl_Main: startup script - -encoding option - mismatched encodings } -constraints { - stdio + stdio nodep } -setup { set script [makeFile {} script] file delete $script diff --git a/tests/safe.test b/tests/safe.test index e2a9b83..b6668d7 100644 --- a/tests/safe.test +++ b/tests/safe.test @@ -1267,7 +1267,7 @@ test safe-11.7 {testing safe encoding} -setup { interp eval $i encoding convertfrom } -returnCodes error -cleanup { safe::interpDelete $i -} -result {wrong # args: should be "encoding convertfrom ?encoding? data ?-stoponerror?"} +} -result {wrong # args: should be "encoding convertfrom ?encoding? data ?-stoponerror|-nothrow?"} test safe-11.7.1 {testing safe encoding} -setup { set i [safe::interpCreate] } -body { @@ -1276,7 +1276,7 @@ test safe-11.7.1 {testing safe encoding} -setup { } -returnCodes ok -match glob -cleanup { unset -nocomplain m o safe::interpDelete $i -} -result {wrong # args: should be "encoding convertfrom ?encoding? data ?-stoponerror?" +} -result {wrong # args: should be "encoding convertfrom ?encoding? data ?-stoponerror|-nothrow?" while executing "encoding convertfrom" invoked from within @@ -1289,7 +1289,7 @@ test safe-11.8 {testing safe encoding} -setup { interp eval $i encoding convertto } -returnCodes error -cleanup { safe::interpDelete $i -} -result {wrong # args: should be "encoding convertto ?encoding? data ?-stoponerror?"} +} -result {wrong # args: should be "encoding convertto ?encoding? data ?-stoponerror|-nothrow?"} test safe-11.8.1 {testing safe encoding} -setup { set i [safe::interpCreate] } -body { @@ -1298,7 +1298,7 @@ test safe-11.8.1 {testing safe encoding} -setup { } -returnCodes ok -match glob -cleanup { unset -nocomplain m o safe::interpDelete $i -} -result {wrong # args: should be "encoding convertto ?encoding? data ?-stoponerror?" +} -result {wrong # args: should be "encoding convertto ?encoding? data ?-stoponerror|-nothrow?" while executing "encoding convertto" invoked from within diff --git a/tests/source.test b/tests/source.test index eee03ec..1748a70 100644 --- a/tests/source.test +++ b/tests/source.test @@ -20,6 +20,8 @@ if {[catch {package require tcltest 2.5}]} { namespace eval ::tcl::test::source { namespace import ::tcltest::* +testConstraint nodep [info exists tcl_precision] + test source-1.1 {source command} -setup { set x "old x value" set y "old y value" @@ -275,7 +277,7 @@ test source-7.5 {source -encoding: correct operation} -setup { removeFile source.file rename € {} } -result foo -test source-7.6 {source -encoding: mismatch encoding error} -setup { +test source-7.6 {source -encoding: mismatch encoding error} -constraints nodep -setup { set sourcefile [makeFile {} source.file] file delete $sourcefile set f [open $sourcefile w] -- cgit v0.12 From 684b9f01af31b898f57e7f05934043893186afc2 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 1 Apr 2021 14:55:22 +0000 Subject: Set errorcode for STOPONERROR --- generic/tclCmdAH.c | 14 +++++++++++--- 1 file changed, 11 insertions(+), 3 deletions(-) diff --git a/generic/tclCmdAH.c b/generic/tclCmdAH.c index ca8e939..cb5ef01 100644 --- a/generic/tclCmdAH.c +++ b/generic/tclCmdAH.c @@ -600,8 +600,12 @@ EncodingConvertfromObjCmd( result = Tcl_ExternalToUtfDStringEx(encoding, bytesPtr, length, stopOnError ? TCL_ENCODING_STOPONERROR : TCL_ENCODING_NO_THROW, &ds); if (stopOnError && (result != (size_t)-1)) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf("unexpected byte at index %" - TCL_LL_MODIFIER "u: '%c' (\\x%X)", (long long)result, UCHAR(bytesPtr[result]), UCHAR(bytesPtr[result]))); + char buf[TCL_INTEGER_SPACE]; + sprintf(buf, "%" TCL_Z_MODIFIER "u", result); + Tcl_SetObjResult(interp, Tcl_ObjPrintf("unexpected byte at index %" + TCL_Z_MODIFIER "u: '%c' (\\x%X)", result, UCHAR(bytesPtr[result]), UCHAR(bytesPtr[result]))); + Tcl_SetErrorCode(interp, "TCL", "ENCODING", "STOPONERROR", + buf, NULL); Tcl_DStringFree(&ds); return TCL_ERROR; } @@ -696,9 +700,13 @@ EncodingConverttoObjCmd( if (stopOnError && (result != (size_t)-1)) { size_t pos = Tcl_NumUtfChars(stringPtr, result); int ucs4; + char buf[TCL_INTEGER_SPACE]; TclUtfToUCS4(&stringPtr[result], &ucs4); + sprintf(buf, "%" TCL_Z_MODIFIER "u", result); Tcl_SetObjResult(interp, Tcl_ObjPrintf("unexpected character at index %" - TCL_LL_MODIFIER "u: '%c' (U+%06X)", (long long)pos, ucs4, ucs4)); + TCL_Z_MODIFIER "u: '%c' (U+%06X)", pos, ucs4, ucs4)); + Tcl_SetErrorCode(interp, "TCL", "ENCODING", "STOPONERROR", + buf, NULL); Tcl_DStringFree(&ds); return TCL_ERROR; } -- cgit v0.12 From 171ff16f7d1431ba085c9bb1dd90d64210ffb30c Mon Sep 17 00:00:00 2001 From: pooryorick Date: Fri, 2 Apr 2021 21:20:46 +0000 Subject: New test for OO cleanup: routine for object gets deleted before namespace deletion is complete. --- tests/oo.test | 37 ++++++++++++++++++++++++++++++++++++- 1 file changed, 36 insertions(+), 1 deletion(-) diff --git a/tests/oo.test b/tests/oo.test index 168baee..404c6a4 100644 --- a/tests/oo.test +++ b/tests/oo.test @@ -1734,6 +1734,7 @@ test oo-11.6.3 { } -result 0 -cleanup { } + test oo-11.6.4 { OO: cleanup ReleaseClassContents() where class is mixed into one of its instances @@ -1754,6 +1755,37 @@ test oo-11.6.4 { rename obj1 {} } + +test oo-11.7 { + When an object is deleted its namespace is deleted, and all objects it is + mixed into are also deleted. If the object has been renamed into the + namespace of one of the objects it has been mixed into, the routine for the + object might get entirely deleted before the namespace of the object is + entirely deleted, in which case the C routine the performs the namespace + either must either understand that the handle on the routine for the object + might now be gone, or it must be guaranteed that the handle does not + disappear until that routine is finished. +} -setup { +} -body { + oo::define oo::class { + export createWithNamespace + } + oo::class create class1 + + oo::object create obj1 + oo::objdefine obj1 { + mixin ::class1 + } + set obj1ns [info object namespace obj1] + set class1ns [info object namespace class1] + rename class1 ${obj1ns}::class1 + # No segmentation fault + namespace delete $class1ns +} -cleanup { + rename obj {} +} -result done + + test oo-12.1 {OO: filters} { oo::class create Aclass Aclass create Aobject @@ -1777,6 +1809,8 @@ test oo-12.1 {OO: filters} { Aclass destroy return $result } {{calling ::Aobject->logFilter 1 2 3 4 5} 1 2 3 4 5 result=12345 12345} + + test oo-12.2 {OO: filters} -setup { oo::class create Aclass Aclass create Aobject @@ -4376,12 +4410,13 @@ test oo-35.6 { } -body { rename obj2 {} rename obj1 {} - # doesn't crash + # No segmentation fault return done } -cleanup { rename obj {} } -result done + test oo-36.1 {TIP #470: introspection within oo::define} { oo::define oo::object self } ::oo::object -- cgit v0.12 From 7d6ca39c8fc1416903f2fe01216ed2d7b435feb3 Mon Sep 17 00:00:00 2001 From: pooryorick Date: Fri, 2 Apr 2021 23:02:00 +0000 Subject: OO cleanup fix that passes test 11.7. --- generic/tclOO.c | 23 ++++++++++++----------- tests/oo.test | 13 +++++-------- 2 files changed, 17 insertions(+), 19 deletions(-) diff --git a/generic/tclOO.c b/generic/tclOO.c index 4dbe668..559cf0b 100644 --- a/generic/tclOO.c +++ b/generic/tclOO.c @@ -1184,18 +1184,19 @@ ObjectNamespaceDeleted( * freed memory. */ - if (((Command *) oPtr->command)->flags && CMD_DYING) { - /* - * Something has already started the command deletion process. We can - * go ahead and clean up the the namespace, - */ - } else { - /* - * The namespace must have been deleted directly. Delete the command - * as well. - */ + if (oPtr->command != NULL) { + if (((Command *) oPtr->command)->flags && CMD_DYING) { + /* + * The command is already (being) deleted. Proceed to clean up the the namespace, + */ + } else { + /* + * The namespace must have been deleted directly. Delete the command + * as well. + */ - Tcl_DeleteCommandFromToken(oPtr->fPtr->interp, oPtr->command); + Tcl_DeleteCommandFromToken(oPtr->fPtr->interp, oPtr->command); + } } if (oPtr->myclassCommand) { diff --git a/tests/oo.test b/tests/oo.test index 404c6a4..7980f9e 100644 --- a/tests/oo.test +++ b/tests/oo.test @@ -1761,15 +1761,12 @@ test oo-11.7 { mixed into are also deleted. If the object has been renamed into the namespace of one of the objects it has been mixed into, the routine for the object might get entirely deleted before the namespace of the object is - entirely deleted, in which case the C routine the performs the namespace - either must either understand that the handle on the routine for the object - might now be gone, or it must be guaranteed that the handle does not - disappear until that routine is finished. + entirely deleted, in which case the C routine that performs the namespace + deletion either must either understand that the handle on the routine for + the object might now be gone, or it must be guaranteed that the handle does + not disappear until that routine is finished. } -setup { } -body { - oo::define oo::class { - export createWithNamespace - } oo::class create class1 oo::object create obj1 @@ -1781,8 +1778,8 @@ test oo-11.7 { rename class1 ${obj1ns}::class1 # No segmentation fault namespace delete $class1ns + return done } -cleanup { - rename obj {} } -result done -- cgit v0.12 From c98ea4af2fac0552f8453c1787028523e1d19117 Mon Sep 17 00:00:00 2001 From: pooryorick Date: Fri, 2 Apr 2021 23:21:50 +0000 Subject: Use TclCleanupCommandMacro instead of just decrementing the reference count. --- generic/tclBasic.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/generic/tclBasic.c b/generic/tclBasic.c index b90e12d..ce8c4ed 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -3662,7 +3662,7 @@ CallCommandTraces( */ cmdPtr->flags &= ~CMD_TRACE_ACTIVE; - cmdPtr->refCount--; + TclCleanupCommandMacro(cmdPtr); iPtr->activeCmdTracePtr = active.nextPtr; Tcl_Release(iPtr); return result; -- cgit v0.12 From aef7e169a724687ab05b72273b5a7fbc2fba22cc Mon Sep 17 00:00:00 2001 From: pooryorick Date: Sat, 3 Apr 2021 10:43:53 +0000 Subject: Remove suspected inadvertent copypasta from test. --- tests/namespace.test | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/tests/namespace.test b/tests/namespace.test index 3394824..679b468 100644 --- a/tests/namespace.test +++ b/tests/namespace.test @@ -3301,8 +3301,8 @@ test namespace-56.2 {bug f97d4ee020: mutually-entangled deletion} { namespace eval ::testing { namespace eval abc {proc xyz {} {}} namespace eval def {proc xyz {} {}} - trace add command abc::xyz delete "namespace delete ::testing::def {}; #" - trace add command def::xyz delete "namespace delete ::testing::abc {}; #" + trace add command abc::xyz delete "namespace delete ::testing::def; #" + trace add command def::xyz delete "namespace delete ::testing::abc; #" } namespace delete ::testing } {} -- cgit v0.12 From 02855d5980f78e6e42b3a35274a26c978f9af694 Mon Sep 17 00:00:00 2001 From: pooryorick Date: Sat, 3 Apr 2021 12:04:21 +0000 Subject: When a namesapce is deleted delete all namespaces under it before making any modifictions to it. --- generic/tclInt.h | 1 + generic/tclNamesp.c | 142 ++++++++++++++++++++++++++++++---------------------- 2 files changed, 84 insertions(+), 59 deletions(-) diff --git a/generic/tclInt.h b/generic/tclInt.h index 2448b5a..3ac46bb 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -2890,6 +2890,7 @@ MODULE_SCOPE Tcl_Command TclCreateEnsembleInNs(Tcl_Interp *interp, const char *name, Tcl_Namespace *nameNamespacePtr, Tcl_Namespace *ensembleNamespacePtr, int flags); MODULE_SCOPE void TclDeleteNamespaceVars(Namespace *nsPtr); +MODULE_SCOPE void TclDeleteNamespaceChildren(Namespace *nsPt); MODULE_SCOPE int TclFindDictElement(Tcl_Interp *interp, const char *dict, int dictLength, const char **elementPtr, const char **nextPtr, diff --git a/generic/tclNamesp.c b/generic/tclNamesp.c index b2d717b..607072b 100644 --- a/generic/tclNamesp.c +++ b/generic/tclNamesp.c @@ -917,10 +917,10 @@ Tcl_DeleteNamespace( /* * Give anyone interested - notably TclOO - a chance to use this namespace * normally despite the fact that the namespace is going to go. Allows the - * calling of destructors. Will only be called once (unless re-established + * calling of destructors. Only called once (unless re-established * by the called function). [Bug 2950259] * - * Note that setting this field requires access to the internal definition + * Setting this field requires access to the internal definition * of namespaces, so it should only be accessed by code that knows about * being careful with reentrancy. */ @@ -1065,7 +1065,7 @@ Tcl_DeleteNamespace( } TclNsDecrRefCount(nsPtr); } - + int TclNamespaceDeleted( Namespace *nsPtr) @@ -1073,6 +1073,83 @@ TclNamespaceDeleted( return (nsPtr->flags & NS_DYING) ? 1 : 0; } +void +TclDeleteNamespaceChildren( + Namespace *nsPtr /* Namespace whose children to delete */ +) +{ + Interp *iPtr = (Interp *) nsPtr->interp; + Tcl_HashEntry *entryPtr; + int i, unchecked; + Tcl_HashSearch search; + /* + * Delete all the child namespaces. + * + * BE CAREFUL: When each child is deleted, it divorces itself from its + * parent. The hash table can't be proplery traversed if its elements are + * being deleted. Because of traces (and the desire to avoid the + * quadratic problems of just using Tcl_FirstHashEntry over and over, [Bug + * f97d4ee020]) copy to a temporary array and then delete all those + * namespaces. + * + * Important: leave the hash table itself still live. + */ + +#ifndef BREAK_NAMESPACE_COMPAT + unchecked = (nsPtr->childTable.numEntries > 0); + while (nsPtr->childTable.numEntries > 0 && unchecked) { + int length = nsPtr->childTable.numEntries; + Namespace **children = (Namespace **)TclStackAlloc((Tcl_Interp *) iPtr, + sizeof(Namespace *) * length); + + i = 0; + for (entryPtr = Tcl_FirstHashEntry(&nsPtr->childTable, &search); + entryPtr != NULL; + entryPtr = Tcl_NextHashEntry(&search)) { + children[i] = (Namespace *)Tcl_GetHashValue(entryPtr); + children[i]->refCount++; + i++; + } + unchecked = 0; + for (i = 0 ; i < length ; i++) { + if (!(children[i]->flags & NS_DYING)) { + unchecked = 1; + Tcl_DeleteNamespace((Tcl_Namespace *) children[i]); + TclNsDecrRefCount(children[i]); + } + } + TclStackFree((Tcl_Interp *) iPtr, children); + } +#else + if (nsPtr->childTablePtr != NULL) { + unchecked = (nsPtr->childTable.numEntries > 0); + while (nsPtr->childTable.numEntries > 0 && unchecked) { + int length = nsPtr->childTablePtr->numEntries; + Namespace **children = (Namespace **)TclStackAlloc((Tcl_Interp *) iPtr, + sizeof(Namespace *) * length); + + i = 0; + for (entryPtr = Tcl_FirstHashEntry(nsPtr->childTablePtr, &search); + entryPtr != NULL; + entryPtr = Tcl_NextHashEntry(&search)) { + children[i] = (Namespace *)Tcl_GetHashValue(entryPtr); + children[i]->refCount++; + i++; + } + unchecked = 0; + for (i = 0 ; i < length ; i++) { + if (!(children[i]->flags & NS_DYING)) { + unchecked = 1; + Tcl_DeleteNamespace((Tcl_Namespace *) children[i]); + TclNsDecrRefCount(children[i]); + } + } + TclStackFree((Tcl_Interp *) iPtr, children); + } + } +#endif +} + /* *---------------------------------------------------------------------- * @@ -1105,6 +1182,9 @@ TclTeardownNamespace( Tcl_HashSearch search; size_t i; + + TclDeleteNamespaceChildren(nsPtr); + /* * Start by destroying the namespace's variable table, since variables * might trigger traces. Variable table should be cleared but not freed! @@ -1181,62 +1261,6 @@ TclTeardownNamespace( nsPtr->commandPathSourceList = NULL; } - /* - * Delete all the child namespaces. - * - * BE CAREFUL: When each child is deleted, it will divorce itself from its - * parent. You can't traverse a hash table properly if its elements are - * being deleted. Because of traces (and the desire to avoid the - * quadratic problems of just using Tcl_FirstHashEntry over and over, [Bug - * f97d4ee020]) we copy to a temporary array and then delete all those - * namespaces. - * - * Important: leave the hash table itself still live. - */ - -#ifndef BREAK_NAMESPACE_COMPAT - while (nsPtr->childTable.numEntries > 0) { - size_t length = nsPtr->childTable.numEntries; - Namespace **children = (Namespace **)TclStackAlloc((Tcl_Interp *) iPtr, - sizeof(Namespace *) * length); - - i = 0; - for (entryPtr = Tcl_FirstHashEntry(&nsPtr->childTable, &search); - entryPtr != NULL; - entryPtr = Tcl_NextHashEntry(&search)) { - children[i] = (Namespace *)Tcl_GetHashValue(entryPtr); - children[i]->refCount++; - i++; - } - for (i = 0 ; i < length ; i++) { - Tcl_DeleteNamespace((Tcl_Namespace *) children[i]); - TclNsDecrRefCount(children[i]); - } - TclStackFree((Tcl_Interp *) iPtr, children); - } -#else - if (nsPtr->childTablePtr != NULL) { - while (nsPtr->childTablePtr->numEntries > 0) { - size_t length = nsPtr->childTablePtr->numEntries; - Namespace **children = (Namespace **)TclStackAlloc((Tcl_Interp *) iPtr, - sizeof(Namespace *) * length); - - i = 0; - for (entryPtr = Tcl_FirstHashEntry(nsPtr->childTablePtr, &search); - entryPtr != NULL; - entryPtr = Tcl_NextHashEntry(&search)) { - children[i] = Tcl_GetHashValue(entryPtr); - children[i]->refCount++; - i++; - } - for (i = 0 ; i < length ; i++) { - Tcl_DeleteNamespace((Tcl_Namespace *) children[i]); - TclNsDecrRefCount(children[i]); - } - TclStackFree((Tcl_Interp *) iPtr, children); - } - } -#endif /* * Free the namespace's export pattern array. -- cgit v0.12 From 78c53b37ab0bf3c76d498a839f6659235efff3cd Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Sun, 4 Apr 2021 15:35:13 +0000 Subject: Implement support for Tcl_SetPreInitScript() --- generic/tcl.h | 2 ++ generic/tclStubCall.c | 10 ++++++---- 2 files changed, 8 insertions(+), 4 deletions(-) diff --git a/generic/tcl.h b/generic/tcl.h index 6dd881d..faf0d49 100644 --- a/generic/tcl.h +++ b/generic/tcl.h @@ -2239,6 +2239,8 @@ extern void *TclStubCall(void *arg); ((Tcl_ExitProc *(*)(Tcl_ExitProc *))TclStubCall((void *)7))(proc) #define Tcl_GetMemoryInfo(dsPtr) \ (void)((const char *(*)(Tcl_DString *))TclStubCall((void *)8))(dsPtr) +#define Tcl_SetPreInitScript(string) \ + ((const char *(*)(const char *))TclStubCall((void *)9))(string) #endif /* diff --git a/generic/tclStubCall.c b/generic/tclStubCall.c index 0eb46b6..e0d85a6 100644 --- a/generic/tclStubCall.c +++ b/generic/tclStubCall.c @@ -28,9 +28,10 @@ MODULE_SCOPE void *tclStubsHandle; * returning NULL if that function cannot be found. See PROCNAME table. * * The functions Tcl_MainEx and Tcl_MainExW never return. - * Tcl_GetMemoryInfo and Tcl_StaticLibrary return (void) and - * Tcl_SetExitProc returns its previous exitProc. This means that - * those 5 functions cannot be used to initialize the stub-table, + * Tcl_GetMemoryInfo and Tcl_StaticLibrary return (void), + * Tcl_SetExitProc returns its previous exitProc and + * Tcl_SetPreInitScript returns the previous script. This means that + * those 6 functions cannot be used to initialize the stub-table, * only the first 4 functions in the table can do that. * *---------------------------------------------------------------------- @@ -46,7 +47,8 @@ static const char PROCNAME[][24] = { "_Tcl_MainEx", /* "arg" == (void *)5 */ "_Tcl_StaticLibrary", /* "arg" == (void *)6 */ "_Tcl_SetExitProc", /* "arg" == (void *)7 */ - "_Tcl_GetMemoryInfo" /* "arg" == (void *)8 */ + "_Tcl_GetMemoryInfo", /* "arg" == (void *)8 */ + "_Tcl_SetPreInitScript" /* "arg" == (void *)9 */ }; MODULE_SCOPE const void *nullVersionProc(void) { -- cgit v0.12 From ce1a1c9f1387df9db70689527f74c37b4c3cf7c0 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 6 Apr 2021 15:57:35 +0000 Subject: Update rules.vc --- win/rules.vc | 11 +++++++++-- 1 file changed, 9 insertions(+), 2 deletions(-) diff --git a/win/rules.vc b/win/rules.vc index 2ec5292..85c37f2 100644 --- a/win/rules.vc +++ b/win/rules.vc @@ -1203,9 +1203,16 @@ TCLSH_NATIVE = $(TCLSH) !if $(DOING_TK) || $(NEED_TK) WISHNAMEPREFIX = wish WISHNAME = $(WISHNAMEPREFIX)$(TK_VERSION)$(SUFX).exe -TKLIBNAME = $(PROJECT)$(TK_VERSION)$(SUFX).$(EXT) -TKSTUBLIBNAME = tkstub$(TK_VERSION).lib +TKLIBNAME8 = tk$(TK_VERSION)$(SUFX).$(EXT) +TKLIBNAME9 = tcl9tk$(TK_VERSION)$(SUFX).$(EXT) +!if $(TCL_MAJOR_VERSION) == 8 +TKLIBNAME = tk$(TK_VERSION)$(SUFX).$(EXT) TKIMPLIBNAME = tk$(TK_VERSION)$(SUFX).lib +!else +TKLIBNAME = tcl9tk$(TK_VERSION)$(SUFX).$(EXT) +TKIMPLIBNAME = tcl9tk$(TK_VERSION)$(SUFX).lib +!endif +TKSTUBLIBNAME = tkstub$(TK_VERSION).lib !if $(DOING_TK) WISH = $(OUT_DIR)\$(WISHNAME) -- cgit v0.12 From 122c6b2c017a836a95ce18c26dfda8ae065bc1b1 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 8 Apr 2021 15:04:11 +0000 Subject: Remove TclWinConvertError from internal stub table. No longer necessary, since it's in the external stub table now. --- generic/tclInt.decls | 7 ++++--- generic/tclIntPlatDecls.h | 26 +++++++++----------------- generic/tclStubInit.c | 14 +++++++------- 3 files changed, 20 insertions(+), 27 deletions(-) diff --git a/generic/tclInt.decls b/generic/tclInt.decls index e843b0e..452749e 100644 --- a/generic/tclInt.decls +++ b/generic/tclInt.decls @@ -602,9 +602,10 @@ interface tclIntPlat ################################ # Platform specific functions -declare 0 {unix win} { - void TclWinConvertError(unsigned errCode) -} +# Removed in 9.0 +#declare 0 {unix win} { +# void TclWinConvertError(unsigned errCode) +#} declare 1 {unix win} { int TclpCloseFile(TclFile file) } diff --git a/generic/tclIntPlatDecls.h b/generic/tclIntPlatDecls.h index 02ab5f4..3f6ee7ee 100644 --- a/generic/tclIntPlatDecls.h +++ b/generic/tclIntPlatDecls.h @@ -41,8 +41,7 @@ extern "C" { */ #if !defined(_WIN32) && !defined(__CYGWIN__) && !defined(MAC_OSX_TCL) /* UNIX */ -/* 0 */ -EXTERN void TclWinConvertError(unsigned errCode); +/* Slot 0 is reserved */ /* 1 */ EXTERN int TclpCloseFile(TclFile file); /* 2 */ @@ -108,8 +107,7 @@ EXTERN int TclUnixOpenTemporaryFile(Tcl_Obj *dirObj, Tcl_Obj *resultingNameObj); #endif /* UNIX */ #if defined(_WIN32) || defined(__CYGWIN__) /* WIN */ -/* 0 */ -EXTERN void TclWinConvertError(unsigned errCode); +/* Slot 0 is reserved */ /* 1 */ EXTERN int TclpCloseFile(TclFile file); /* 2 */ @@ -179,8 +177,7 @@ EXTERN int TclUnixOpenTemporaryFile(Tcl_Obj *dirObj, Tcl_Obj *resultingNameObj); #endif /* WIN */ #ifdef MAC_OSX_TCL /* MACOSX */ -/* 0 */ -EXTERN void TclWinConvertError(unsigned errCode); +/* Slot 0 is reserved */ /* 1 */ EXTERN int TclpCloseFile(TclFile file); /* 2 */ @@ -251,7 +248,7 @@ typedef struct TclIntPlatStubs { void *hooks; #if !defined(_WIN32) && !defined(__CYGWIN__) && !defined(MAC_OSX_TCL) /* UNIX */ - void (*tclWinConvertError) (unsigned errCode); /* 0 */ + void (*reserved0)(void); int (*tclpCloseFile) (TclFile file); /* 1 */ Tcl_Channel (*tclpCreateCommandChannel) (TclFile readFile, TclFile writeFile, TclFile errorFile, int numPids, Tcl_Pid *pidPtr); /* 2 */ int (*tclpCreatePipe) (TclFile *readPipe, TclFile *writePipe); /* 3 */ @@ -284,7 +281,7 @@ typedef struct TclIntPlatStubs { int (*tclUnixOpenTemporaryFile) (Tcl_Obj *dirObj, Tcl_Obj *basenameObj, Tcl_Obj *extensionObj, Tcl_Obj *resultingNameObj); /* 30 */ #endif /* UNIX */ #if defined(_WIN32) || defined(__CYGWIN__) /* WIN */ - void (*tclWinConvertError) (unsigned errCode); /* 0 */ + void (*reserved0)(void); int (*tclpCloseFile) (TclFile file); /* 1 */ Tcl_Channel (*tclpCreateCommandChannel) (TclFile readFile, TclFile writeFile, TclFile errorFile, int numPids, Tcl_Pid *pidPtr); /* 2 */ int (*tclpCreatePipe) (TclFile *readPipe, TclFile *writePipe); /* 3 */ @@ -317,7 +314,7 @@ typedef struct TclIntPlatStubs { int (*tclUnixOpenTemporaryFile) (Tcl_Obj *dirObj, Tcl_Obj *basenameObj, Tcl_Obj *extensionObj, Tcl_Obj *resultingNameObj); /* 30 */ #endif /* WIN */ #ifdef MAC_OSX_TCL /* MACOSX */ - void (*tclWinConvertError) (unsigned errCode); /* 0 */ + void (*reserved0)(void); int (*tclpCloseFile) (TclFile file); /* 1 */ Tcl_Channel (*tclpCreateCommandChannel) (TclFile readFile, TclFile writeFile, TclFile errorFile, int numPids, Tcl_Pid *pidPtr); /* 2 */ int (*tclpCreatePipe) (TclFile *readPipe, TclFile *writePipe); /* 3 */ @@ -364,8 +361,7 @@ extern const TclIntPlatStubs *tclIntPlatStubsPtr; */ #if !defined(_WIN32) && !defined(__CYGWIN__) && !defined(MAC_OSX_TCL) /* UNIX */ -#define TclWinConvertError \ - (tclIntPlatStubsPtr->tclWinConvertError) /* 0 */ +/* Slot 0 is reserved */ #define TclpCloseFile \ (tclIntPlatStubsPtr->tclpCloseFile) /* 1 */ #define TclpCreateCommandChannel \ @@ -419,8 +415,7 @@ extern const TclIntPlatStubs *tclIntPlatStubsPtr; (tclIntPlatStubsPtr->tclUnixOpenTemporaryFile) /* 30 */ #endif /* UNIX */ #if defined(_WIN32) || defined(__CYGWIN__) /* WIN */ -#define TclWinConvertError \ - (tclIntPlatStubsPtr->tclWinConvertError) /* 0 */ +/* Slot 0 is reserved */ #define TclpCloseFile \ (tclIntPlatStubsPtr->tclpCloseFile) /* 1 */ #define TclpCreateCommandChannel \ @@ -477,8 +472,7 @@ extern const TclIntPlatStubs *tclIntPlatStubsPtr; (tclIntPlatStubsPtr->tclUnixOpenTemporaryFile) /* 30 */ #endif /* WIN */ #ifdef MAC_OSX_TCL /* MACOSX */ -#define TclWinConvertError \ - (tclIntPlatStubsPtr->tclWinConvertError) /* 0 */ +/* Slot 0 is reserved */ #define TclpCloseFile \ (tclIntPlatStubsPtr->tclpCloseFile) /* 1 */ #define TclpCreateCommandChannel \ @@ -538,9 +532,7 @@ extern const TclIntPlatStubs *tclIntPlatStubsPtr; #undef TCL_STORAGE_CLASS #define TCL_STORAGE_CLASS DLLIMPORT -#undef TclWinConvertWSAError #define TclWinConvertWSAError Tcl_WinConvertError -#undef TclWinConvertError #define TclWinConvertError Tcl_WinConvertError #ifdef MAC_OSX_TCL /* not accessable on Win32/UNIX */ diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c index 773936e..9d8f12e 100644 --- a/generic/tclStubInit.c +++ b/generic/tclStubInit.c @@ -67,8 +67,10 @@ #undef Tcl_UtfToUniCharDString #undef Tcl_UtfToUniChar #define TclUnusedStubEntry 0 -#undef TclWinConvertError -#define TclWinConvertError 0 +#if !defined(_WIN32) && !defined(__CYGWIN__) +#undef Tcl_WinConvertError +#define Tcl_WinConvertError 0 +#endif #if TCL_UTF_MAX <= 3 @@ -270,8 +272,6 @@ static int utfNcasecmp(const char *s1, const char *s2, unsigned int n){ #else /* __CYGWIN__ */ # define TclWinGetTclInstance (void *(*)(void))(void *)TclpCreateProcess # define TclpGetPid (size_t(*)(Tcl_Pid))(void *)TclUnixWaitForFile -# undef TclWinConvertError -# define TclWinConvertError (void(*)(int))(void *)TclGetAndDetachPids # define TclWinFlushDirtyChannels 0 # define TclWinNoBackslash 0 # define TclWinAddProcess 0 @@ -566,7 +566,7 @@ static const TclIntPlatStubs tclIntPlatStubs = { TCL_STUB_MAGIC, 0, #if !defined(_WIN32) && !defined(__CYGWIN__) && !defined(MAC_OSX_TCL) /* UNIX */ - TclWinConvertError, /* 0 */ + 0, /* 0 */ TclpCloseFile, /* 1 */ TclpCreateCommandChannel, /* 2 */ TclpCreatePipe, /* 3 */ @@ -599,7 +599,7 @@ static const TclIntPlatStubs tclIntPlatStubs = { TclUnixOpenTemporaryFile, /* 30 */ #endif /* UNIX */ #if defined(_WIN32) || defined(__CYGWIN__) /* WIN */ - TclWinConvertError, /* 0 */ + 0, /* 0 */ TclpCloseFile, /* 1 */ TclpCreateCommandChannel, /* 2 */ TclpCreatePipe, /* 3 */ @@ -632,7 +632,7 @@ static const TclIntPlatStubs tclIntPlatStubs = { TclUnixOpenTemporaryFile, /* 30 */ #endif /* WIN */ #ifdef MAC_OSX_TCL /* MACOSX */ - TclWinConvertError, /* 0 */ + 0, /* 0 */ TclpCloseFile, /* 1 */ TclpCreateCommandChannel, /* 2 */ TclpCreatePipe, /* 3 */ -- cgit v0.12 From 8ba69750a3d5b3706fb03205f59a64e6c7539663 Mon Sep 17 00:00:00 2001 From: oehhar Date: Fri, 16 Apr 2021 11:48:02 +0000 Subject: TIP596: Document Tcl_MainEx, Tcl_MainExW, Tcl_GetMemoryInfo, Tcl_SetPreInitScript --- doc/Alloc.3 | 13 +++++++++++-- doc/Init.3 | 14 +++++++++++++- doc/Tcl_Main.3 | 14 +++++++++++++- 3 files changed, 37 insertions(+), 4 deletions(-) diff --git a/doc/Alloc.3 b/doc/Alloc.3 index 849f65e..c3c3f11 100644 --- a/doc/Alloc.3 +++ b/doc/Alloc.3 @@ -4,11 +4,11 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.TH Tcl_Alloc 3 7.5 Tcl "Tcl Library Procedures" +.TH Tcl_Alloc 3 9.0 Tcl "Tcl Library Procedures" .so man.macros .BS .SH NAME -Tcl_Alloc, Tcl_Free, Tcl_Realloc, Tcl_AttemptAlloc, Tcl_AttemptRealloc \- allocate or free heap memory +Tcl_Alloc, Tcl_Free, Tcl_Realloc, Tcl_AttemptAlloc, Tcl_AttemptRealloc, Tcl_GetMemoryInfo \- allocate or free heap memory .SH SYNOPSIS .nf \fB#include \fR @@ -27,12 +27,17 @@ void * .sp void * \fBTcl_AttemptRealloc\fR(\fIptr, size\fR) +.sp +void +\fBTcl_GetMemoryInfo\fR(\fIdsPtr\fR) .SH ARGUMENTS .AS char *size .AP "unsigned int" size in Size in bytes of the memory block to allocate. .AP char *ptr in Pointer to memory block to free or realloc. +.AP Tcl_DString *dsPtr in +Initialized DString pointer. .BE .SH DESCRIPTION @@ -69,5 +74,9 @@ the procedures \fBTcl_Alloc\fR, \fBTcl_Free\fR, \fBTcl_Realloc\fR, \fBTcl_AttemptAlloc\fR, and \fBTcl_AttempRealloc\fR are implemented as macros, redefined to be special debugging versions of these procedures. +\fBTcl_GetMemoryInfo\fR appends a list-of-lists of memory stats to the provided DString. +This procedure may be called when the TCL library is included within an embedded application. +The stubs table must be first initialized using one of \fBTcl_InitSubsystems\fR, \fBTcl_SetPanicProc\fR, \fBTcl_FindExecutable\fR or \fBTclZipfs_AppHook\fR. + .SH KEYWORDS alloc, allocation, free, malloc, memory, realloc, TCL_MEM_DEBUG diff --git a/doc/Init.3 b/doc/Init.3 index d9fc2e1..fa87892 100644 --- a/doc/Init.3 +++ b/doc/Init.3 @@ -2,7 +2,7 @@ '\" Copyright (c) 1998-2000 Scriptics Corporation. '\" All rights reserved. '\" -.TH Tcl_Init 3 8.0 Tcl "Tcl Library Procedures" +.TH Tcl_Init 3 9.0 Tcl "Tcl Library Procedures" .so man.macros .BS .SH NAME @@ -13,10 +13,15 @@ Tcl_Init \- find and source initialization script .sp int \fBTcl_Init\fR(\fIinterp\fR) +.sp +const char * +\fBTcl_SetPreInitScript\fR(\fIscriptPtr\fR) .SH ARGUMENTS .AS Tcl_Interp *interp .AP Tcl_Interp *interp in Interpreter to initialize. +.AP "const char" *scriptPtr in +Address of the initialization script. .BE .SH DESCRIPTION @@ -26,6 +31,13 @@ Interpreter to initialize. path. .PP \fBTcl_Init\fR is typically called from \fBTcl_AppInit\fR procedures. +.PP +\fBTcl_SetPreInitScript\fR registeres the pre-initialization script and returns the former (now replaced) script pointer. +A value of \fINULL\fR may be passed to not register any script. +The pre-initialization script is executed by \fBTcl_Init\fR before accessing the file system. +The purpose is to typically prepare a custom file system (like an embedded zip-file) to be activated before the search. + +When the TCL library is loaded within an embedded application, the stubs table must be first initialized using one of \fBTcl_InitSubsystems\fR, \fBTcl_SetPanicProc\fR, \fBTcl_FindExecutable\fR or \fBTclZipfs_AppHook\fR before \fBTcl_SetPreInitScript\fR may be called. .SH "SEE ALSO" Tcl_AppInit, Tcl_Main diff --git a/doc/Tcl_Main.3 b/doc/Tcl_Main.3 index 62ceeab..6ace8c9 100644 --- a/doc/Tcl_Main.3 +++ b/doc/Tcl_Main.3 @@ -6,7 +6,7 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.TH Tcl_Main 3 8.4 Tcl "Tcl Library Procedures" +.TH Tcl_Main 3 9.0 Tcl "Tcl Library Procedures" .so man.macros .BS .SH NAME @@ -17,6 +17,10 @@ Tcl_Main, Tcl_SetStartupScript, Tcl_GetStartupScript, Tcl_SetMainLoop \- main pr .sp \fBTcl_Main\fR(\fIargc, argv, appInitProc\fR) .sp +\fBTcl_MainEx\fR(\fIargc, charargv, appInitProc\fR) +.sp +\fBTcl_MainExW\fR(\fIargc, wideargv, appInitProc\fR) +.sp \fBTcl_SetStartupScript\fR(\fIpath, encoding\fR) .sp Tcl_Obj * @@ -30,6 +34,10 @@ Number of elements in \fIargv\fR. .AP char *argv[] in Array of strings containing command-line arguments. On Windows, when using -DUNICODE, the parameter type changes to wchar_t *. +.AP char *charargv[] in +As argv, but does not change type to wchar_t. +.AP char *wideargv[] in +As argv, but type is always wchar_t. .AP Tcl_AppInitProc *appInitProc in Address of an application-specific initialization procedure. The value for this argument is usually \fBTcl_AppInit\fR. @@ -191,6 +199,10 @@ procedure (if any) returns, \fBTcl_Main\fR will also evaluate the \fBexit\fR command. .PP \fBTcl_Main\fR can not be used in stub-enabled extensions. +.PP +When the TCL library is loaded within an embedded application, \fBTcl_MainEx\fR or \fBTcl_MainExW\fR may be used to call \fBTcl_Main\fR. +The difference between Tcl_MainEx and Tcl_MainExW is that the arguments are passed as characters or wide characters. +Remark that the stubs table must be first initialized using one of \fBTcl_InitSubsystems\fR, \fBTcl_SetPanicProc\fR, \fBTcl_FindExecutable\fR or \fBTclZipfs_AppHook\fR. .SH "SEE ALSO" tclsh(1), Tcl_GetStdChannel(3), Tcl_StandardChannels(3), Tcl_AppInit(3), exit(n), encoding(n) -- cgit v0.12 From 4106570aa941dd23622fb8107e28d9702902fbe1 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 28 Apr 2021 15:10:58 +0000 Subject: Fix documentation and remove unused function signature (leftover from earlier implementation) --- doc/Tcl_Main.3 | 9 +++++++++ generic/tcl.h | 2 -- 2 files changed, 9 insertions(+), 2 deletions(-) diff --git a/doc/Tcl_Main.3 b/doc/Tcl_Main.3 index b7b15a9..986ebbe 100644 --- a/doc/Tcl_Main.3 +++ b/doc/Tcl_Main.3 @@ -206,6 +206,15 @@ The difference between Tcl_MainEx and Tcl_MainExW is that the arguments are passed as characters or wide characters. When used in stub-enabled embedders, the stubs table must be first initialized using one of \fBTcl_InitSubsystems\fR, \fBTcl_SetPanicProc\fR, \fBTcl_FindExecutable\fR or \fBTclZipfs_AppHook\fR. +.SH "REFERENCE COUNT MANAGEMENT" +.PP +\fBTcl_SetStartupScript\fR takes a value (or NULL) for its \fIpath\fR +argument, and will increment the reference count of it. +.PP +\fBTcl_GetStartupScript\fR returns a value with reference count at least 1, or +NULL. It's \fIencodingPtr\fR is also used (if non-NULL) to return a value with +a reference count at least 1, or NULL. In both cases, the owner of the values +is the current thread. .SH "SEE ALSO" tclsh(1), Tcl_GetStdChannel(3), Tcl_StandardChannels(3), Tcl_AppInit(3), exit(n), encoding(n) diff --git a/generic/tcl.h b/generic/tcl.h index ec8a8ef..cfc1485 100644 --- a/generic/tcl.h +++ b/generic/tcl.h @@ -2148,8 +2148,6 @@ const char * Tcl_InitStubs(Tcl_Interp *interp, const char *version, const char * TclTomMathInitializeStubs(Tcl_Interp *interp, const char *version, int epoch, int revision); const char * TclInitStubTable(const char *version); -void TclStubMainEx(int index, int argc, const void *argv, - Tcl_AppInitProc *appInitProc, Tcl_Interp *interp); void * TclStubCall(void *arg); #if defined(_WIN32) TCL_NORETURN1 void Tcl_ConsolePanic(const char *format, ...); -- cgit v0.12 From 64524dd1b913c7b5c0c8a053d35321834e3137ed Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 30 Apr 2021 11:56:15 +0000 Subject: Keep win/rules.vc the same as in other branches --- win/rules.vc | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/win/rules.vc b/win/rules.vc index 35d8356..19f0dd8 100644 --- a/win/rules.vc +++ b/win/rules.vc @@ -1382,7 +1382,7 @@ OPTDEFINES = $(OPTDEFINES) /DTCL_NO_DEPRECATED # Note we do not define USE_TCL_STUBS even when building tk since some # test targets in tk do not use stubs !if !$(DOING_TCL) -USE_STUBS_DEFS = /DUSE_TCL_STUBS=1 /DUSE_TCLOO_STUBS=1 +USE_STUBS_DEFS = /DUSE_TCL_STUBS /DUSE_TCLOO_STUBS !if $(NEED_TK) USE_STUBS_DEFS = $(USE_STUBS_DEFS) /DUSE_TK_STUBS !endif -- cgit v0.12 From 06c51c6b90d0f09d4b7cebd7a4018e9ca5dacd9f Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 30 Apr 2021 13:39:35 +0000 Subject: More test-cases --- tests/encoding.test | 28 +++++++++++++++++++++++++++- 1 file changed, 27 insertions(+), 1 deletion(-) diff --git a/tests/encoding.test b/tests/encoding.test index 195fc25..5471e0b 100644 --- a/tests/encoding.test +++ b/tests/encoding.test @@ -600,7 +600,33 @@ test encoding-24.10 {Parse valid or invalid utf-8} { test encoding-24.11 {Parse valid or invalid utf-8} { string length [encoding convertfrom utf-8 "\xEF\xBF\xBF" -nothrow] } 1 - +test encoding-24.12 {Parse valid or invalid utf-8} { + string length [encoding convertfrom utf-8 "\xC0\x80" -stoponerror] +} 1 +test encoding-24.13 {Parse valid or invalid utf-8} -body { + encoding convertfrom utf-8 "\xC0\x81" -stoponerror +} -returnCodes 1 -result {unexpected byte at index 0: 'À' (\xC0)} +test encoding-24.14 {Parse valid or invalid utf-8} -body { + encoding convertfrom utf-8 "\xC1\xBF" -stoponerror +} -returnCodes 1 -result {unexpected byte at index 0: 'Á' (\xC1)} +test encoding-24.15 {Parse valid or invalid utf-8} { + string length [encoding convertfrom utf-8 "\xC2\x80" -stoponerror] +} 1 +test encoding-24.16 {Parse valid or invalid utf-8} -body { + encoding convertfrom utf-8 "Z\xE0\x80" -stoponerror +} -returnCodes 1 -result {unexpected byte at index 1: 'à' (\xE0)} +test encoding-24.17 {Parse valid or invalid utf-8} -constraints testbytestring -body { + encoding convertto utf-8 [testbytestring "Z\u4343\x80"] -stoponerror +} -returnCodes 1 -result {expected byte sequence but character 1 was '䍃€' (U+004343)} +test encoding-24.18 {Parse valid or invalid utf-8} -constraints testbytestring -body { + encoding convertto utf-8 [testbytestring "Z\xE0\x80"] -stoponerror +} -result "Z\xC3\xA0\xE2\x82\xAC" +test encoding-24.19 {Parse valid or invalid utf-8} -constraints testbytestring -body { + encoding convertto utf-8 [testbytestring "Z\xE0\x80xxxxxx"] -stoponerror +} -result "Z\xC3\xA0\xE2\x82\xACxxxxxx" +test encoding-24.20 {Parse valid or invalid utf-8} -constraints testbytestring -body { + encoding convertto utf-8 "ZX\uD800" -stoponerror +} -returnCodes 1 -match glob -result "unexpected character at index 2: '\uD800' (U+00D800)" file delete [file join [temporaryDirectory] iso2022.txt] # -- cgit v0.12 From aca352b62784bfe712dcdbe1fa2942399494f7ea Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 30 Apr 2021 14:29:47 +0000 Subject: Update tcl.dsp. Update documentation --- doc/FindExec.3 | 3 +++ doc/InitSubSyst.3 | 3 +++ doc/Panic.3 | 6 ++++-- doc/StaticLibrary.3 | 3 +-- doc/zipfs.3 | 10 +++++----- win/tcl.dsp | 10 +--------- 6 files changed, 17 insertions(+), 18 deletions(-) diff --git a/doc/FindExec.3 b/doc/FindExec.3 index 4b92695..3672546 100644 --- a/doc/FindExec.3 +++ b/doc/FindExec.3 @@ -35,6 +35,9 @@ Tcl. For example, it is needed on some platforms in the implementation of the \fBload\fR command. It is also returned by the \fBinfo nameofexecutable\fR command. .PP +The result of \fBTcl_InitSubsystems\fR is the full Tcl version (e.g., +\fB"9.0.0"\fR). +.PP On UNIX platforms this procedure is typically invoked as the very first thing in the application's main program; it must be passed \fIargv[0]\fR as its argument. It is important not to change the diff --git a/doc/InitSubSyst.3 b/doc/InitSubSyst.3 index 17d14b1..294861e 100644 --- a/doc/InitSubSyst.3 +++ b/doc/InitSubSyst.3 @@ -21,6 +21,9 @@ The \fBTcl_InitSubsystems\fR procedure initializes the Tcl library. This procedure is typically invoked as the very first thing in the application's main program. .PP +The result of \fBTcl_InitSubsystems\fR is the full Tcl version (e.g., +\fB"9.0.0"\fR). +.PP \fBTcl_InitSubsystems\fR is very similar in use to \fBTcl_FindExecutable\fR. It can be used when Tcl is used as utility library, no other encodings than utf-8, diff --git a/doc/Panic.3 b/doc/Panic.3 index cb4d3cb..659b2fe 100644 --- a/doc/Panic.3 +++ b/doc/Panic.3 @@ -79,12 +79,14 @@ making calls into the Tcl library, or into other libraries that may call the Tcl library, since the original call to \fBTcl_Panic\fR indicates the Tcl library is not in a state of reliable operation. .PP +The result of \fBTcl_SetPanicProc\fR is the full Tcl version (e.g., +\fB"9.0.0"\fR). +.PP 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 safely by stub-enabled extensions, so its -symbol is not included in the stub table. +\fBTcl_SetPanicProc\fR can not be used in stub-enabled extensions. .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 diff --git a/doc/StaticLibrary.3 b/doc/StaticLibrary.3 index 83a9a07..c5bd364 100644 --- a/doc/StaticLibrary.3 +++ b/doc/StaticLibrary.3 @@ -70,8 +70,7 @@ initialization procedure to be invoked. \fBTcl_StaticLibrary\fR was named \fBTcl_StaticPackage\fR in Tcl 8.6 and earlier, but the old name is deprecated now. .PP -\fBTcl_StaticLibrary\fR can not be safely used by stub-enabled extensions, -so its symbol is not included in the stub table. +\fBTcl_StaticLibrary\fR can not be used in stub-enabled extensions. .SH KEYWORDS initialization procedure, package, static linking .SH "SEE ALSO" diff --git a/doc/zipfs.3 b/doc/zipfs.3 index 2db6d67..f868915 100644 --- a/doc/zipfs.3 +++ b/doc/zipfs.3 @@ -87,11 +87,11 @@ it uses WCHAR instead of char. As a result, it requires your application to be compiled with the UNICODE preprocessor symbol defined (e.g., via the \fB-DUNICODE\fR compiler flag). .PP -The result of \fBTclZipfs_AppHook\fR is the full Tcl version string(e.g., -\fB"9.0.0"\fR). The function \fImay\fR modify the variables -pointed to by \fIargcPtr\fR and \fIargvPtr\fR to remove arguments; the -current implementation does not do so, but callers \fIshould not\fR assume -that this will be true in the future. +The result of \fBTclZipfs_AppHook\fR is the full Tcl version (e.g., +\fB"9.0.0"\fR). The function \fImay\fR modify +the variables pointed to by \fIargcPtr\fR and \fIargvPtr\fR to remove +arguments; the current implementation does not do so, but callers +\fIshould not\fR assume that this will be true in the future. .PP \fBTclzipfs_Mount\fR mounts the ZIP archive \fIzipname\fR on the mount point given in \fImountpoint\fR using the optional ZIP password \fIpassword\fR. diff --git a/win/tcl.dsp b/win/tcl.dsp index 3d79332..97c9000 100644 --- a/win/tcl.dsp +++ b/win/tcl.dsp @@ -1288,15 +1288,7 @@ SOURCE=..\generic\tclStubLib.c # End Source File # Begin Source File -SOURCE=..\generic\tclStubFindExecutable.c -# End Source File -# Begin Source File - -SOURCE=..\generic\tclStubInitSubsystems.c -# End Source File -# Begin Source File - -SOURCE=..\generic\tclStubSetPanicProc.c +SOURCE=..\generic\tclStubCall.c # End Source File # Begin Source File -- cgit v0.12 From 346e9e294098953ae67cf7e84b7078630d6ba2ae Mon Sep 17 00:00:00 2001 From: dgp Date: Mon, 3 May 2021 20:38:16 +0000 Subject: Bump to version 9.0a3 for release. --- README.md | 2 +- generic/tcl.h | 4 ++-- library/init.tcl | 2 +- unix/configure | 2 +- unix/configure.ac | 2 +- unix/tcl.spec | 2 +- win/configure | 2 +- win/configure.ac | 2 +- 8 files changed, 9 insertions(+), 9 deletions(-) diff --git a/README.md b/README.md index 875c7ba..a061c49 100644 --- a/README.md +++ b/README.md @@ -1,6 +1,6 @@ # README: Tcl -This is the **Tcl 9.0a2** source distribution. +This is the **Tcl 9.0a3** source distribution. You can get any source release of Tcl from [our distribution site](https://sourceforge.net/projects/tcl/files/Tcl/). diff --git a/generic/tcl.h b/generic/tcl.h index cfc1485..364e930 100644 --- a/generic/tcl.h +++ b/generic/tcl.h @@ -50,10 +50,10 @@ extern "C" { #define TCL_MAJOR_VERSION 9 #define TCL_MINOR_VERSION 0 #define TCL_RELEASE_LEVEL TCL_ALPHA_RELEASE -#define TCL_RELEASE_SERIAL 2 +#define TCL_RELEASE_SERIAL 3 #define TCL_VERSION "9.0" -#define TCL_PATCH_LEVEL "9.0a2" +#define TCL_PATCH_LEVEL "9.0a3" #if defined(RC_INVOKED) /* diff --git a/library/init.tcl b/library/init.tcl index ece3591..c01dc97 100644 --- a/library/init.tcl +++ b/library/init.tcl @@ -19,7 +19,7 @@ if {[info commands package] == ""} { error "version mismatch: library\nscripts expect Tcl version 7.5b1 or later but the loaded version is\nonly [info patchlevel]" } -package require -exact tcl 9.0a2 +package require -exact tcl 9.0a3 # Compute the auto path to use in this interpreter. # The values on the path come from several locations: diff --git a/unix/configure b/unix/configure index 7c6ff95..806579c 100755 --- a/unix/configure +++ b/unix/configure @@ -2683,7 +2683,7 @@ ac_compiler_gnu=$ac_cv_c_compiler_gnu TCL_VERSION=9.0 TCL_MAJOR_VERSION=9 TCL_MINOR_VERSION=0 -TCL_PATCH_LEVEL="a2" +TCL_PATCH_LEVEL="a3" VERSION=${TCL_VERSION} EXTRA_INSTALL_BINARIES=${EXTRA_INSTALL_BINARIES:-"@:"} diff --git a/unix/configure.ac b/unix/configure.ac index 685a335..d826c90 100644 --- a/unix/configure.ac +++ b/unix/configure.ac @@ -26,7 +26,7 @@ m4_ifdef([SC_USE_CONFIG_HEADERS], [ TCL_VERSION=9.0 TCL_MAJOR_VERSION=9 TCL_MINOR_VERSION=0 -TCL_PATCH_LEVEL="a2" +TCL_PATCH_LEVEL="a3" VERSION=${TCL_VERSION} EXTRA_INSTALL_BINARIES=${EXTRA_INSTALL_BINARIES:-"@:"} diff --git a/unix/tcl.spec b/unix/tcl.spec index b0a8016..3e7f3cd 100644 --- a/unix/tcl.spec +++ b/unix/tcl.spec @@ -4,7 +4,7 @@ Name: tcl Summary: Tcl scripting language development environment -Version: 9.0a2 +Version: 9.0a3 Release: 2 License: BSD Group: Development/Languages diff --git a/win/configure b/win/configure index e3f299f..f33d950 100755 --- a/win/configure +++ b/win/configure @@ -2401,7 +2401,7 @@ SHELL=/bin/sh TCL_VERSION=9.0 TCL_MAJOR_VERSION=9 TCL_MINOR_VERSION=0 -TCL_PATCH_LEVEL="a2" +TCL_PATCH_LEVEL="a3" VER=$TCL_MAJOR_VERSION$TCL_MINOR_VERSION TCL_DDE_VERSION=1.4 diff --git a/win/configure.ac b/win/configure.ac index b412ec2..f52df0b 100644 --- a/win/configure.ac +++ b/win/configure.ac @@ -15,7 +15,7 @@ SHELL=/bin/sh TCL_VERSION=9.0 TCL_MAJOR_VERSION=9 TCL_MINOR_VERSION=0 -TCL_PATCH_LEVEL="a2" +TCL_PATCH_LEVEL="a3" VER=$TCL_MAJOR_VERSION$TCL_MINOR_VERSION TCL_DDE_VERSION=1.4 -- cgit v0.12 From 9e781ffb02d3f384c1123ddcb6f96944cc4dc3ef Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 6 May 2021 11:35:39 +0000 Subject: Make ?-stoponerror|-nothrow? argument first in stead of last for encoding convertto/convertfrom --- generic/tclCmdAH.c | 16 +++++++-------- tests/cmdAH.test | 4 ++-- tests/encoding.test | 58 ++++++++++++++++++++++++++--------------------------- tests/safe.test | 8 ++++---- 4 files changed, 43 insertions(+), 43 deletions(-) diff --git a/generic/tclCmdAH.c b/generic/tclCmdAH.c index cb5ef01..682ba3f 100644 --- a/generic/tclCmdAH.c +++ b/generic/tclCmdAH.c @@ -557,12 +557,12 @@ EncodingConvertfromObjCmd( encoding = Tcl_GetEncoding(interp, NULL); data = objv[1]; } else if ((unsigned)(objc - 3) < 2) { - if (Tcl_GetEncodingFromObj(interp, objv[1], &encoding) != TCL_OK) { + if (Tcl_GetEncodingFromObj(interp, objv[objc - 2], &encoding) != TCL_OK) { return TCL_ERROR; } - data = objv[2]; + data = objv[objc - 1]; if (objc > 3) { - stopOnError = Tcl_GetString(objv[3]); + stopOnError = Tcl_GetString(objv[1]); if (!stopOnError[0]) { #if TCL_MAJOR_VERSION < 9 && !defined(TCL_NO_DEPRECATED) stopOnError = NULL; @@ -582,7 +582,7 @@ EncodingConvertfromObjCmd( } } else { encConvFromError: - Tcl_WrongNumArgs(interp, 1, objv, "?encoding? data ?-stoponerror|-nothrow?"); + Tcl_WrongNumArgs(interp, 1, objv, "?-stoponerror|-nothrow? ?encoding? data"); return TCL_ERROR; } @@ -661,12 +661,12 @@ EncodingConverttoObjCmd( encoding = Tcl_GetEncoding(interp, NULL); data = objv[1]; } else if ((unsigned)(objc - 3) < 2) { - if (Tcl_GetEncodingFromObj(interp, objv[1], &encoding) != TCL_OK) { + if (Tcl_GetEncodingFromObj(interp, objv[objc - 2], &encoding) != TCL_OK) { return TCL_ERROR; } - data = objv[2]; + data = objv[objc - 1]; if (objc > 3) { - stopOnError = Tcl_GetString(objv[3]); + stopOnError = Tcl_GetString(objv[1]); if (!stopOnError[0]) { #if TCL_MAJOR_VERSION < 9 && !defined(TCL_NO_DEPRECATED) stopOnError = NULL; @@ -686,7 +686,7 @@ EncodingConverttoObjCmd( } } else { encConvToError: - Tcl_WrongNumArgs(interp, 1, objv, "?encoding? data ?-stoponerror|-nothrow?"); + Tcl_WrongNumArgs(interp, 1, objv, "?-stoponerror|-nothrow? ?encoding? data"); return TCL_ERROR; } diff --git a/tests/cmdAH.test b/tests/cmdAH.test index e9973a9..5cf8fac 100644 --- a/tests/cmdAH.test +++ b/tests/cmdAH.test @@ -178,7 +178,7 @@ test cmdAH-4.2 {Tcl_EncodingObjCmd} -returnCodes error -body { } -result {unknown or ambiguous subcommand "foo": must be convertfrom, convertto, dirs, names, or system} test cmdAH-4.3 {Tcl_EncodingObjCmd} -returnCodes error -body { encoding convertto -} -result {wrong # args: should be "encoding convertto ?encoding? data ?-stoponerror|-nothrow?"} +} -result {wrong # args: should be "encoding convertto ?-stoponerror|-nothrow? ?encoding? data"} test cmdAH-4.4 {Tcl_EncodingObjCmd} -returnCodes error -body { encoding convertto foo bar } -result {unknown encoding "foo"} @@ -200,7 +200,7 @@ test cmdAH-4.6 {Tcl_EncodingObjCmd} -setup { } -result 8C test cmdAH-4.7 {Tcl_EncodingObjCmd} -returnCodes error -body { encoding convertfrom -} -result {wrong # args: should be "encoding convertfrom ?encoding? data ?-stoponerror|-nothrow?"} +} -result {wrong # args: should be "encoding convertfrom ?-stoponerror|-nothrow? ?encoding? data"} test cmdAH-4.8 {Tcl_EncodingObjCmd} -returnCodes error -body { encoding convertfrom foo bar } -result {unknown encoding "foo"} diff --git a/tests/encoding.test b/tests/encoding.test index 5471e0b..91fb1ec 100644 --- a/tests/encoding.test +++ b/tests/encoding.test @@ -291,7 +291,7 @@ test encoding-11.9 {encoding: extended Unicode UTF-16} { test encoding-12.1 {LoadTableEncoding: normal encoding} { set x [encoding convertto iso8859-3 Ġ] - append x [encoding convertto iso8859-3 Õ -nothrow] + append x [encoding convertto -nothrow iso8859-3 Õ] append x [encoding convertfrom iso8859-3 Õ] } "Õ?Ġ" test encoding-12.2 {LoadTableEncoding: single-byte encoding} { @@ -340,67 +340,67 @@ test encoding-15.5 {UtfToUtfProc emoji character input} { } "4 😂" test encoding-15.6 {UtfToUtfProc emoji character output} { set x \uDE02\uD83D\uDE02\uD83D - set y [encoding convertto utf-8 \uDE02\uD83D\uDE02\uD83D -nothrow] + set y [encoding convertto -nothrow utf-8 \uDE02\uD83D\uDE02\uD83D] binary scan $y H* z list [string length $y] $z } {10 efbfbdf09f9882efbfbd} test encoding-15.7 {UtfToUtfProc emoji character output} { set x \uDE02\uD83D\uD83D - set y [encoding convertto utf-8 \uDE02\uD83D\uD83D -nothrow] + set y [encoding convertto -nothrow utf-8 \uDE02\uD83D\uD83D] binary scan $y H* z list [string length $x] [string length $y] $z } {3 9 efbfbdefbfbdefbfbd} test encoding-15.8 {UtfToUtfProc emoji character output} { set x \uDE02\uD83Dé - set y [encoding convertto utf-8 \uDE02\uD83Dé -nothrow] + set y [encoding convertto -nothrow utf-8 \uDE02\uD83Dé] binary scan $y H* z list [string length $x] [string length $y] $z } {3 8 efbfbdefbfbdc3a9} test encoding-15.9 {UtfToUtfProc emoji character output} { set x \uDE02\uD83DX - set y [encoding convertto utf-8 \uDE02\uD83DX -nothrow] + set y [encoding convertto -nothrow utf-8 \uDE02\uD83DX] binary scan $y H* z list [string length $x] [string length $y] $z } {3 7 efbfbdefbfbd58} test encoding-15.10 {UtfToUtfProc high surrogate character output} { set x \uDE02é - set y [encoding convertto utf-8 \uDE02é -nothrow] + set y [encoding convertto -nothrow utf-8 \uDE02é] binary scan $y H* z list [string length $x] [string length $y] $z } {2 5 efbfbdc3a9} test encoding-15.11 {UtfToUtfProc low surrogate character output} { set x \uDA02é - set y [encoding convertto utf-8 \uDA02é -nothrow] + set y [encoding convertto -nothrow utf-8 \uDA02é] binary scan $y H* z list [string length $x] [string length $y] $z } {2 5 efbfbdc3a9} test encoding-15.12 {UtfToUtfProc high surrogate character output} { set x \uDE02Y - set y [encoding convertto utf-8 \uDE02Y -nothrow] + set y [encoding convertto -nothrow utf-8 \uDE02Y] binary scan $y H* z list [string length $x] [string length $y] $z } {2 4 efbfbd59} test encoding-15.13 {UtfToUtfProc low surrogate character output} { set x \uDA02Y - set y [encoding convertto utf-8 \uDA02Y -nothrow] + set y [encoding convertto -nothrow utf-8 \uDA02Y] binary scan $y H* z list [string length $x] [string length $y] $z } {2 4 efbfbd59} test encoding-15.14 {UtfToUtfProc high surrogate character output} { set x \uDE02 - set y [encoding convertto utf-8 \uDE02 -nothrow] + set y [encoding convertto -nothrow utf-8 \uDE02] binary scan $y H* z list [string length $x] [string length $y] $z } {1 3 efbfbd} test encoding-15.15 {UtfToUtfProc low surrogate character output} { set x \uDA02 - set y [encoding convertto utf-8 \uDA02 -nothrow] + set y [encoding convertto -nothrow utf-8 \uDA02] binary scan $y H* z list [string length $x] [string length $y] $z } {1 3 efbfbd} test encoding-15.16 {UtfToUtfProc: Invalid 4-byte UTF-8, see [ed29806ba]} { set x \xF0\xA0\xA1\xC2 - set y [encoding convertfrom utf-8 \xF0\xA0\xA1\xC2 -nothrow] + set y [encoding convertfrom -nothrow utf-8 \xF0\xA0\xA1\xC2] list [string length $x] $y } "4 \xF0\xA0\xA1\xC2" test encoding-15.17 {UtfToUtfProc emoji character output} { @@ -458,10 +458,10 @@ test encoding-17.2 {UtfToUcs2Proc} -body { encoding convertfrom utf-16 [encoding convertto ucs-2 "\U460DC"] } -result "\uFFFD" test encoding-17.3 {UtfToUtf16Proc} -body { - encoding convertto utf-16be "\uDCDC" -nothrow + encoding convertto -nothrow utf-16be "\uDCDC" } -result "\xFF\xFD" test encoding-17.4 {UtfToUtf16Proc} -body { - encoding convertto utf-16le "\uD8D8" -nothrow + encoding convertto -nothrow utf-16le "\uD8D8" } -result "\xFD\xFF" test encoding-18.1 {TableToUtfProc} { @@ -580,52 +580,52 @@ test encoding-24.4 {Parse valid or invalid utf-8} { string length [encoding convertfrom utf-8 "\xC0\x80"] } 1 test encoding-24.5 {Parse valid or invalid utf-8} { - string length [encoding convertfrom utf-8 "\xC0\x81" -nothrow] + string length [encoding convertfrom -nothrow utf-8 "\xC0\x81"] } 2 test encoding-24.6 {Parse valid or invalid utf-8} { - string length [encoding convertfrom utf-8 "\xC1\xBF" -nothrow] + string length [encoding convertfrom -nothrow utf-8 "\xC1\xBF"] } 2 test encoding-24.7 {Parse valid or invalid utf-8} { string length [encoding convertfrom utf-8 "\xC2\x80"] } 1 test encoding-24.8 {Parse valid or invalid utf-8} { - string length [encoding convertfrom utf-8 "\xE0\x80\x80" -nothrow] + string length [encoding convertfrom -nothrow utf-8 "\xE0\x80\x80"] } 3 test encoding-24.9 {Parse valid or invalid utf-8} { - string length [encoding convertfrom utf-8 "\xE0\x9F\xBF" -nothrow] + string length [encoding convertfrom -nothrow utf-8 "\xE0\x9F\xBF"] } 3 test encoding-24.10 {Parse valid or invalid utf-8} { string length [encoding convertfrom utf-8 "\xE0\xA0\x80"] } 1 test encoding-24.11 {Parse valid or invalid utf-8} { - string length [encoding convertfrom utf-8 "\xEF\xBF\xBF" -nothrow] + string length [encoding convertfrom -nothrow utf-8 "\xEF\xBF\xBF"] } 1 test encoding-24.12 {Parse valid or invalid utf-8} { - string length [encoding convertfrom utf-8 "\xC0\x80" -stoponerror] + string length [encoding convertfrom -stoponerror utf-8 "\xC0\x80"] } 1 test encoding-24.13 {Parse valid or invalid utf-8} -body { - encoding convertfrom utf-8 "\xC0\x81" -stoponerror + encoding convertfrom -stoponerror utf-8 "\xC0\x81" } -returnCodes 1 -result {unexpected byte at index 0: 'À' (\xC0)} test encoding-24.14 {Parse valid or invalid utf-8} -body { - encoding convertfrom utf-8 "\xC1\xBF" -stoponerror + encoding convertfrom -stoponerror utf-8 "\xC1\xBF" } -returnCodes 1 -result {unexpected byte at index 0: 'Á' (\xC1)} test encoding-24.15 {Parse valid or invalid utf-8} { - string length [encoding convertfrom utf-8 "\xC2\x80" -stoponerror] + string length [encoding convertfrom -stoponerror utf-8 "\xC2\x80"] } 1 test encoding-24.16 {Parse valid or invalid utf-8} -body { - encoding convertfrom utf-8 "Z\xE0\x80" -stoponerror + encoding convertfrom -stoponerror utf-8 "Z\xE0\x80" } -returnCodes 1 -result {unexpected byte at index 1: 'à' (\xE0)} test encoding-24.17 {Parse valid or invalid utf-8} -constraints testbytestring -body { - encoding convertto utf-8 [testbytestring "Z\u4343\x80"] -stoponerror + encoding convertto -stoponerror utf-8 [testbytestring "Z\u4343\x80"] } -returnCodes 1 -result {expected byte sequence but character 1 was '䍃€' (U+004343)} test encoding-24.18 {Parse valid or invalid utf-8} -constraints testbytestring -body { - encoding convertto utf-8 [testbytestring "Z\xE0\x80"] -stoponerror + encoding convertto -stoponerror utf-8 [testbytestring "Z\xE0\x80"] } -result "Z\xC3\xA0\xE2\x82\xAC" test encoding-24.19 {Parse valid or invalid utf-8} -constraints testbytestring -body { - encoding convertto utf-8 [testbytestring "Z\xE0\x80xxxxxx"] -stoponerror + encoding convertto -stoponerror utf-8 [testbytestring "Z\xE0\x80xxxxxx"] } -result "Z\xC3\xA0\xE2\x82\xACxxxxxx" test encoding-24.20 {Parse valid or invalid utf-8} -constraints testbytestring -body { - encoding convertto utf-8 "ZX\uD800" -stoponerror + encoding convertto -stoponerror utf-8 "ZX\uD800" } -returnCodes 1 -match glob -result "unexpected character at index 2: '\uD800' (U+00D800)" file delete [file join [temporaryDirectory] iso2022.txt] @@ -781,7 +781,7 @@ test encoding-28.0 {all encodings load} -body { set string hello foreach name [encoding names] { incr count - encoding convertto $name $string -nothrow + encoding convertto -nothrow $name $string # discard the cached internal representation of Tcl_Encoding # Unfortunately, without this, encoding 2-1 fails. diff --git a/tests/safe.test b/tests/safe.test index e7e427b..2ea32f5 100644 --- a/tests/safe.test +++ b/tests/safe.test @@ -1269,7 +1269,7 @@ test safe-11.7 {testing safe encoding} -setup { interp eval $i encoding convertfrom } -returnCodes error -cleanup { safe::interpDelete $i -} -result {wrong # args: should be "encoding convertfrom ?encoding? data ?-stoponerror|-nothrow?"} +} -result {wrong # args: should be "encoding convertfrom ?-stoponerror|-nothrow? ?encoding? data"} test safe-11.7.1 {testing safe encoding} -setup { set i [safe::interpCreate] } -body { @@ -1278,7 +1278,7 @@ test safe-11.7.1 {testing safe encoding} -setup { } -returnCodes ok -match glob -cleanup { unset -nocomplain m o safe::interpDelete $i -} -result {wrong # args: should be "encoding convertfrom ?encoding? data ?-stoponerror|-nothrow?" +} -result {wrong # args: should be "encoding convertfrom ?-stoponerror|-nothrow? ?encoding? data" while executing "encoding convertfrom" invoked from within @@ -1291,7 +1291,7 @@ test safe-11.8 {testing safe encoding} -setup { interp eval $i encoding convertto } -returnCodes error -cleanup { safe::interpDelete $i -} -result {wrong # args: should be "encoding convertto ?encoding? data ?-stoponerror|-nothrow?"} +} -result {wrong # args: should be "encoding convertto ?-stoponerror|-nothrow? ?encoding? data"} test safe-11.8.1 {testing safe encoding} -setup { set i [safe::interpCreate] } -body { @@ -1300,7 +1300,7 @@ test safe-11.8.1 {testing safe encoding} -setup { } -returnCodes ok -match glob -cleanup { unset -nocomplain m o safe::interpDelete $i -} -result {wrong # args: should be "encoding convertto ?encoding? data ?-stoponerror|-nothrow?" +} -result {wrong # args: should be "encoding convertto ?-stoponerror|-nothrow? ?encoding? data" while executing "encoding convertto" invoked from within -- cgit v0.12 From 82b2bfa1b8f90760f53b543c9dc7e4fa7c2e3510 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 6 May 2021 14:16:58 +0000 Subject: Remove character/byte value from error-message, only use hex here. --- generic/tclCmdAH.c | 4 ++-- tests/encoding.test | 8 ++++---- 2 files changed, 6 insertions(+), 6 deletions(-) diff --git a/generic/tclCmdAH.c b/generic/tclCmdAH.c index 682ba3f..1361f11 100644 --- a/generic/tclCmdAH.c +++ b/generic/tclCmdAH.c @@ -603,7 +603,7 @@ EncodingConvertfromObjCmd( char buf[TCL_INTEGER_SPACE]; sprintf(buf, "%" TCL_Z_MODIFIER "u", result); Tcl_SetObjResult(interp, Tcl_ObjPrintf("unexpected byte at index %" - TCL_Z_MODIFIER "u: '%c' (\\x%X)", result, UCHAR(bytesPtr[result]), UCHAR(bytesPtr[result]))); + TCL_Z_MODIFIER "u: '\\x%X'", result, UCHAR(bytesPtr[result]))); Tcl_SetErrorCode(interp, "TCL", "ENCODING", "STOPONERROR", buf, NULL); Tcl_DStringFree(&ds); @@ -704,7 +704,7 @@ EncodingConverttoObjCmd( TclUtfToUCS4(&stringPtr[result], &ucs4); sprintf(buf, "%" TCL_Z_MODIFIER "u", result); Tcl_SetObjResult(interp, Tcl_ObjPrintf("unexpected character at index %" - TCL_Z_MODIFIER "u: '%c' (U+%06X)", pos, ucs4, ucs4)); + TCL_Z_MODIFIER "u: 'U+%06X'", pos, ucs4)); Tcl_SetErrorCode(interp, "TCL", "ENCODING", "STOPONERROR", buf, NULL); Tcl_DStringFree(&ds); diff --git a/tests/encoding.test b/tests/encoding.test index 91fb1ec..355c2ec 100644 --- a/tests/encoding.test +++ b/tests/encoding.test @@ -605,16 +605,16 @@ test encoding-24.12 {Parse valid or invalid utf-8} { } 1 test encoding-24.13 {Parse valid or invalid utf-8} -body { encoding convertfrom -stoponerror utf-8 "\xC0\x81" -} -returnCodes 1 -result {unexpected byte at index 0: 'À' (\xC0)} +} -returnCodes 1 -result {unexpected byte at index 0: '\xC0'} test encoding-24.14 {Parse valid or invalid utf-8} -body { encoding convertfrom -stoponerror utf-8 "\xC1\xBF" -} -returnCodes 1 -result {unexpected byte at index 0: 'Á' (\xC1)} +} -returnCodes 1 -result {unexpected byte at index 0: '\xC1'} test encoding-24.15 {Parse valid or invalid utf-8} { string length [encoding convertfrom -stoponerror utf-8 "\xC2\x80"] } 1 test encoding-24.16 {Parse valid or invalid utf-8} -body { encoding convertfrom -stoponerror utf-8 "Z\xE0\x80" -} -returnCodes 1 -result {unexpected byte at index 1: 'à' (\xE0)} +} -returnCodes 1 -result {unexpected byte at index 1: '\xE0'} test encoding-24.17 {Parse valid or invalid utf-8} -constraints testbytestring -body { encoding convertto -stoponerror utf-8 [testbytestring "Z\u4343\x80"] } -returnCodes 1 -result {expected byte sequence but character 1 was '䍃€' (U+004343)} @@ -626,7 +626,7 @@ test encoding-24.19 {Parse valid or invalid utf-8} -constraints testbytestring - } -result "Z\xC3\xA0\xE2\x82\xACxxxxxx" test encoding-24.20 {Parse valid or invalid utf-8} -constraints testbytestring -body { encoding convertto -stoponerror utf-8 "ZX\uD800" -} -returnCodes 1 -match glob -result "unexpected character at index 2: '\uD800' (U+00D800)" +} -returnCodes 1 -match glob -result "unexpected character at index 2: 'U+00D800'" file delete [file join [temporaryDirectory] iso2022.txt] # -- cgit v0.12 From 99994365ea8c04611e93f3108f4a7d8d4e1ca49f Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 7 May 2021 09:50:13 +0000 Subject: Parse simplifications and better errormessage. Not 100% correct yet --- generic/tclCmdAH.c | 36 +++++++++++++----------------------- tests/encoding.test | 6 +++--- 2 files changed, 16 insertions(+), 26 deletions(-) diff --git a/generic/tclCmdAH.c b/generic/tclCmdAH.c index 1361f11..9cd8c12 100644 --- a/generic/tclCmdAH.c +++ b/generic/tclCmdAH.c @@ -550,24 +550,24 @@ EncodingConvertfromObjCmd( Tcl_Encoding encoding; /* Encoding to use */ int length; /* Length of the byte array being converted */ const char *bytesPtr; /* Pointer to the first byte of the array */ +#if TCL_MAJOR_VERSION > 8 || defined(TCL_NO_DEPRECATED) + const char *stopOnError = ""; +#else const char *stopOnError = NULL; +#endif size_t result; if (objc == 2) { encoding = Tcl_GetEncoding(interp, NULL); data = objv[1]; - } else if ((unsigned)(objc - 3) < 2) { + } else if ((unsigned)(objc - 2) < 3) { if (Tcl_GetEncodingFromObj(interp, objv[objc - 2], &encoding) != TCL_OK) { return TCL_ERROR; } data = objv[objc - 1]; if (objc > 3) { stopOnError = Tcl_GetString(objv[1]); - if (!stopOnError[0]) { -#if TCL_MAJOR_VERSION < 9 && !defined(TCL_NO_DEPRECATED) - stopOnError = NULL; -#endif - } else if (stopOnError[0] == '-' && stopOnError[1] == 'n' + if (stopOnError[0] == '-' && stopOnError[1] == 'n' && !strncmp(stopOnError, "-nothrow", strlen(stopOnError))) { stopOnError = NULL; } else if (stopOnError[0] == '-' && stopOnError[1] == 's' @@ -575,10 +575,6 @@ EncodingConvertfromObjCmd( } else { goto encConvFromError; } -#if TCL_MAJOR_VERSION > 8 || defined(TCL_NO_DEPRECATED) - } else { - stopOnError = ""; -#endif } } else { encConvFromError: @@ -602,7 +598,7 @@ EncodingConvertfromObjCmd( if (stopOnError && (result != (size_t)-1)) { char buf[TCL_INTEGER_SPACE]; sprintf(buf, "%" TCL_Z_MODIFIER "u", result); - Tcl_SetObjResult(interp, Tcl_ObjPrintf("unexpected byte at index %" + Tcl_SetObjResult(interp, Tcl_ObjPrintf("unexpected byte sequence starting at index %" TCL_Z_MODIFIER "u: '\\x%X'", result, UCHAR(bytesPtr[result]))); Tcl_SetErrorCode(interp, "TCL", "ENCODING", "STOPONERROR", buf, NULL); @@ -653,25 +649,23 @@ EncodingConverttoObjCmd( int length; /* Length of the string being converted */ const char *stringPtr; /* Pointer to the first byte of the string */ size_t result; +#if TCL_MAJOR_VERSION > 8 || defined(TCL_NO_DEPRECATED) + const char *stopOnError = ""; +#else const char *stopOnError = NULL; - - /* TODO - ADJUST OBJ INDICES WHEN ENSEMBLIFYING THIS */ +#endif if (objc == 2) { encoding = Tcl_GetEncoding(interp, NULL); data = objv[1]; - } else if ((unsigned)(objc - 3) < 2) { + } else if ((unsigned)(objc - 2) < 3) { if (Tcl_GetEncodingFromObj(interp, objv[objc - 2], &encoding) != TCL_OK) { return TCL_ERROR; } data = objv[objc - 1]; if (objc > 3) { stopOnError = Tcl_GetString(objv[1]); - if (!stopOnError[0]) { -#if TCL_MAJOR_VERSION < 9 && !defined(TCL_NO_DEPRECATED) - stopOnError = NULL; -#endif - } else if (stopOnError[0] == '-' && stopOnError[1] == 'n' + if (stopOnError[0] == '-' && stopOnError[1] == 'n' && !strncmp(stopOnError, "-nothrow", strlen(stopOnError))) { stopOnError = NULL; } else if (stopOnError[0] == '-' && stopOnError[1] == 's' @@ -679,10 +673,6 @@ EncodingConverttoObjCmd( } else { goto encConvToError; } -#if TCL_MAJOR_VERSION > 8 || defined(TCL_NO_DEPRECATED) - } else { - stopOnError = ""; -#endif } } else { encConvToError: diff --git a/tests/encoding.test b/tests/encoding.test index 355c2ec..d30ef60 100644 --- a/tests/encoding.test +++ b/tests/encoding.test @@ -605,16 +605,16 @@ test encoding-24.12 {Parse valid or invalid utf-8} { } 1 test encoding-24.13 {Parse valid or invalid utf-8} -body { encoding convertfrom -stoponerror utf-8 "\xC0\x81" -} -returnCodes 1 -result {unexpected byte at index 0: '\xC0'} +} -returnCodes 1 -result {unexpected byte sequence starting at index 0: '\xC0'} test encoding-24.14 {Parse valid or invalid utf-8} -body { encoding convertfrom -stoponerror utf-8 "\xC1\xBF" -} -returnCodes 1 -result {unexpected byte at index 0: '\xC1'} +} -returnCodes 1 -result {unexpected byte sequence starting at index 0: '\xC1'} test encoding-24.15 {Parse valid or invalid utf-8} { string length [encoding convertfrom -stoponerror utf-8 "\xC2\x80"] } 1 test encoding-24.16 {Parse valid or invalid utf-8} -body { encoding convertfrom -stoponerror utf-8 "Z\xE0\x80" -} -returnCodes 1 -result {unexpected byte at index 1: '\xE0'} +} -returnCodes 1 -result {unexpected byte sequence starting at index 1: '\xE0'} test encoding-24.17 {Parse valid or invalid utf-8} -constraints testbytestring -body { encoding convertto -stoponerror utf-8 [testbytestring "Z\u4343\x80"] } -returnCodes 1 -result {expected byte sequence but character 1 was '䍃€' (U+004343)} -- cgit v0.12 From c1591561bfc41b9b4bd3f4bf09929d419325c9ef Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 7 May 2021 13:44:53 +0000 Subject: doc fix --- doc/Encoding.3 | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/doc/Encoding.3 b/doc/Encoding.3 index d853977..73ad65d 100644 --- a/doc/Encoding.3 +++ b/doc/Encoding.3 @@ -25,13 +25,13 @@ int char * \fBTcl_ExternalToUtfDString\fR(\fIencoding, src, srcLen, dstPtr\fR) .sp -char * +size_t \fBTcl_ExternalToUtfDStringEx\fR(\fIencoding, src, srcLen, flags, dstPtr\fR) .sp char * \fBTcl_UtfToExternalDString\fR(\fIencoding, src, srcLen, dstPtr\fR) .sp -char * +size_t \fBTcl_UtfToExternalDStringEx\fR(\fIencoding, src, srcLen, flags, dstPtr\fR) .sp int @@ -261,8 +261,8 @@ a pointer to the value stored in the DString. .PP \fBTcl_UtfToExternalDStringEx\fR is the same as \fBTcl_UtfToExternalDString\fR, but it has an additional flags parameter. The return value is the index of -the first byte in the input string causing a conversion error. -Or (size_t)-1 if all is OK. +the first byte of an utf-8 byte-sequence in the input string causing a +conversion error. Or (size_t)-1 if all is OK. .PP \fBTcl_UtfToExternal\fR converts a source buffer \fIsrc\fR from UTF-8 into the specified \fIencoding\fR. Up to \fIsrcLen\fR bytes are converted from -- cgit v0.12 From c19b90133a56c0adc06f764732d80720e60747a3 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 7 May 2021 13:55:14 +0000 Subject: Double definition of TCL_ENCODING_MODIFIED and another doc fix --- doc/string.n | 2 +- generic/tclEncoding.c | 1 - 2 files changed, 1 insertion(+), 2 deletions(-) diff --git a/doc/string.n b/doc/string.n index 6a10da8..f3d7616 100644 --- a/doc/string.n +++ b/doc/string.n @@ -419,7 +419,7 @@ command to convert a string to a known encoding (e.g. "utf-8" or "cesu-8") and then apply \fBstring length\fR to that. .PP .CS -\fBstring length\fR [encoding convertto wtf-8 $theString] +\fBstring length\fR [encoding convertto utf-8 $theString] .CE .RE .TP diff --git a/generic/tclEncoding.c b/generic/tclEncoding.c index a53261e..17b00d6 100644 --- a/generic/tclEncoding.c +++ b/generic/tclEncoding.c @@ -512,7 +512,6 @@ FillEncodingFileMap(void) /* Since TCL_ENCODING_MODIFIED is only used for utf-8/cesu-8 and * TCL_ENCODING_LE is only used for utf-16/ucs-2. re-use the same value */ -#define TCL_ENCODING_MODIFIED 0x20 /* Converting NULL bytes to 0xC0 0x80 */ #define TCL_ENCODING_LE TCL_ENCODING_MODIFIED /* Little-endian encoding */ #define TCL_ENCODING_UTF 0x200 /* For UTF-8 encoding, allow 4-byte output sequences */ -- cgit v0.12 From 95cd48673472309ca5a790f3d26e4a137c010a6b Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 14 May 2021 10:52:53 +0000 Subject: One left-over wtf-8 mentioning, which is no longer part of TIP #597 --- generic/tcl.h | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/generic/tcl.h b/generic/tcl.h index a5d0106..759adc9 100644 --- a/generic/tcl.h +++ b/generic/tcl.h @@ -2075,7 +2075,7 @@ typedef struct Tcl_EncodingType { * produced is controlled only by other limiting * factors. * TCL_ENCODING_MODIFIED - Convert NULL bytes to \xC0\x80 in stead of - * 0x00. Only valid for "utf-8", "wtf-8 and "cesu-8". + * 0x00. Only valid for "utf-8" and "cesu-8". * This flag is implicit for external -> internal conversions, * optional for internal -> external conversions. * TCL_ENCODING_NO_THROW - If set, the converter -- cgit v0.12 From b02cd57334865909a8622d486b47daf7439aee6c Mon Sep 17 00:00:00 2001 From: pooryorick Date: Sun, 16 May 2021 19:34:09 +0000 Subject: Replace ckfree with Tcl_Free. --- generic/tclZipfs.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/generic/tclZipfs.c b/generic/tclZipfs.c index d81f5c0..4d619f0 100644 --- a/generic/tclZipfs.c +++ b/generic/tclZipfs.c @@ -5753,7 +5753,7 @@ ZipfsExitHandler( static void ZipfsFinalize(void) { Tcl_DeleteHashTable(&ZipFS.fileHash); - ckfree(ZipFS.fallbackEntryEncoding); + Tcl_Free(ZipFS.fallbackEntryEncoding); ZipFS.initialized = -1; } -- cgit v0.12 From a3bdb5abeea38e4eca31dd4691e26ea25d695d31 Mon Sep 17 00:00:00 2001 From: pooryorick Date: Mon, 17 May 2021 20:46:36 +0000 Subject: Reinstate one line lost in last merge. --- generic/tclBasic.c | 1 + 1 file changed, 1 insertion(+) diff --git a/generic/tclBasic.c b/generic/tclBasic.c index e96b581..cafec69 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -1799,6 +1799,7 @@ DeleteInterpProc( if (dPtr->proc != NULL) { dPtr->proc(dPtr->clientData, interp); } + Tcl_DeleteHashEntry(hPtr); Tcl_Free(dPtr); } Tcl_DeleteHashTable(hTablePtr); -- cgit v0.12 From 9cea1455ec0d8bfae73216639af0a8b78f93967c Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 18 May 2021 13:03:31 +0000 Subject: Make pkgua package thread-safe --- unix/dltest/pkgua.c | 53 +++++++++++++++++++++++++++++++++-------------------- 1 file changed, 33 insertions(+), 20 deletions(-) diff --git a/unix/dltest/pkgua.c b/unix/dltest/pkgua.c index 0ab3e23..a822541 100644 --- a/unix/dltest/pkgua.c +++ b/unix/dltest/pkgua.c @@ -21,6 +21,7 @@ static int PkguaEqObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); static int PkguaQuoteObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); +static void CommandDeleted(ClientData clientData); /* * In the following hash table we are going to store a struct that holds all @@ -30,23 +31,32 @@ static int PkguaQuoteObjCmd(ClientData clientData, * need to keep the various command tokens we have registered, as they are the * only safe way to unregister our registered commands, even if they have been * renamed. - * - * Note that this code is utterly single-threaded. */ -static Tcl_HashTable interpTokenMap; -static int interpTokenMapInitialised = 0; +typedef struct ThreadSpecificData { + int interpTokenMapInitialised; + Tcl_HashTable interpTokenMap; +} ThreadSpecificData; +static Tcl_ThreadDataKey dataKey; #define MAX_REGISTERED_COMMANDS 2 +static void +CommandDeleted(ClientData clientData) +{ + Tcl_Command *cmdToken = (Tcl_Command *)clientData; + *cmdToken = NULL; +} static void PkguaInitTokensHashTable(void) { - if (interpTokenMapInitialised) { + ThreadSpecificData *tsdPtr = (ThreadSpecificData *)Tcl_GetThreadData((&dataKey), sizeof(ThreadSpecificData)); + + if (tsdPtr->interpTokenMapInitialised) { return; } - Tcl_InitHashTable(&interpTokenMap, TCL_ONE_WORD_KEYS); - interpTokenMapInitialised = 1; + Tcl_InitHashTable(&tsdPtr->interpTokenMap, TCL_ONE_WORD_KEYS); + tsdPtr->interpTokenMapInitialised = 1; } static void @@ -54,12 +64,13 @@ PkguaFreeTokensHashTable(void) { Tcl_HashSearch search; Tcl_HashEntry *entryPtr; + ThreadSpecificData *tsdPtr = (ThreadSpecificData *)Tcl_GetThreadData((&dataKey), sizeof(ThreadSpecificData)); - for (entryPtr = Tcl_FirstHashEntry(&interpTokenMap, &search); + for (entryPtr = Tcl_FirstHashEntry(&tsdPtr->interpTokenMap, &search); entryPtr != NULL; entryPtr = Tcl_NextHashEntry(&search)) { Tcl_Free((char *) Tcl_GetHashValue(entryPtr)); } - interpTokenMapInitialised = 0; + tsdPtr->interpTokenMapInitialised = 0; } static Tcl_Command * @@ -68,13 +79,14 @@ PkguaInterpToTokens( { int newEntry; Tcl_Command *cmdTokens; + ThreadSpecificData *tsdPtr = (ThreadSpecificData *)Tcl_GetThreadData((&dataKey), sizeof(ThreadSpecificData)); Tcl_HashEntry *entryPtr = - Tcl_CreateHashEntry(&interpTokenMap, interp, &newEntry); + Tcl_CreateHashEntry(&tsdPtr->interpTokenMap, (char *) interp, &newEntry); if (newEntry) { cmdTokens = (Tcl_Command *) - Tcl_Alloc(sizeof(Tcl_Command) * (MAX_REGISTERED_COMMANDS+1)); - for (newEntry=0 ; newEntryinterpTokenMap, (char *) interp); if (entryPtr) { Tcl_Free((char *) Tcl_GetHashValue(entryPtr)); @@ -199,7 +212,7 @@ Pkgua_Init( Tcl_Interp *interp) /* Interpreter in which the package is to be * made available. */ { - int code, cmdIndex = 0; + int code; Tcl_Command *cmdTokens; if (Tcl_InitStubs(interp, "8.5-", 0) == NULL) { @@ -207,7 +220,7 @@ Pkgua_Init( } /* - * Initialise our Hash table, where we store the registered command tokens + * Initialize our Hash table, where we store the registered command tokens * for each interpreter. */ @@ -221,12 +234,12 @@ Pkgua_Init( Tcl_SetVar2(interp, "::pkgua_loaded", NULL, ".", TCL_APPEND_VALUE); cmdTokens = PkguaInterpToTokens(interp); - cmdTokens[cmdIndex++] = - Tcl_CreateObjCommand(interp, "pkgua_eq", PkguaEqObjCmd, NULL, - NULL); - cmdTokens[cmdIndex++] = + cmdTokens[0] = + Tcl_CreateObjCommand(interp, "pkgua_eq", PkguaEqObjCmd, &cmdTokens[0], + CommandDeleted); + cmdTokens[1] = Tcl_CreateObjCommand(interp, "pkgua_quote", PkguaQuoteObjCmd, - NULL, NULL); + &cmdTokens[1], CommandDeleted); return TCL_OK; } -- cgit v0.12 From b9bd6ffbf8851cfc23fefe5653355b201d12cf83 Mon Sep 17 00:00:00 2001 From: oehhar Date: Wed, 26 May 2021 06:44:40 +0000 Subject: TIP601 encoding stoponerror: document Tcl_ExternalToUtfDStringEx and Tcl_ExternalToUtfDStringEx --- generic/tclEncoding.c | 64 +++++++++++++++++++++++++++++++++++++++++++++++++-- 1 file changed, 62 insertions(+), 2 deletions(-) diff --git a/generic/tclEncoding.c b/generic/tclEncoding.c index 17b00d6..1e56c12 100644 --- a/generic/tclEncoding.c +++ b/generic/tclEncoding.c @@ -1093,7 +1093,7 @@ Tcl_CreateEncoding( /* *------------------------------------------------------------------------- * - * Tcl_ExternalToUtfDString/Tcl_ExternalToUtfDStringEx -- + * Tcl_ExternalToUtfDString -- * * Convert a source buffer from the specified encoding into UTF-8. If any * of the bytes in the source buffer are invalid or cannot be represented @@ -1125,6 +1125,35 @@ Tcl_ExternalToUtfDString( return Tcl_DStringValue(dstPtr); } + +/* + *------------------------------------------------------------------------- + * + * Tcl_ExternalToUtfDStringEx -- + * + * Convert a source buffer from the specified encoding into UTF-8. +* The parameter flags controls the behavior, if any of the bytes in + * the source buffer are invalid or cannot be represented in utf-8. + * Possible flags values: + * TCLENCODINGSTOPONERROR: don't replace invalid characters/bytes but + * return the first error position (Default in Tcl 9.0). + * TCLENCODINGNO_THROW: replace invalid characters/bytes by a default + * fallback character. Always return -1 (Default in Tcl 8.7). + * TCLENCODINGMODIFIED: convert NULL bytes to \xC0\x80 in stead of 0x00. + * Only valid for "utf-8" and "cesu-8". This flag may be used together + * with the other flags. + * + * Results: + * The converted bytes are stored in the DString, which is then NULL + * terminated in an encoding-specific manner. The return value is + * the error position in the source string or -1 if no conversion error + * is reported. + * + * Side effects: + * None. + * + *------------------------------------------------------------------------- + */ size_t Tcl_ExternalToUtfDStringEx( @@ -1303,7 +1332,7 @@ Tcl_ExternalToUtf( /* *------------------------------------------------------------------------- * - * Tcl_UtfToExternalDString/Tcl_UtfToExternalDStringEx -- + * Tcl_UtfToExternalDString -- * * Convert a source buffer from UTF-8 to the specified encoding. If any * of the bytes in the source buffer are invalid or cannot be represented @@ -1335,6 +1364,37 @@ Tcl_UtfToExternalDString( return Tcl_DStringValue(dstPtr); } + +/* + *------------------------------------------------------------------------- + * + * Tcl_UtfToExternalDStringEx -- + * + * Convert a source buffer from UTF-8 to the specified encoding. + * The parameter flags controls the behavior, if any of the bytes in + * the source buffer are invalid or cannot be represented in the + * target encoding. + * Possible flags values: + * TCLENCODINGSTOPONERROR: don't replace invalid characters/bytes but + * return the first error position (Default in Tcl 9.0). + * TCLENCODINGNO_THROW: replace invalid characters/bytes by a default + * fallback character. Always return -1 (Default in Tcl 8.7). + * TCLENCODINGMODIFIED: convert NULL bytes to \xC0\x80 in stead of 0x00. + * Only valid for "utf-8" and "cesu-8". This flag may be used together + * with the other flags. + * + * Results: + * The converted bytes are stored in the DString, which is then NULL + * terminated in an encoding-specific manner. The return value is + * the error position in the source string or -1 if no conversion error + * is reported. + * + * Side effects: + * None. + * + *------------------------------------------------------------------------- + */ + size_t Tcl_UtfToExternalDStringEx( Tcl_Encoding encoding, /* The encoding for the converted string, or -- cgit v0.12 From 5ab98c9b65c66ac15cafc95755202ac31b237450 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 26 May 2021 08:36:28 +0000 Subject: Add underscores in flag names --- generic/tclEncoding.c | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/generic/tclEncoding.c b/generic/tclEncoding.c index 1e56c12..7a9f0b7 100644 --- a/generic/tclEncoding.c +++ b/generic/tclEncoding.c @@ -1135,11 +1135,11 @@ Tcl_ExternalToUtfDString( * The parameter flags controls the behavior, if any of the bytes in * the source buffer are invalid or cannot be represented in utf-8. * Possible flags values: - * TCLENCODINGSTOPONERROR: don't replace invalid characters/bytes but + * TCL_ENCODING_STOPONERROR: don't replace invalid characters/bytes but * return the first error position (Default in Tcl 9.0). - * TCLENCODINGNO_THROW: replace invalid characters/bytes by a default + * TCL_ENCODING_NO_THROW: replace invalid characters/bytes by a default * fallback character. Always return -1 (Default in Tcl 8.7). - * TCLENCODINGMODIFIED: convert NULL bytes to \xC0\x80 in stead of 0x00. + * TCL_ENCODING_MODIFIED: convert NULL bytes to \xC0\x80 in stead of 0x00. * Only valid for "utf-8" and "cesu-8". This flag may be used together * with the other flags. * @@ -1375,11 +1375,11 @@ Tcl_UtfToExternalDString( * the source buffer are invalid or cannot be represented in the * target encoding. * Possible flags values: - * TCLENCODINGSTOPONERROR: don't replace invalid characters/bytes but + * TCL_ENCODING_STOPONERROR: don't replace invalid characters/bytes but * return the first error position (Default in Tcl 9.0). - * TCLENCODINGNO_THROW: replace invalid characters/bytes by a default + * TCL_ENCODING_NO_THROW: replace invalid characters/bytes by a default * fallback character. Always return -1 (Default in Tcl 8.7). - * TCLENCODINGMODIFIED: convert NULL bytes to \xC0\x80 in stead of 0x00. + * TCL_ENCODING_MODIFIED: convert NULL bytes to \xC0\x80 in stead of 0x00. * Only valid for "utf-8" and "cesu-8". This flag may be used together * with the other flags. * -- cgit v0.12 From 588e5a48cb262a4fa3d60698be3f1d94434dfcf1 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 26 May 2021 14:04:00 +0000 Subject: Handle the situation when there is "-nothrow" or "-stoponerror" but without providing encoding --- generic/tclCmdAH.c | 77 +++++++++++++++++++++++++++++++---------------------- tests/encoding.test | 6 +++++ 2 files changed, 51 insertions(+), 32 deletions(-) diff --git a/generic/tclCmdAH.c b/generic/tclCmdAH.c index 0f9aa27..6549648 100644 --- a/generic/tclCmdAH.c +++ b/generic/tclCmdAH.c @@ -561,21 +561,26 @@ EncodingConvertfromObjCmd( encoding = Tcl_GetEncoding(interp, NULL); data = objv[1]; } else if ((unsigned)(objc - 2) < 3) { - if (Tcl_GetEncodingFromObj(interp, objv[objc - 2], &encoding) != TCL_OK) { - return TCL_ERROR; - } data = objv[objc - 1]; - if (objc > 3) { - bytesPtr = Tcl_GetString(objv[1]); - if (bytesPtr[0] == '-' && bytesPtr[1] == 'n' - && !strncmp(bytesPtr, "-nothrow", strlen(bytesPtr))) { - flags = TCL_ENCODING_NO_THROW; - } else if (bytesPtr[0] == '-' && bytesPtr[1] == 's' - && !strncmp(bytesPtr, "-stoponerror", strlen(bytesPtr))) { - flags = TCL_ENCODING_STOPONERROR; - } else { - goto encConvFromError; + bytesPtr = Tcl_GetString(objv[1]); + if (bytesPtr[0] == '-' && bytesPtr[1] == 'n' + && !strncmp(bytesPtr, "-nothrow", strlen(bytesPtr))) { + flags = TCL_ENCODING_NO_THROW; + } else if (bytesPtr[0] == '-' && bytesPtr[1] == 's' + && !strncmp(bytesPtr, "-stoponerror", strlen(bytesPtr))) { + flags = TCL_ENCODING_STOPONERROR; + } else if (objc < 4) { + if (Tcl_GetEncodingFromObj(interp, objv[objc - 2], &encoding) != TCL_OK) { + return TCL_ERROR; } + goto encConvFromOK; + } else { + goto encConvFromError; + } + if (objc < 4) { + encoding = Tcl_GetEncoding(interp, NULL); + } else if (Tcl_GetEncodingFromObj(interp, objv[objc - 2], &encoding) != TCL_OK) { + return TCL_ERROR; } } else { encConvFromError: @@ -583,16 +588,18 @@ EncodingConvertfromObjCmd( return TCL_ERROR; } +encConvFromOK: /* * Convert the string into a byte array in 'ds' */ - if (flags & TCL_ENCODING_STOPONERROR) { - bytesPtr = (char *) TclGetBytesFromObj(interp, data, &length); - if (bytesPtr == NULL) { - return TCL_ERROR; - } - } else { +#if !defined(TCL_NO_DEPRECATED) && (TCL_MAJOR_VERSION < 9) + if (!(flags & TCL_ENCODING_STOPONERROR)) { bytesPtr = (char *) Tcl_GetByteArrayFromObj(data, &length); + } else +#endif + bytesPtr = (char *) TclGetBytesFromObj(interp, data, &length); + if (bytesPtr == NULL) { + return TCL_ERROR; } result = Tcl_ExternalToUtfDStringEx(encoding, bytesPtr, length, flags, &ds); @@ -660,21 +667,26 @@ EncodingConverttoObjCmd( encoding = Tcl_GetEncoding(interp, NULL); data = objv[1]; } else if ((unsigned)(objc - 2) < 3) { - if (Tcl_GetEncodingFromObj(interp, objv[objc - 2], &encoding) != TCL_OK) { - return TCL_ERROR; - } data = objv[objc - 1]; - if (objc > 3) { - stringPtr = Tcl_GetString(objv[1]); - if (stringPtr[0] == '-' && stringPtr[1] == 'n' - && !strncmp(stringPtr, "-nothrow", strlen(stringPtr))) { - flags = TCL_ENCODING_NO_THROW; - } else if (stringPtr[0] == '-' && stringPtr[1] == 's' - && !strncmp(stringPtr, "-stoponerror", strlen(stringPtr))) { - flags = TCL_ENCODING_STOPONERROR; - } else { - goto encConvToError; + stringPtr = Tcl_GetString(objv[1]); + if (stringPtr[0] == '-' && stringPtr[1] == 'n' + && !strncmp(stringPtr, "-nothrow", strlen(stringPtr))) { + flags = TCL_ENCODING_NO_THROW; + } else if (stringPtr[0] == '-' && stringPtr[1] == 's' + && !strncmp(stringPtr, "-stoponerror", strlen(stringPtr))) { + flags = TCL_ENCODING_STOPONERROR; + } else if (objc < 4) { + if (Tcl_GetEncodingFromObj(interp, objv[objc - 2], &encoding) != TCL_OK) { + return TCL_ERROR; } + goto encConvToOK; + } else { + goto encConvToError; + } + if (objc < 4) { + encoding = Tcl_GetEncoding(interp, NULL); + } else if (Tcl_GetEncodingFromObj(interp, objv[objc - 2], &encoding) != TCL_OK) { + return TCL_ERROR; } } else { encConvToError: @@ -682,6 +694,7 @@ EncodingConverttoObjCmd( return TCL_ERROR; } +encConvToOK: /* * Convert the string to a byte array in 'ds' */ diff --git a/tests/encoding.test b/tests/encoding.test index d30ef60..55ace7f 100644 --- a/tests/encoding.test +++ b/tests/encoding.test @@ -627,6 +627,12 @@ test encoding-24.19 {Parse valid or invalid utf-8} -constraints testbytestring - test encoding-24.20 {Parse valid or invalid utf-8} -constraints testbytestring -body { encoding convertto -stoponerror utf-8 "ZX\uD800" } -returnCodes 1 -match glob -result "unexpected character at index 2: 'U+00D800'" +test encoding-24.21 {Parse with -nothrow but without providing encoding} { + string length [encoding convertfrom -nothrow "\x20"] +} 1 +test encoding-24.22 {Parse with -nothrow but without providing encoding} { + string length [encoding convertto -nothrow "\x20"] +} 1 file delete [file join [temporaryDirectory] iso2022.txt] # -- cgit v0.12 From 20fcf335945daf5dedf6f10f940026b681dd7f1b Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 26 May 2021 14:10:30 +0000 Subject: More testcases regarding possible parse errors --- tests/encoding.test | 15 ++++++++++++++- 1 file changed, 14 insertions(+), 1 deletion(-) diff --git a/tests/encoding.test b/tests/encoding.test index 55ace7f..bdebad9 100644 --- a/tests/encoding.test +++ b/tests/encoding.test @@ -624,7 +624,7 @@ test encoding-24.18 {Parse valid or invalid utf-8} -constraints testbytestring - test encoding-24.19 {Parse valid or invalid utf-8} -constraints testbytestring -body { encoding convertto -stoponerror utf-8 [testbytestring "Z\xE0\x80xxxxxx"] } -result "Z\xC3\xA0\xE2\x82\xACxxxxxx" -test encoding-24.20 {Parse valid or invalid utf-8} -constraints testbytestring -body { +test encoding-24.20 {Parse valid or invalid utf-8} -body { encoding convertto -stoponerror utf-8 "ZX\uD800" } -returnCodes 1 -match glob -result "unexpected character at index 2: 'U+00D800'" test encoding-24.21 {Parse with -nothrow but without providing encoding} { @@ -633,6 +633,19 @@ test encoding-24.21 {Parse with -nothrow but without providing encoding} { test encoding-24.22 {Parse with -nothrow but without providing encoding} { string length [encoding convertto -nothrow "\x20"] } 1 +test encoding-24.23 {Syntax error, two encodings} -body { + encoding convertfrom iso8859-1 utf-8 "ZX\uD800" +} -returnCodes 1 -result {wrong # args: should be "::tcl::encoding::convertfrom ?-nothrow|-stoponerror? ?encoding? data"} +test encoding-24.24 {Syntax error, two encodings} -body { + encoding convertto iso8859-1 utf-8 "ZX\uD800" +} -returnCodes 1 -result {wrong # args: should be "::tcl::encoding::convertto ?-nothrow|-stoponerror? ?encoding? data"} +test encoding-24.25 {Syntax error, two options} -body { + encoding convertfrom -nothrow -stoponerror "ZX\uD800" +} -returnCodes 1 -result {unknown encoding "-stoponerror"} +test encoding-24.26 {Syntax error, two options} -body { + encoding convertto -nothrow -stoponerror "ZX\uD800" +} -returnCodes 1 -result {unknown encoding "-stoponerror"} + file delete [file join [temporaryDirectory] iso2022.txt] # -- cgit v0.12 From f38691efea4e8147b9699e7ba46ed8f576d1e873 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 7 Jun 2021 16:37:28 +0000 Subject: =?UTF-8?q?Temporary=20fix=20for=20[29871ea55c],=20by=20not=20buil?= =?UTF-8?q?ding=20pkg=CF=80.c=20by=20default:=20Older=20gcc=20(and=20other?= =?UTF-8?q?)=20C-compilers=20cannot=20handle=20this.?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- unix/dltest/Makefile.in | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/unix/dltest/Makefile.in b/unix/dltest/Makefile.in index 55a711f..7a872c5 100644 --- a/unix/dltest/Makefile.in +++ b/unix/dltest/Makefile.in @@ -25,11 +25,11 @@ LDFLAGS = @LDFLAGS_DEFAULT@ @LDFLAGS@ CC_SWITCHES = $(CFLAGS) -I${SRC_DIR}/../../generic -DTCL_MEM_DEBUG \ ${SHLIB_CFLAGS} -DUSE_TCL_STUBS ${AC_FLAGS} -all: embtest tcl9pkgπ${SHLIB_SUFFIX} tcl9pkga${SHLIB_SUFFIX} tcl9pkgb${SHLIB_SUFFIX} tcl9pkgc${SHLIB_SUFFIX} tcl9pkgd${SHLIB_SUFFIX} tcl9pkge${SHLIB_SUFFIX} tcl9pkgua${SHLIB_SUFFIX} tcl9pkgooa${SHLIB_SUFFIX} +all: embtest tcl9pkga${SHLIB_SUFFIX} tcl9pkgb${SHLIB_SUFFIX} tcl9pkgc${SHLIB_SUFFIX} tcl9pkgd${SHLIB_SUFFIX} tcl9pkge${SHLIB_SUFFIX} tcl9pkgua${SHLIB_SUFFIX} tcl9pkgooa${SHLIB_SUFFIX} @if test -n "$(DLTEST_SUFFIX)"; then $(MAKE) dltest_suffix; fi @touch ../dltest.marker -dltest_suffix: tcl9pkgπ${DLTEST_SUFFIX} tcl9pkga${DLTEST_SUFFIX} tcl9pkgb${DLTEST_SUFFIX} tcl9pkgc${DLTEST_SUFFIX} tcl9pkgd${DLTEST_SUFFIX} tcl9pkge${DLTEST_SUFFIX} tcl9pkgua${DLTEST_SUFFIX} tcl9pkgooa${DLTEST_SUFFIX} +dltest_suffix: tcl9pkga${DLTEST_SUFFIX} tcl9pkgb${DLTEST_SUFFIX} tcl9pkgc${DLTEST_SUFFIX} tcl9pkgd${DLTEST_SUFFIX} tcl9pkge${DLTEST_SUFFIX} tcl9pkgua${DLTEST_SUFFIX} tcl9pkgooa${DLTEST_SUFFIX} @touch ../dltest.marker embtest.o: $(SRC_DIR)/embtest.c -- cgit v0.12 From fdcf06d7315d6e51133ed51339324dcaa1731707 Mon Sep 17 00:00:00 2001 From: dgp Date: Tue, 22 Jun 2021 02:49:23 +0000 Subject: update changes --- changes | 7 +++++++ 1 file changed, 7 insertions(+) diff --git a/changes b/changes index 46cf762..e5ec3a8 100644 --- a/changes +++ b/changes @@ -9351,10 +9351,17 @@ Changes to 9.0a3 include all changes to the 8.7 line through 8.7a5, plus the following, which focuses on the high-level feature changes in this changeset (new major version) rather than bug fixes: +Many of the TIPs in Tcl 8.7 mentioned above are extended further in 9.0 +2020-02-28 [TIP 497] Full support for Unicode planes 1-16 +2020-08-21 (bug)[43b434] improper calls to stat64() +2021-04-08 [TIP 595] Unicode-aware loadable library handling. +2021-04-30 [TIP 596] Stubs support for embedding Tcl in apps + +Many internal changes to broaden support for sizes beyond 32-bits. - Released 9.0a3, Jun 23, 2021 --- https://core.tcl-lang.org/tcl/ for details - -- cgit v0.12 From 5d945e860c40ef1dbdcfcff14829206954b3f202 Mon Sep 17 00:00:00 2001 From: dgp Date: Fri, 25 Jun 2021 13:44:58 +0000 Subject: Bump version number to distinguish from release. --- README.md | 2 +- generic/tcl.h | 4 ++-- library/init.tcl | 2 +- unix/configure | 2 +- unix/configure.ac | 2 +- unix/tcl.spec | 2 +- win/configure | 2 +- win/configure.ac | 2 +- 8 files changed, 9 insertions(+), 9 deletions(-) diff --git a/README.md b/README.md index d6785d4..1ec9c96 100644 --- a/README.md +++ b/README.md @@ -1,6 +1,6 @@ # README: Tcl -This is the **Tcl 9.0a3** source distribution. +This is the **Tcl 9.0a4** source distribution. You can get any source release of Tcl from [our distribution site](https://sourceforge.net/projects/tcl/files/Tcl/). diff --git a/generic/tcl.h b/generic/tcl.h index f221b0c..c5fa9a5 100644 --- a/generic/tcl.h +++ b/generic/tcl.h @@ -50,10 +50,10 @@ extern "C" { #define TCL_MAJOR_VERSION 9 #define TCL_MINOR_VERSION 0 #define TCL_RELEASE_LEVEL TCL_ALPHA_RELEASE -#define TCL_RELEASE_SERIAL 3 +#define TCL_RELEASE_SERIAL 4 #define TCL_VERSION "9.0" -#define TCL_PATCH_LEVEL "9.0a3" +#define TCL_PATCH_LEVEL "9.0a4" #if defined(RC_INVOKED) /* diff --git a/library/init.tcl b/library/init.tcl index c01dc97..09b81fb 100644 --- a/library/init.tcl +++ b/library/init.tcl @@ -19,7 +19,7 @@ if {[info commands package] == ""} { error "version mismatch: library\nscripts expect Tcl version 7.5b1 or later but the loaded version is\nonly [info patchlevel]" } -package require -exact tcl 9.0a3 +package require -exact tcl 9.0a4 # Compute the auto path to use in this interpreter. # The values on the path come from several locations: diff --git a/unix/configure b/unix/configure index ea26d70..9e5486f 100755 --- a/unix/configure +++ b/unix/configure @@ -2683,7 +2683,7 @@ ac_compiler_gnu=$ac_cv_c_compiler_gnu TCL_VERSION=9.0 TCL_MAJOR_VERSION=9 TCL_MINOR_VERSION=0 -TCL_PATCH_LEVEL="a3" +TCL_PATCH_LEVEL="a4" VERSION=${TCL_VERSION} EXTRA_INSTALL_BINARIES=${EXTRA_INSTALL_BINARIES:-"@:"} diff --git a/unix/configure.ac b/unix/configure.ac index d826c90..324399d 100644 --- a/unix/configure.ac +++ b/unix/configure.ac @@ -26,7 +26,7 @@ m4_ifdef([SC_USE_CONFIG_HEADERS], [ TCL_VERSION=9.0 TCL_MAJOR_VERSION=9 TCL_MINOR_VERSION=0 -TCL_PATCH_LEVEL="a3" +TCL_PATCH_LEVEL="a4" VERSION=${TCL_VERSION} EXTRA_INSTALL_BINARIES=${EXTRA_INSTALL_BINARIES:-"@:"} diff --git a/unix/tcl.spec b/unix/tcl.spec index bce18b8..f2d4bd5 100644 --- a/unix/tcl.spec +++ b/unix/tcl.spec @@ -4,7 +4,7 @@ Name: tcl Summary: Tcl scripting language development environment -Version: 9.0a3 +Version: 9.0a4 Release: 2 License: BSD Group: Development/Languages diff --git a/win/configure b/win/configure index 0c2bdf7..059f619 100755 --- a/win/configure +++ b/win/configure @@ -2401,7 +2401,7 @@ SHELL=/bin/sh TCL_VERSION=9.0 TCL_MAJOR_VERSION=9 TCL_MINOR_VERSION=0 -TCL_PATCH_LEVEL="a3" +TCL_PATCH_LEVEL="a4" VER=$TCL_MAJOR_VERSION$TCL_MINOR_VERSION TCL_DDE_VERSION=1.4 diff --git a/win/configure.ac b/win/configure.ac index f52df0b..59c9dd9 100644 --- a/win/configure.ac +++ b/win/configure.ac @@ -15,7 +15,7 @@ SHELL=/bin/sh TCL_VERSION=9.0 TCL_MAJOR_VERSION=9 TCL_MINOR_VERSION=0 -TCL_PATCH_LEVEL="a3" +TCL_PATCH_LEVEL="a4" VER=$TCL_MAJOR_VERSION$TCL_MINOR_VERSION TCL_DDE_VERSION=1.4 -- cgit v0.12 From ba2e55da57918ca2d91334bc01e4183f391202fd Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 25 Jun 2021 16:13:55 +0000 Subject: typo --- generic/tclLoad.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/generic/tclLoad.c b/generic/tclLoad.c index 9335437..cca5b7a 100644 --- a/generic/tclLoad.c +++ b/generic/tclLoad.c @@ -339,7 +339,7 @@ Tcl_LoadObjCmd( } #endif /* __CYGWIN__ */ if (((pkgGuess[0] == 't') -#ifdef MAC_OS_TCL +#ifdef MAC_OSX_TCL || (pkgGuess[0] == 'T') #endif ) && (pkgGuess[1] == 'c') -- cgit v0.12 From 82d5e7d59540bfd95e3258032a92d4607752d9cd Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Sun, 15 Aug 2021 20:35:59 +0000 Subject: Proposed TIP #609 implementation --- doc/Notifier.3 | 23 ++++++++++++++++++----- generic/tcl.h | 17 +++++++++++++++++ generic/tclIORChan.c | 8 ++++---- generic/tclIORTrans.c | 4 ++-- generic/tclNotify.c | 35 ++++++++++++++++++++++++----------- generic/tclThreadTest.c | 3 +-- 6 files changed, 66 insertions(+), 24 deletions(-) diff --git a/doc/Notifier.3 b/doc/Notifier.3 index ec9f910..755930f 100644 --- a/doc/Notifier.3 +++ b/doc/Notifier.3 @@ -92,7 +92,9 @@ An event to add to the event queue. The storage for the event must have been allocated by the caller using \fBTcl_Alloc\fR or \fBckalloc\fR. .AP Tcl_QueuePosition position in Where to add the new event in the queue: \fBTCL_QUEUE_TAIL\fR, -\fBTCL_QUEUE_HEAD\fR, or \fBTCL_QUEUE_MARK\fR. +\fBTCL_QUEUE_HEAD\fR, \fBTCL_QUEUE_MARK\fR, +\fBTCL_QUEUE_TAIL_ALERT_IF_EMPTY\fR, or +\fBTCL_QUEUE_HEAD_ALERT_IF_EMPTY\fR. .AP Tcl_ThreadId threadId in A unique identifier for a thread. .AP Tcl_EventDeleteProc *deleteProc in @@ -340,14 +342,14 @@ and should not be modified by the event source. .PP An event may be added to the queue at any of three positions, depending on the \fIposition\fR argument to \fBTcl_QueueEvent\fR: -.IP \fBTCL_QUEUE_TAIL\fR 24 +.IP \fBTCL_QUEUE_TAIL\fR 32 Add the event at the back of the queue, so that all other pending events will be serviced first. This is almost always the right place for new events. -.IP \fBTCL_QUEUE_HEAD\fR 24 +.IP \fBTCL_QUEUE_HEAD\fR 32 Add the event at the front of the queue, so that it will be serviced before all other queued events. -.IP \fBTCL_QUEUE_MARK\fR 24 +.IP \fBTCL_QUEUE_MARK\fR 32 Add the event at the front of the queue, unless there are other events at the front whose position is \fBTCL_QUEUE_MARK\fR; if so, add the new event just after all other \fBTCL_QUEUE_MARK\fR events. @@ -355,6 +357,14 @@ This value of \fIposition\fR is used to insert an ordered sequence of events at the front of the queue, such as a series of Enter and Leave events synthesized during a grab or ungrab operation in Tk. +.IP \fBTCL_QUEUE_TAIL_ALERT_IF_EMPTY\fR 32 +Like \fBTCL_QUEUE_TAIL\fR but when used in \fBTcl_ThreadQueueEvent\fR +arranges for an automatic call of \fBTcl_ThreadAlert\fR when the queue was +empty. +.IP \fBTCL_QUEUE_HEAD_ALERT_IF_EMPTY\fR 32 +Like \fBTCL_QUEUE_HEAD\fR but when used in \fBTcl_ThreadQueueEvent\fR +arranges for an automatic call of \fBTcl_ThreadAlert\fR when the queue was +empty. .PP When it is time to handle an event from the queue (steps 1 and 4 above) \fBTcl_ServiceEvent\fR will invoke the \fIproc\fR specified @@ -408,7 +418,10 @@ threads for those threads to be able to add events to its queue.) After adding an event to another thread's queue, you then typically need to call \fBTcl_ThreadAlert\fR to .QW "wake up" -that thread's notifier to alert it to the new event. +that thread's notifier to alert it to the new event. Alternatively, +the queue positions \fBTCL_QUEUE_TAIL_ALERT_IF_EMPTY\fR and +\fBTCL_QUEUE_HEAD_ALERT_IF_EMPTY\fR can be used which automatically +call \fBTcl_ThreadAlert\fR if the thread's queue was empty. .PP \fBTcl_DeleteEvents\fR can be used to explicitly remove one or more events from the event queue. \fBTcl_DeleteEvents\fR calls \fIproc\fR diff --git a/generic/tcl.h b/generic/tcl.h index 2d529b7..1ce68b4 100644 --- a/generic/tcl.h +++ b/generic/tcl.h @@ -1337,6 +1337,23 @@ typedef enum { } Tcl_QueuePosition; /* + * Positions for Tcl_ThreadQueueEvent: + */ + +typedef enum { + TCL_QUEUE_TAIL_EX = TCL_QUEUE_TAIL, + TCL_QUEUE_HEAD_EX = TCL_QUEUE_HEAD, + TCL_QUEUE_MARK_EX = TCL_QUEUE_MARK, + TCL_QUEUE_TAIL_EX_ALERT_IF_EMPTY, + TCL_QUEUE_HEAD_EX_ALERT_IF_EMPTY, +} Tcl_QueuePositionEx; + +#define TCL_QUEUE_TAIL_ALERT_IF_EMPTY \ + ((Tcl_QueuePosition) TCL_QUEUE_TAIL_EX_ALERT_IF_EMPTY) +#define TCL_QUEUE_HEAD_ALERT_IF_EMPTY \ + ((Tcl_QueuePosition) TCL_QUEUE_HEAD_EX_ALERT_IF_EMPTY) + +/* * Values to pass to Tcl_SetServiceMode to specify the behavior of notifier * event routines. */ diff --git a/generic/tclIORChan.c b/generic/tclIORChan.c index cc45873..b473417 100644 --- a/generic/tclIORChan.c +++ b/generic/tclIORChan.c @@ -994,8 +994,8 @@ TclChanPostEventObjCmd( * XXX Actually, in that case the channel should be dead also ! */ - Tcl_ThreadQueueEvent(rcPtr->owner, (Tcl_Event *) ev, TCL_QUEUE_TAIL); - Tcl_ThreadAlert(rcPtr->owner); + Tcl_ThreadQueueEvent(rcPtr->owner, (Tcl_Event *) ev, + TCL_QUEUE_TAIL_ALERT_IF_EMPTY); } #endif @@ -2996,8 +2996,8 @@ ForwardOpToHandlerThread( * Queue the event and poke the other thread's notifier. */ - Tcl_ThreadQueueEvent(dst, (Tcl_Event *) evPtr, TCL_QUEUE_TAIL); - Tcl_ThreadAlert(dst); + Tcl_ThreadQueueEvent(dst, (Tcl_Event *) evPtr, + TCL_QUEUE_TAIL_ALERT_IF_EMPTY); /* * (*) Block until the handler thread has either processed the transfer or diff --git a/generic/tclIORTrans.c b/generic/tclIORTrans.c index b06bd45..eda72ba 100644 --- a/generic/tclIORTrans.c +++ b/generic/tclIORTrans.c @@ -2452,8 +2452,8 @@ ForwardOpToOwnerThread( * Queue the event and poke the other thread's notifier. */ - Tcl_ThreadQueueEvent(dst, (Tcl_Event *) evPtr, TCL_QUEUE_TAIL); - Tcl_ThreadAlert(dst); + Tcl_ThreadQueueEvent(dst, (Tcl_Event *) evPtr, + TCL_QUEUE_TAIL_ALERT_IF_EMPTY); /* * (*) Block until the other thread has either processed the transfer or diff --git a/generic/tclNotify.c b/generic/tclNotify.c index 12b40b1..99aceec 100644 --- a/generic/tclNotify.c +++ b/generic/tclNotify.c @@ -95,8 +95,8 @@ TCL_DECLARE_MUTEX(listLock) * Declarations for routines used only in this file. */ -static void QueueEvent(ThreadSpecificData *tsdPtr, - Tcl_Event *evPtr, Tcl_QueuePosition position); +static int QueueEvent(ThreadSpecificData *tsdPtr, + Tcl_Event *evPtr, Tcl_QueuePositionEx position); /* *---------------------------------------------------------------------- @@ -397,7 +397,7 @@ Tcl_QueueEvent( { ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); - QueueEvent(tsdPtr, evPtr, position); + (void) QueueEvent(tsdPtr, evPtr, (Tcl_QueuePositionEx) position); } /* @@ -444,7 +444,9 @@ Tcl_ThreadQueueEvent( */ if (tsdPtr) { - QueueEvent(tsdPtr, evPtr, position); + if (QueueEvent(tsdPtr, evPtr, (Tcl_QueuePositionEx) position)) { + Tcl_AlertNotifier(tsdPtr->clientData); + } } else { ckfree(evPtr); } @@ -464,7 +466,8 @@ Tcl_ThreadQueueEvent( * last-in-first-out order. * * Results: - * None. + * For TCL_QUEUE_(HEAD|TAIL)_ALERT_IF_EMPTY the empty state before the + * operation is returned. * * Side effects: * None. @@ -472,7 +475,7 @@ Tcl_ThreadQueueEvent( *---------------------------------------------------------------------- */ -static void +static int QueueEvent( ThreadSpecificData *tsdPtr, /* Handle to thread local data that indicates * which event queue to use. */ @@ -481,11 +484,17 @@ QueueEvent( * malloc (ckalloc), and it becomes the * property of the event queue. It will be * freed after the event has been handled. */ - Tcl_QueuePosition position) /* One of TCL_QUEUE_TAIL, TCL_QUEUE_HEAD, - * TCL_QUEUE_MARK. */ + Tcl_QueuePositionEx position) + /* One of TCL_QUEUE_TAIL_EX, + * TCL_QUEUE_HEAD_EX, TCL_QUEUE_MARK_EX, + * TCL_QUEUE_TAIL_ALERT_IF_EMPTY, or + * TCL_QUEUE_HEAD_ALERT_IF_EMPTY. */ { + int wasEmpty = 0; + Tcl_MutexLock(&(tsdPtr->queueMutex)); - if (position == TCL_QUEUE_TAIL) { + if ((position == TCL_QUEUE_TAIL_EX) || + (position == TCL_QUEUE_TAIL_EX_ALERT_IF_EMPTY)) { /* * Append the event on the end of the queue. */ @@ -493,11 +502,13 @@ QueueEvent( evPtr->nextPtr = NULL; if (tsdPtr->firstEventPtr == NULL) { tsdPtr->firstEventPtr = evPtr; + wasEmpty = (position == TCL_QUEUE_TAIL_EX_ALERT_IF_EMPTY) ? 1 : 0; } else { tsdPtr->lastEventPtr->nextPtr = evPtr; } tsdPtr->lastEventPtr = evPtr; - } else if (position == TCL_QUEUE_HEAD) { + } else if ((position == TCL_QUEUE_HEAD_EX) || + (position == TCL_QUEUE_HEAD_EX_ALERT_IF_EMPTY)) { /* * Push the event on the head of the queue. */ @@ -505,9 +516,10 @@ QueueEvent( evPtr->nextPtr = tsdPtr->firstEventPtr; if (tsdPtr->firstEventPtr == NULL) { tsdPtr->lastEventPtr = evPtr; + wasEmpty = (position == TCL_QUEUE_HEAD_EX_ALERT_IF_EMPTY) ? 1 : 0; } tsdPtr->firstEventPtr = evPtr; - } else if (position == TCL_QUEUE_MARK) { + } else if (position == TCL_QUEUE_MARK_EX) { /* * Insert the event after the current marker event and advance the * marker to the new event. @@ -526,6 +538,7 @@ QueueEvent( } } Tcl_MutexUnlock(&(tsdPtr->queueMutex)); + return wasEmpty; } /* diff --git a/generic/tclThreadTest.c b/generic/tclThreadTest.c index 9f08d83..887f645 100644 --- a/generic/tclThreadTest.c +++ b/generic/tclThreadTest.c @@ -878,8 +878,7 @@ ThreadSend( threadEventPtr->event.proc = ThreadEventProc; Tcl_ThreadQueueEvent(threadId, (Tcl_Event *) threadEventPtr, - TCL_QUEUE_TAIL); - Tcl_ThreadAlert(threadId); + TCL_QUEUE_TAIL_ALERT_IF_EMPTY); if (!wait) { Tcl_MutexUnlock(&threadMutex); -- cgit v0.12 From 31b544baefc9bf84fded3c7dfb98da9db1032e10 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Sun, 15 Aug 2021 21:34:02 +0000 Subject: Make TCL_QUEUE_ALERT_IF_EMPTY a separate flag --- doc/Notifier.3 | 15 +++++---------- generic/tcl.decls | 4 ++-- generic/tcl.h | 22 +++------------------- generic/tclDecls.h | 9 ++++----- generic/tclIORChan.c | 4 ++-- generic/tclIORTrans.c | 2 +- generic/tclNotify.c | 33 +++++++++++++++------------------ generic/tclTest.c | 2 +- generic/tclThreadTest.c | 2 +- 9 files changed, 34 insertions(+), 59 deletions(-) diff --git a/doc/Notifier.3 b/doc/Notifier.3 index 755930f..3fb13a2 100644 --- a/doc/Notifier.3 +++ b/doc/Notifier.3 @@ -90,11 +90,10 @@ necessary. .AP Tcl_Event *evPtr in An event to add to the event queue. The storage for the event must have been allocated by the caller using \fBTcl_Alloc\fR or \fBckalloc\fR. -.AP Tcl_QueuePosition position in +.AP int flags in Where to add the new event in the queue: \fBTCL_QUEUE_TAIL\fR, -\fBTCL_QUEUE_HEAD\fR, \fBTCL_QUEUE_MARK\fR, -\fBTCL_QUEUE_TAIL_ALERT_IF_EMPTY\fR, or -\fBTCL_QUEUE_HEAD_ALERT_IF_EMPTY\fR. +\fBTCL_QUEUE_HEAD\fR, \fBTCL_QUEUE_MARK\fR, and whether to do +an alert if the queue is empty: \fBTCL_QUEUE_ALERT_IF_EMPTY\fR. .AP Tcl_ThreadId threadId in A unique identifier for a thread. .AP Tcl_EventDeleteProc *deleteProc in @@ -357,12 +356,8 @@ This value of \fIposition\fR is used to insert an ordered sequence of events at the front of the queue, such as a series of Enter and Leave events synthesized during a grab or ungrab operation in Tk. -.IP \fBTCL_QUEUE_TAIL_ALERT_IF_EMPTY\fR 32 -Like \fBTCL_QUEUE_TAIL\fR but when used in \fBTcl_ThreadQueueEvent\fR -arranges for an automatic call of \fBTcl_ThreadAlert\fR when the queue was -empty. -.IP \fBTCL_QUEUE_HEAD_ALERT_IF_EMPTY\fR 32 -Like \fBTCL_QUEUE_HEAD\fR but when used in \fBTcl_ThreadQueueEvent\fR +.IP \fBTCL_QUEUE_ALERT_IF_EMPTY\fR 32 +When used in \fBTcl_ThreadQueueEvent\fR arranges for an automatic call of \fBTcl_ThreadAlert\fR when the queue was empty. .PP diff --git a/generic/tcl.decls b/generic/tcl.decls index 3dec972..a1bf91b 100644 --- a/generic/tcl.decls +++ b/generic/tcl.decls @@ -732,7 +732,7 @@ declare 204 { const char *Tcl_PosixError(Tcl_Interp *interp) } declare 205 { - void Tcl_QueueEvent(Tcl_Event *evPtr, Tcl_QueuePosition position) + void Tcl_QueueEvent(Tcl_Event *evPtr, int flags) } declare 206 { int Tcl_Read(Tcl_Channel chan, char *bufPtr, int toRead) @@ -1142,7 +1142,7 @@ declare 318 { } declare 319 { void Tcl_ThreadQueueEvent(Tcl_ThreadId threadId, Tcl_Event *evPtr, - Tcl_QueuePosition position) + int flags) } declare 320 { int Tcl_UniCharAtIndex(const char *src, int index) diff --git a/generic/tcl.h b/generic/tcl.h index 1ce68b4..4316f50 100644 --- a/generic/tcl.h +++ b/generic/tcl.h @@ -1329,31 +1329,15 @@ struct Tcl_Event { }; /* - * Positions to pass to Tcl_QueueEvent: + * Positions to pass to Tcl_QueueEvent/Tcl_ThreadQueueEvent: */ typedef enum { - TCL_QUEUE_TAIL, TCL_QUEUE_HEAD, TCL_QUEUE_MARK + TCL_QUEUE_TAIL, TCL_QUEUE_HEAD, TCL_QUEUE_MARK, + TCL_QUEUE_ALERT_IF_EMPTY=4 } Tcl_QueuePosition; /* - * Positions for Tcl_ThreadQueueEvent: - */ - -typedef enum { - TCL_QUEUE_TAIL_EX = TCL_QUEUE_TAIL, - TCL_QUEUE_HEAD_EX = TCL_QUEUE_HEAD, - TCL_QUEUE_MARK_EX = TCL_QUEUE_MARK, - TCL_QUEUE_TAIL_EX_ALERT_IF_EMPTY, - TCL_QUEUE_HEAD_EX_ALERT_IF_EMPTY, -} Tcl_QueuePositionEx; - -#define TCL_QUEUE_TAIL_ALERT_IF_EMPTY \ - ((Tcl_QueuePosition) TCL_QUEUE_TAIL_EX_ALERT_IF_EMPTY) -#define TCL_QUEUE_HEAD_ALERT_IF_EMPTY \ - ((Tcl_QueuePosition) TCL_QUEUE_HEAD_EX_ALERT_IF_EMPTY) - -/* * Values to pass to Tcl_SetServiceMode to specify the behavior of notifier * event routines. */ diff --git a/generic/tclDecls.h b/generic/tclDecls.h index 713f3e9..fb22928 100644 --- a/generic/tclDecls.h +++ b/generic/tclDecls.h @@ -644,8 +644,7 @@ EXTERN int Tcl_PutEnv(const char *assignment); /* 204 */ EXTERN const char * Tcl_PosixError(Tcl_Interp *interp); /* 205 */ -EXTERN void Tcl_QueueEvent(Tcl_Event *evPtr, - Tcl_QueuePosition position); +EXTERN void Tcl_QueueEvent(Tcl_Event *evPtr, int flags); /* 206 */ EXTERN int Tcl_Read(Tcl_Channel chan, char *bufPtr, int toRead); /* 207 */ @@ -985,7 +984,7 @@ EXTERN Tcl_Obj * Tcl_SetVar2Ex(Tcl_Interp *interp, const char *part1, EXTERN void Tcl_ThreadAlert(Tcl_ThreadId threadId); /* 319 */ EXTERN void Tcl_ThreadQueueEvent(Tcl_ThreadId threadId, - Tcl_Event *evPtr, Tcl_QueuePosition position); + Tcl_Event *evPtr, int flags); /* 320 */ EXTERN int Tcl_UniCharAtIndex(const char *src, int index); /* 321 */ @@ -2179,7 +2178,7 @@ typedef struct TclStubs { void (*tcl_PrintDouble) (Tcl_Interp *interp, double value, char *dst); /* 202 */ int (*tcl_PutEnv) (const char *assignment); /* 203 */ const char * (*tcl_PosixError) (Tcl_Interp *interp); /* 204 */ - void (*tcl_QueueEvent) (Tcl_Event *evPtr, Tcl_QueuePosition position); /* 205 */ + void (*tcl_QueueEvent) (Tcl_Event *evPtr, int flags); /* 205 */ int (*tcl_Read) (Tcl_Channel chan, char *bufPtr, int toRead); /* 206 */ void (*tcl_ReapDetachedProcs) (void); /* 207 */ int (*tcl_RecordAndEval) (Tcl_Interp *interp, const char *cmd, int flags); /* 208 */ @@ -2293,7 +2292,7 @@ typedef struct TclStubs { int (*tcl_SetSystemEncoding) (Tcl_Interp *interp, const char *name); /* 316 */ Tcl_Obj * (*tcl_SetVar2Ex) (Tcl_Interp *interp, const char *part1, const char *part2, Tcl_Obj *newValuePtr, int flags); /* 317 */ void (*tcl_ThreadAlert) (Tcl_ThreadId threadId); /* 318 */ - void (*tcl_ThreadQueueEvent) (Tcl_ThreadId threadId, Tcl_Event *evPtr, Tcl_QueuePosition position); /* 319 */ + void (*tcl_ThreadQueueEvent) (Tcl_ThreadId threadId, Tcl_Event *evPtr, int flags); /* 319 */ int (*tcl_UniCharAtIndex) (const char *src, int index); /* 320 */ int (*tcl_UniCharToLower) (int ch); /* 321 */ int (*tcl_UniCharToTitle) (int ch); /* 322 */ diff --git a/generic/tclIORChan.c b/generic/tclIORChan.c index b473417..3f8a51e 100644 --- a/generic/tclIORChan.c +++ b/generic/tclIORChan.c @@ -995,7 +995,7 @@ TclChanPostEventObjCmd( */ Tcl_ThreadQueueEvent(rcPtr->owner, (Tcl_Event *) ev, - TCL_QUEUE_TAIL_ALERT_IF_EMPTY); + TCL_QUEUE_TAIL|TCL_QUEUE_ALERT_IF_EMPTY); } #endif @@ -2997,7 +2997,7 @@ ForwardOpToHandlerThread( */ Tcl_ThreadQueueEvent(dst, (Tcl_Event *) evPtr, - TCL_QUEUE_TAIL_ALERT_IF_EMPTY); + TCL_QUEUE_TAIL|TCL_QUEUE_ALERT_IF_EMPTY); /* * (*) Block until the handler thread has either processed the transfer or diff --git a/generic/tclIORTrans.c b/generic/tclIORTrans.c index eda72ba..1d66835 100644 --- a/generic/tclIORTrans.c +++ b/generic/tclIORTrans.c @@ -2453,7 +2453,7 @@ ForwardOpToOwnerThread( */ Tcl_ThreadQueueEvent(dst, (Tcl_Event *) evPtr, - TCL_QUEUE_TAIL_ALERT_IF_EMPTY); + TCL_QUEUE_TAIL|TCL_QUEUE_ALERT_IF_EMPTY); /* * (*) Block until the other thread has either processed the transfer or diff --git a/generic/tclNotify.c b/generic/tclNotify.c index 99aceec..fa85f95 100644 --- a/generic/tclNotify.c +++ b/generic/tclNotify.c @@ -96,7 +96,7 @@ TCL_DECLARE_MUTEX(listLock) */ static int QueueEvent(ThreadSpecificData *tsdPtr, - Tcl_Event *evPtr, Tcl_QueuePositionEx position); + Tcl_Event *evPtr, int flags); /* *---------------------------------------------------------------------- @@ -392,12 +392,12 @@ Tcl_QueueEvent( * malloc (ckalloc), and it becomes the * property of the event queue. It will be * freed after the event has been handled. */ - Tcl_QueuePosition position) /* One of TCL_QUEUE_TAIL, TCL_QUEUE_HEAD, - * TCL_QUEUE_MARK. */ + int flags) /* One of TCL_QUEUE_TAIL, TCL_QUEUE_HEAD, + * TCL_QUEUE_MARK, possibly combined with TCL_QUEUE_ALERT_IF_EMPTY. */ { ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); - (void) QueueEvent(tsdPtr, evPtr, (Tcl_QueuePositionEx) position); + (void) QueueEvent(tsdPtr, evPtr, flags); } /* @@ -424,8 +424,8 @@ Tcl_ThreadQueueEvent( * malloc (ckalloc), and it becomes the * property of the event queue. It will be * freed after the event has been handled. */ - Tcl_QueuePosition position) /* One of TCL_QUEUE_TAIL, TCL_QUEUE_HEAD, - * TCL_QUEUE_MARK. */ + int flags) /* One of TCL_QUEUE_TAIL, TCL_QUEUE_HEAD, + * TCL_QUEUE_MARK, possibly combined with TCL_QUEUE_ALERT_IF_EMPTY. */ { ThreadSpecificData *tsdPtr; @@ -444,7 +444,7 @@ Tcl_ThreadQueueEvent( */ if (tsdPtr) { - if (QueueEvent(tsdPtr, evPtr, (Tcl_QueuePositionEx) position)) { + if (QueueEvent(tsdPtr, evPtr, flags)) { Tcl_AlertNotifier(tsdPtr->clientData); } } else { @@ -466,7 +466,7 @@ Tcl_ThreadQueueEvent( * last-in-first-out order. * * Results: - * For TCL_QUEUE_(HEAD|TAIL)_ALERT_IF_EMPTY the empty state before the + * For TCL_QUEUE_ALERT_IF_EMPTY the empty state before the * operation is returned. * * Side effects: @@ -484,17 +484,15 @@ QueueEvent( * malloc (ckalloc), and it becomes the * property of the event queue. It will be * freed after the event has been handled. */ - Tcl_QueuePositionEx position) + int flags) /* One of TCL_QUEUE_TAIL_EX, * TCL_QUEUE_HEAD_EX, TCL_QUEUE_MARK_EX, - * TCL_QUEUE_TAIL_ALERT_IF_EMPTY, or - * TCL_QUEUE_HEAD_ALERT_IF_EMPTY. */ + * possibly combined with TCL_QUEUE_ALERT_IF_EMPTY */ { int wasEmpty = 0; Tcl_MutexLock(&(tsdPtr->queueMutex)); - if ((position == TCL_QUEUE_TAIL_EX) || - (position == TCL_QUEUE_TAIL_EX_ALERT_IF_EMPTY)) { + if ((flags & 3) == TCL_QUEUE_TAIL) { /* * Append the event on the end of the queue. */ @@ -502,13 +500,12 @@ QueueEvent( evPtr->nextPtr = NULL; if (tsdPtr->firstEventPtr == NULL) { tsdPtr->firstEventPtr = evPtr; - wasEmpty = (position == TCL_QUEUE_TAIL_EX_ALERT_IF_EMPTY) ? 1 : 0; + wasEmpty = (flags & TCL_QUEUE_ALERT_IF_EMPTY) ? 1 : 0; } else { tsdPtr->lastEventPtr->nextPtr = evPtr; } tsdPtr->lastEventPtr = evPtr; - } else if ((position == TCL_QUEUE_HEAD_EX) || - (position == TCL_QUEUE_HEAD_EX_ALERT_IF_EMPTY)) { + } else if ((flags & 3) == TCL_QUEUE_HEAD) { /* * Push the event on the head of the queue. */ @@ -516,10 +513,10 @@ QueueEvent( evPtr->nextPtr = tsdPtr->firstEventPtr; if (tsdPtr->firstEventPtr == NULL) { tsdPtr->lastEventPtr = evPtr; - wasEmpty = (position == TCL_QUEUE_HEAD_EX_ALERT_IF_EMPTY) ? 1 : 0; + wasEmpty = (flags & TCL_QUEUE_ALERT_IF_EMPTY) ? 1 : 0; } tsdPtr->firstEventPtr = evPtr; - } else if (position == TCL_QUEUE_MARK_EX) { + } else if ((flags & 3) == TCL_QUEUE_MARK) { /* * Insert the event after the current marker event and advance the * marker to the new event. diff --git a/generic/tclTest.c b/generic/tclTest.c index 99fe92f..b29bb1c 100644 --- a/generic/tclTest.c +++ b/generic/tclTest.c @@ -2109,7 +2109,7 @@ TesteventObjCmd( "head", "tail", "mark", NULL }; int posIndex; /* Index of the chosen position */ - static const Tcl_QueuePosition posNum[] = { + static const int posNum[] = { /* Interpretation of the chosen position */ TCL_QUEUE_HEAD, TCL_QUEUE_TAIL, diff --git a/generic/tclThreadTest.c b/generic/tclThreadTest.c index 887f645..1e8e013 100644 --- a/generic/tclThreadTest.c +++ b/generic/tclThreadTest.c @@ -878,7 +878,7 @@ ThreadSend( threadEventPtr->event.proc = ThreadEventProc; Tcl_ThreadQueueEvent(threadId, (Tcl_Event *) threadEventPtr, - TCL_QUEUE_TAIL_ALERT_IF_EMPTY); + TCL_QUEUE_TAIL|TCL_QUEUE_ALERT_IF_EMPTY); if (!wait) { Tcl_MutexUnlock(&threadMutex); -- cgit v0.12 From 65dc531cf93c773f5d73b4db3cb9dce44d5386df Mon Sep 17 00:00:00 2001 From: dgp Date: Fri, 20 Aug 2021 13:10:21 +0000 Subject: Repair build failure. --- generic/tclAsync.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/generic/tclAsync.c b/generic/tclAsync.c index a2ee1eb..38ea2e4 100644 --- a/generic/tclAsync.c +++ b/generic/tclAsync.c @@ -115,7 +115,7 @@ TclFinalizeAsync(void) while (toDelete != NULL) { token = toDelete; toDelete = toDelete->nextPtr; - ckfree(token); + Tcl_Free(token); } } -- cgit v0.12 From c5d86c1b291b4db986c0d8b8087bf8d679e0bdf8 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 25 Aug 2021 11:06:31 +0000 Subject: Fix for TIP #430/#595 corner-case: tcl_findLibrary should use correct library name when running in Tcl 9. --- library/auto.tcl | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/library/auto.tcl b/library/auto.tcl index dc37328..0d30011 100644 --- a/library/auto.tcl +++ b/library/auto.tcl @@ -108,7 +108,7 @@ proc tcl_findLibrary {basename version patch initScript enVarName varName} { catch {lappend paths [::tcl::pkgconfig get bindir,runtime]} } if {[catch {::${basename}::pkgconfig get dllfile,runtime} dllfile]} { - set dllfile "lib${basename}${version}[info sharedlibextension]" + set dllfile "libtcl9${basename}${version}[info sharedlibextension]" } set dir [file dirname [file join [pwd] [info nameofexecutable]]] lappend paths $dir -- cgit v0.12 From 00b583a57994fe50d0b67f154b398d81b4ab7561 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 27 Aug 2021 07:20:33 +0000 Subject: One more TclUnusedStubEntry -> TclOOUnusedStubEntry --- generic/tclOOStubInit.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/generic/tclOOStubInit.c b/generic/tclOOStubInit.c index df3f07d..4b6559a 100644 --- a/generic/tclOOStubInit.c +++ b/generic/tclOOStubInit.c @@ -14,7 +14,7 @@ MODULE_SCOPE const TclOOStubs tclOOStubs; #pragma GCC dependency "tclOO.decls" #endif -#define TclUnusedStubEntry 0 +#define TclOOUnusedStubEntry 0 /* !BEGIN!: Do not edit below this line. */ -- cgit v0.12 From 166d3a5b6c49ef9433b4e01976d24d25534431fb Mon Sep 17 00:00:00 2001 From: pooryorick Date: Wed, 1 Sep 2021 23:13:17 +0000 Subject: Fix for [ccc448a6bfd59cbd], namespace ensemble subcommand name prefix matching and a subsequent error results in a segmentation fault --- generic/tclEnsemble.c | 20 +++++++++++++++++++- generic/tclIndexObj.c | 18 +++++------------- generic/tclInt.h | 1 + generic/tclNamesp.c | 5 +++-- tests/namespace.test | 18 ++++++++++++++++++ 5 files changed, 46 insertions(+), 16 deletions(-) diff --git a/generic/tclEnsemble.c b/generic/tclEnsemble.c index 13408e1..799c645 100644 --- a/generic/tclEnsemble.c +++ b/generic/tclEnsemble.c @@ -2201,6 +2201,18 @@ TclSpellFix( TclNRAddCallback(interp, TclNRReleaseValues, fix, NULL, NULL, NULL); } +Tcl_Obj *const *TclEnsembleGetRewriteValues( + Tcl_Interp *interp /* Current interpreter. */ +) +{ + Interp *iPtr = (Interp *) interp; + Tcl_Obj *const *origObjv = iPtr->ensembleRewrite.sourceObjs; + if (origObjv[0] == NULL) { + origObjv = (Tcl_Obj *const *)origObjv[2]; + } + return origObjv; +} + /* *---------------------------------------------------------------------- * @@ -2225,12 +2237,18 @@ TclFetchEnsembleRoot( int objc, int *objcPtr) { + Tcl_Obj *const *sourceObjs; Interp *iPtr = (Interp *) interp; if (iPtr->ensembleRewrite.sourceObjs) { *objcPtr = objc + iPtr->ensembleRewrite.numRemovedObjs - iPtr->ensembleRewrite.numInsertedObjs; - return iPtr->ensembleRewrite.sourceObjs; + if (iPtr->ensembleRewrite.sourceObjs[0] == NULL) { + sourceObjs = iPtr->ensembleRewrite.sourceObjs[1]; + } else { + sourceObjs = iPtr->ensembleRewrite.sourceObjs; + } + return sourceObjs; } *objcPtr = objc; return objv; diff --git a/generic/tclIndexObj.c b/generic/tclIndexObj.c index b665589..f81f0b3 100644 --- a/generic/tclIndexObj.c +++ b/generic/tclIndexObj.c @@ -798,27 +798,19 @@ Tcl_WrongNumArgs( } /* - * Check to see if we are processing an ensemble implementation, and if so - * rewrite the results in terms of how the ensemble was invoked. + * If processing an an ensemble implementation, rewrite the results in + * terms of how the ensemble was invoked. */ if (iPtr->ensembleRewrite.sourceObjs != NULL) { int toSkip = iPtr->ensembleRewrite.numInsertedObjs; int toPrint = iPtr->ensembleRewrite.numRemovedObjs; - Tcl_Obj *const *origObjv = iPtr->ensembleRewrite.sourceObjs; + Tcl_Obj *const *origObjv = TclEnsembleGetRewriteValues(interp); /* - * Check for spelling fixes, and substitute the fixed values. - */ - - if (origObjv[0] == NULL) { - origObjv = (Tcl_Obj *const *)origObjv[2]; - } - - /* - * We only know how to do rewriting if all the replaced objects are + * Only do rewrite the command if all the replaced objects are * actually arguments (in objv) to this function. Otherwise it just - * gets too complicated and we'd be better off just giving a slightly + * gets too complicated and it's to just give a slightly * confusing error message... */ diff --git a/generic/tclInt.h b/generic/tclInt.h index 7f19a42..96bbfc5 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -2924,6 +2924,7 @@ MODULE_SCOPE char * TclDStringAppendDString(Tcl_DString *dsPtr, MODULE_SCOPE Tcl_Obj * TclDStringToObj(Tcl_DString *dsPtr); MODULE_SCOPE Tcl_Obj *const *TclFetchEnsembleRoot(Tcl_Interp *interp, Tcl_Obj *const *objv, int objc, int *objcPtr); +MODULE_SCOPE Tcl_Obj *const *TclEnsembleGetRewriteValues(Tcl_Interp *interp); MODULE_SCOPE Tcl_Namespace *TclEnsureNamespace(Tcl_Interp *interp, Tcl_Namespace *namespacePtr); MODULE_SCOPE void TclFinalizeAllocSubsystem(void); diff --git a/generic/tclNamesp.c b/generic/tclNamesp.c index 8f2a711..f935fa4 100644 --- a/generic/tclNamesp.c +++ b/generic/tclNamesp.c @@ -4924,8 +4924,9 @@ TclLogCommandInfo( * command (must be <= command). */ const char *command, /* First character in command that generated * the error. */ - size_t length, /* Number of bytes in command (-1 means - * use all bytes up to first null byte). */ + size_t length, /* Number of bytes in command (TCL_INDEX_NONE + * means use all bytes up to first null byte). + */ const unsigned char *pc, /* Current pc of bytecode execution context */ Tcl_Obj **tosPtr) /* Current stack of bytecode execution * context */ diff --git a/tests/namespace.test b/tests/namespace.test index 2d0c20f..ae233cb 100644 --- a/tests/namespace.test +++ b/tests/namespace.test @@ -1920,6 +1920,24 @@ test namespace-42.10 { unset -nocomplain lst } -returnCodes error -match glob -result {invalid command name *three*} + +test namespace-42.11 { + ensembles: prefix matching segmentation fault + + issue ccc448a6bfd59cbd +} -body { + namespace eval n1 { + namespace ensemble create + namespace export * + proc p1 args {error success} + } + # segmentation fault only occurs in the non-byte-compiled path, so avoid + # byte compilation + set cmd {namespace eva n1 {[namespace parent]::n1 p1}} + {*}$cmd +} -returnCodes error -result success + + test namespace-43.1 {ensembles: dict-driven} { namespace eval ns { namespace export x* -- cgit v0.12 From b6f6b92ae4dced8a01b700e78265a95daa0a98cd Mon Sep 17 00:00:00 2001 From: pooryorick Date: Thu, 2 Sep 2021 21:14:19 +0000 Subject: Silence warning in fix for [ccc448a6bfd5], namespace ensemble subcommand name prefix matching and a subsequent error results in a segmentation fault --- generic/tclEnsemble.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/generic/tclEnsemble.c b/generic/tclEnsemble.c index 799c645..b55489b 100644 --- a/generic/tclEnsemble.c +++ b/generic/tclEnsemble.c @@ -2244,7 +2244,7 @@ TclFetchEnsembleRoot( *objcPtr = objc + iPtr->ensembleRewrite.numRemovedObjs - iPtr->ensembleRewrite.numInsertedObjs; if (iPtr->ensembleRewrite.sourceObjs[0] == NULL) { - sourceObjs = iPtr->ensembleRewrite.sourceObjs[1]; + sourceObjs = (Tcl_Obj *const *)iPtr->ensembleRewrite.sourceObjs[1]; } else { sourceObjs = iPtr->ensembleRewrite.sourceObjs; } -- cgit v0.12 From 962e5966f927e1a98e7ca5255cad96c6efc45617 Mon Sep 17 00:00:00 2001 From: pooryorick Date: Thu, 2 Sep 2021 22:15:34 +0000 Subject: Update code comments. --- generic/tclEnsemble.c | 268 +++++++++++++++++++++++--------------------------- generic/tclExecute.c | 2 +- generic/tclIndexObj.c | 4 +- generic/tclNamesp.c | 10 +- generic/tclObj.c | 13 +-- 5 files changed, 137 insertions(+), 160 deletions(-) diff --git a/generic/tclEnsemble.c b/generic/tclEnsemble.c index b55489b..bf3196d 100644 --- a/generic/tclEnsemble.c +++ b/generic/tclEnsemble.c @@ -70,8 +70,8 @@ enum EnsConfigOpts { }; /* - * This structure defines a Tcl object type that contains a reference to an - * ensemble subcommand (e.g. the "length" in [string length ab]). It is used + * ensembleCmdType is a Tcl object type that contains a reference to an + * ensemble subcommand, e.g. the "length" in [string length ab]. It is used * to cache the mapping between the subcommand itself and the real command * that implements it. */ @@ -1704,7 +1704,7 @@ NsEnsembleImplementationCmdNR( size_t subIdx; /* - * Must recheck objc, since numParameters might have changed. Cf. test + * Must recheck objc since numParameters might have changed. See test * namespace-53.9. */ @@ -1712,7 +1712,7 @@ NsEnsembleImplementationCmdNR( subIdx = 1 + ensemblePtr->numParameters; if ((size_t)objc < subIdx + 1) { /* - * We don't have a subcommand argument. Make error message. + * No subcommand argument. Make error message. */ Tcl_DString buf; /* Message being built */ @@ -1744,18 +1744,16 @@ NsEnsembleImplementationCmdNR( } /* - * Determine if the table of subcommands is right. If so, we can just look - * up in there and go straight to dispatch. + * If the table of subcommands is valid just lookup up the command there + * and go to dispatch. */ subObj = objv[subIdx]; if (ensemblePtr->epoch == ensemblePtr->nsPtr->exportLookupEpoch) { /* - * Table of subcommands is still valid; therefore there might be a - * valid cache of discovered information which we can reuse. Do the - * check here, and if we're still valid, we can jump straight to the - * part where we do the invocation of the subcommand. + * Table of subcommands is still valid so if the internal representtion + * is an ensembleCmd, just call it. */ EnsembleCmdRep *ensembleCmd; @@ -1777,8 +1775,8 @@ NsEnsembleImplementationCmdNR( } /* - * Look in the hashtable for the subcommand name; this is the fastest way - * of all if there is no cache in operation. + * Look in the hashtable for the named subcommand. This is the fastest + * path if there is no cache in operation. */ hPtr = Tcl_FindHashEntry(&ensemblePtr->subcommandTable, @@ -1786,26 +1784,25 @@ NsEnsembleImplementationCmdNR( if (hPtr != NULL) { /* - * Cache for later in the subcommand object. + * Cache ensemble in the subcommand object for later. */ MakeCachedEnsembleCommand(subObj, ensemblePtr, hPtr, NULL); } else if (!(ensemblePtr->flags & TCL_ENSEMBLE_PREFIX)) { /* - * Could not map, no prefixing, go to unknown/error handling. + * Could not map. No prefixing. Go to unknown/error handling. */ goto unknownOrAmbiguousSubcommand; } else { /* - * If we've not already confirmed the command with the hash as part of - * building our export table, we need to scan the sorted array for - * matches. + * If the command isn't yet confirmed with the hash as part of building + * the export table, scan the sorted array for matches. */ - const char *subcmdName; /* Name of the subcommand, or unique prefix of - * it (will be an error for a non-unique - * prefix). */ + const char *subcmdName; /* Name of the subcommand or unique prefix of + * it (a non-unique prefix produces an error). + */ char *fullName = NULL; /* Full name of the subcommand. */ size_t stringLength, i; size_t tableLength = ensemblePtr->subcommandTable.numEntries; @@ -1820,10 +1817,10 @@ NsEnsembleImplementationCmdNR( if (cmp == 0) { if (fullName != NULL) { /* - * Since there's never the exact-match case to worry about - * (hash search filters this), getting here indicates that - * our subcommand is an ambiguous prefix of (at least) two - * exported subcommands, which is an error case. + * Hash search filters out the exact-match case, so getting + * here indicates that the subcommand is an ambiguous + * prefix of at least two exported subcommands, which is an + * error case. */ goto unknownOrAmbiguousSubcommand; @@ -1831,9 +1828,8 @@ NsEnsembleImplementationCmdNR( fullName = ensemblePtr->subcommandArrayPtr[i]; } else if (cmp < 0) { /* - * Because we are searching a sorted table, we can now stop - * searching because we have gone past anything that could - * possibly match. + * The table is sorted so stop searching because a match would + * have been found already. */ break; @@ -1841,7 +1837,7 @@ NsEnsembleImplementationCmdNR( } if (fullName == NULL) { /* - * The subcommand is not a prefix of anything, so bail out! + * The subcommand is not a prefix of anything. Bail out! */ goto unknownOrAmbiguousSubcommand; @@ -1871,21 +1867,19 @@ NsEnsembleImplementationCmdNR( runResultingSubcommand: /* - * Do the real work of execution of the subcommand by building an array of - * objects (note that this is potentially not the same length as the - * number of arguments to this ensemble command), populating it and then - * feeding it back through the main command-lookup engine. In theory, we - * could look up the command in the namespace ourselves, as we already - * have the namespace in which it is guaranteed to exist, + * Execute the subcommand by populating an array of objects, which might + * not be the same length as the number of arguments to this ensemble + * command, and then handing it to the main command-lookup engine. In + * theory, the command could be looked up right here using the namespace in + * which it is guaranteed to exist, * * ((Q: That's not true if the -map option is used, is it?)) * - * but we don't do that (the cacheing of the command object used should - * help with that.) + * but don't do that because cacheing of the command object should help. */ { - Tcl_Obj *copyPtr; /* The actual list of words to dispatch to. + Tcl_Obj *copyPtr; /* The list of words to dispatch on. * Will be freed by the dispatch engine. */ Tcl_Obj **copyObjv; int copyObjc, prefixObjc; @@ -1908,8 +1902,8 @@ NsEnsembleImplementationCmdNR( TclDecrRefCount(prefixObj); /* - * Record what arguments the script sent in so that things like - * Tcl_WrongNumArgs can give the correct error message. Parameters + * Record the words of the command as given so that routines like + * Tcl_WrongNumArgs can produce the correct error message. Parameters * count both as inserted and removed arguments. */ @@ -1931,10 +1925,9 @@ NsEnsembleImplementationCmdNR( unknownOrAmbiguousSubcommand: /* - * Have not been able to match the subcommand asked for with a real - * subcommand that we export. See whether a handler has been registered - * for dealing with this situation. Will only call (at most) once for any - * particular ensemble invocation. + * The named subcommand did not match any exported command. If there is a + * handler registered unknown subcommands, call it, but not more than once + * for this call. */ if (ensemblePtr->unknownHandler != NULL && reparseCount++ < 1) { @@ -1950,10 +1943,10 @@ NsEnsembleImplementationCmdNR( } /* - * We cannot determine what subcommand to hand off to, so generate a - * (standard) failure message. Note the one odd case compared with - * standard ensemble-like command, which is where a namespace has no - * exported commands at all... + * Could not find a routine for the named subcommand so generate a standard + * failure message. The one odd case compared with a standard + * ensemble-like command is where a namespace has no exported commands at + * all... */ Tcl_ResetResult(interp); @@ -2000,8 +1993,8 @@ TclClearRootEnsemble( * * TclInitRewriteEnsemble -- * - * Applies a rewrite of arguments so that an ensemble subcommand will - * report error messages correctly for the overall command. + * Applies a rewrite of arguments so that an ensemble subcommand + * correctly reports any error messages for the overall command. * * Results: * Whether this is the first rewrite applied, a value which must be @@ -2079,7 +2072,7 @@ TclResetRewriteEnsemble( * * TclSpellFix -- * - * Record a spelling correction that needs making in the generation of + * Records a spelling correction that needs making in the generation of * the WrongNumArgs usage message. * * Results: @@ -2144,8 +2137,8 @@ TclSpellFix( if (badIdx < iPtr->ensembleRewrite.numInsertedObjs) { /* - * Misspelled value was inserted. We cannot directly jump to the bad - * value, but have to search. + * Misspelled value was inserted. Cannot directly jump to the bad + * value. Must search. */ idx = 1; @@ -2257,22 +2250,22 @@ TclFetchEnsembleRoot( /* * ---------------------------------------------------------------------- * - * EnsmebleUnknownCallback -- + * EnsembleUnknownCallback -- * - * Helper for the ensemble engine that handles the procesing of unknown - * callbacks. See the user documentation of the ensemble unknown handler - * for details; this function is only ever called when such a function is - * defined, and is only ever called once per ensemble dispatch (i.e. if a - * reparse still fails, this isn't called again). + * Helper for the ensemble engine. Calls the routine registered for + * "ensemble unknown" case. See the user documentation of the + * ensemble unknown handler for details. Only called when such a + * function is defined, and is only called once per ensemble dispatch. + * I.e. even if a reparse still fails, this isn't called again. * * Results: * TCL_OK - *prefixObjPtr contains the command words to dispatch * to. - * TCL_CONTINUE - Need to reparse (*prefixObjPtr is invalid). - * TCL_ERROR - Something went wrong! Error message in interpreter. + * TCL_CONTINUE - Need to reparse, i.e. *prefixObjPtr is invalid + * TCL_ERROR - Something went wrong. Error message in interpreter. * * Side effects: - * Calls the Tcl interpreter, so arbitrary. + * Arbitrary, due to evaluation of script provided by client. * * ---------------------------------------------------------------------- */ @@ -2289,7 +2282,7 @@ EnsembleUnknownCallback( Tcl_Obj **paramv, *unknownCmd, *ensObj; /* - * Create the unknown command callback to determine what to do. + * Create the "unknown" command callback to determine what to do. */ unknownCmd = Tcl_DuplicateObj(ensemblePtr->unknownHandler); @@ -2303,10 +2296,9 @@ EnsembleUnknownCallback( Tcl_IncrRefCount(unknownCmd); /* - * Now call the unknown handler. (We don't bother NRE-enabling this; deep - * recursing through unknown handlers is horribly perverse.) Note that it - * is always an error for an unknown handler to delete its ensemble; don't - * do that! + * Call the "unknown" handler. No attempt to NRE-enable this as deep + * recursion through unknown handlers is perverse. It is always an error + * for an unknown handler to delete its ensemble. Don't do that. */ Tcl_Preserve(ensemblePtr); @@ -2324,10 +2316,9 @@ EnsembleUnknownCallback( Tcl_Release(ensemblePtr); /* - * If we succeeded, we should either have a list of words that form the - * command to be executed, or an empty list. In the empty-list case, the - * ensemble is believed to be updated so we should ask the ensemble engine - * to reparse the original command. + * On success the result is a list of words that form the command to be + * executed. If the list is empty, the ensemble should have been updated, + * so ask the ensemble engine to reparse the original command. */ if (result == TCL_OK) { @@ -2336,11 +2327,7 @@ EnsembleUnknownCallback( TclDecrRefCount(unknownCmd); Tcl_ResetResult(interp); - /* - * Namespace is still there. Check if the result is a valid list. If - * it is, and it is non-empty, that list is what we are using as our - * replacement. - */ + /* A non-empty list is the replacement command. */ if (TclListObjLength(interp, *prefixObjPtr, &prefixObjc) != TCL_OK) { TclDecrRefCount(*prefixObjPtr); @@ -2353,7 +2340,7 @@ EnsembleUnknownCallback( } /* - * Namespace alive & empty result => reparse. + * Empty result => reparse. */ TclDecrRefCount(*prefixObjPtr); @@ -2361,7 +2348,7 @@ EnsembleUnknownCallback( } /* - * Oh no! An exceptional result. Convert to an error. + * Convert exceptional result to an error. */ if (!Tcl_InterpDeleted(interp)) { @@ -2401,16 +2388,16 @@ EnsembleUnknownCallback( * * MakeCachedEnsembleCommand -- * - * Cache what we've computed so far; it's not nice to repeatedly copy - * strings about. Note that to do this, we start by deleting any old - * representation that there was (though if it was an out of date - * ensemble rep, we can skip some of the deallocation process.) + * Caches what has been computed so far to minimize string copying. + * Starts by deleting any existing representation but reusing the existing + * structure if it is an ensembleCmd. * * Results: - * None + * None. * * Side effects: - * Alters the internal representation of the first object parameter. + * Converts the internal representation of the given object to an + * ensembleCmd. * *---------------------------------------------------------------------- */ @@ -2432,8 +2419,7 @@ MakeCachedEnsembleCommand( } } else { /* - * Kill the old internal rep, and replace it with a brand new one of - * our own. + * Replace any old internal representation with a new one. */ ensembleCmd = (EnsembleCmdRep *)Tcl_Alloc(sizeof(EnsembleCmdRep)); @@ -2459,17 +2445,16 @@ MakeCachedEnsembleCommand( * * DeleteEnsembleConfig -- * - * Destroys the data structure used to represent an ensemble. This is - * called when the ensemble's command is deleted (which happens - * automatically if the ensemble's namespace is deleted.) Maintainers - * should note that ensembles should be deleted by deleting their - * commands. + * Destroys the data structure used to represent an ensemble. Called when + * the procedure for the ensemble is deleted, which happens automatically + * if the namespace for the ensemble is deleted. Deleting the procedure + * for an ensemble is the right way to initiate cleanup. * * Results: * None. * * Side effects: - * Memory is (eventually) deallocated. + * Memory is eventually deallocated. * *---------------------------------------------------------------------- */ @@ -2501,10 +2486,7 @@ DeleteEnsembleConfig( EnsembleConfig *ensemblePtr = (EnsembleConfig *)clientData; Namespace *nsPtr = ensemblePtr->nsPtr; - /* - * Unlink from the ensemble chain if it has not been marked as having been - * done already. - */ + /* Unlink from the ensemble chain if it not already marked as unlinked. */ if (ensemblePtr->next != ensemblePtr) { EnsembleConfig *ensPtr = (EnsembleConfig *) nsPtr->ensembles; @@ -2530,7 +2512,7 @@ DeleteEnsembleConfig( ensemblePtr->flags |= ENSEMBLE_DEAD; /* - * Kill the pointer-containing fields. + * Release the fields that contain pointers. */ ClearTable(ensemblePtr); @@ -2548,10 +2530,9 @@ DeleteEnsembleConfig( } /* - * Arrange for the structure to be reclaimed. Note that this is complex - * because we have to make sure that we can react sensibly when an - * ensemble is deleted during the process of initialising the ensemble - * (especially the unknown callback.) + * Arrange for the structure to be reclaimed. This is complex because it is + * necessary to react sensibly when an ensemble is deleted during its + * initialisation, particularly in the case of an unknown callback. */ Tcl_EventuallyFree(ensemblePtr, TCL_DYNAMIC); @@ -2562,11 +2543,11 @@ DeleteEnsembleConfig( * * BuildEnsembleConfig -- * - * Create the internal data structures that describe how an ensemble - * looks, being a hash mapping from the full command name to the Tcl list - * that describes the implementation prefix words, and a sorted array of - * all the full command names to allow for reasonably efficient - * unambiguous prefix handling. + * Creates the internal data structures that describe how an ensemble + * looks. The structures are a hash map from the full command name to the + * Tcl list that describes the implementation prefix words, and a sorted + * array of all the full command names to allow for reasonably efficient + * handling of an unambiguous prefix. * * Results: * None. @@ -2574,7 +2555,7 @@ DeleteEnsembleConfig( * Side effects: * Reallocates and rebuilds the hash table and array stored at the * ensemblePtr argument. For large ensembles or large namespaces, this is - * a potentially expensive operation. + * may be an expensive operation. * *---------------------------------------------------------------------- */ @@ -2583,9 +2564,8 @@ static void BuildEnsembleConfig( EnsembleConfig *ensemblePtr) { - Tcl_HashSearch search; /* Used for scanning the set of commands in - * the namespace that backs up this - * ensemble. */ + Tcl_HashSearch search; /* Used for scanning the commands in + * the namespace for this ensemble. */ size_t i, j; int isNew; Tcl_HashTable *hash = &ensemblePtr->subcommandTable; @@ -2603,13 +2583,13 @@ BuildEnsembleConfig( /* * There is a list of exactly what subcommands go in the table. - * Must determine the target for each. + * Determine the target for each. */ Tcl_ListObjGetElements(NULL, subList, &subc, &subv); if (subList == mapDict) { /* - * Strange case where explicit list of subcommands is same value + * Unusual case where explicit list of subcommands is same value * as the dict mapping to targets. */ @@ -2658,10 +2638,10 @@ BuildEnsembleConfig( } /* - * target was not in the dictionary so map onto the namespace. - * Note in this case that we do not guarantee that the command - * is actually there; that is the programmer's responsibility - * (or [::unknown] of course). + * Target was not in the dictionary. Map onto the namespace. + * In this case there is no guarantee that the command + * is actually there. It is the responsibility of the + * programmer (or [::unknown] of course) to provide the procedure. */ cmdObj = Tcl_NewStringObj(name, -1); @@ -2672,9 +2652,9 @@ BuildEnsembleConfig( } } else if (mapDict) { /* - * No subcmd list, but we do have a mapping dictionary so we should - * use the keys of that. Convert the dictionary's contents into the - * form required for the ensemble's internal hashtable. + * No subcmd list, but there is a mapping dictionary, so + * use the keys of that. Convert the contents of the dictionary into the + * form required for the internal hashtable of the ensemble. */ Tcl_DictSearch dictSearch; @@ -2693,18 +2673,15 @@ BuildEnsembleConfig( } } else { /* - * Discover what commands are actually exported by the namespace. - * What we have is an array of patterns and a hash table whose keys - * are the command names exported by the namespace (the contents do - * not matter here.) We must find out what commands are actually - * exported by filtering each command in the namespace against each of - * the patterns in the export list. Note that we use an intermediate - * hash table to make memory management easier, and because that makes - * exact matching far easier too. + * Use the array of patterns and the hash table whose keys are the + * commands exported by the namespace. The corresponding values do not + * matter here. Filter the commands in the namespace against the + * patterns in the export list to find out what commands are actually + * exported. Use an intermediate hash table to make memory management + * easier and to make exact matching much easier. * - * Suggestion for future enhancement: compute the unique prefixes and - * place them in the hash too, which should make for even faster - * matching. + * Suggestion for future enhancement: Compute the unique prefixes and + * place them in the hash too for even faster matching. */ hPtr = Tcl_FirstHashEntry(&ensemblePtr->nsPtr->cmdTable, &search); @@ -2747,24 +2724,24 @@ BuildEnsembleConfig( } /* - * Create a sorted array of all subcommands in the ensemble; hash tables + * Create a sorted array of all subcommands in the ensemble. Hash tables * are all very well for a quick look for an exact match, but they can't - * determine things like whether a string is a prefix of another (not - * without lots of preparation anyway) and they're no good for when we're - * generating the error message either. + * determine things like whether a string is a prefix of another, at least + * not without a lot of preparation, and they're not useful for generating + * the error message either. * - * We do this by filling an array with the names (we use the hash keys - * directly to save a copy, since any time we change the array we change - * the hash too, and vice versa) and running quicksort over the array. + * Do this by filling an array with the names: Use the hash keys + * directly to save a copy since any time we change the array we change + * the hash too, and vice versa, and run quicksort over the array. */ ensemblePtr->subcommandArrayPtr = (char **)Tcl_Alloc(sizeof(char *) * hash->numEntries); /* - * Fill array from both ends as this makes us less likely to end up with - * performance problems in qsort(), which is good. Note that doing this - * makes this code much more opaque, but the naive alternatve: + * Fill the array from both ends as this reduces the likelihood of + * performance problems in qsort(). This makes this code much more opaque, + * but the naive alternatve: * * for (hPtr=Tcl_FirstHashEntry(hash,&search),i=0 ; * hPtr!=NULL ; hPtr=Tcl_NextHashEntry(&search),i++) { @@ -2772,11 +2749,11 @@ BuildEnsembleConfig( * } * * can produce long runs of precisely ordered table entries when the - * commands in the namespace are declared in a sorted fashion (an ordering - * some people like) and the hashing functions (or the command names - * themselves) are fairly unfortunate. By filling from both ends, it - * requires active malice (and probably a debugger) to get qsort() to have - * awful runtime behaviour. + * commands in the namespace are declared in a sorted fashion, which is an + * ordering some people like, and the hashing functions or the command + * names themselves are fairly unfortunate. Filling from both ends means + * that it requires active malice, and probably a debugger, to get qsort() + * to have awful runtime behaviour. */ i = 0; @@ -2802,8 +2779,7 @@ BuildEnsembleConfig( * * NsEnsembleStringOrder -- * - * Helper function to compare two pointers to two strings for use with - * qsort(). + * Helper to for uset with sort() that compares two string pointers. * * Results: * -1 if the first string is smaller, 1 if the second string is smaller, diff --git a/generic/tclExecute.c b/generic/tclExecute.c index b0a73b4..f0e6cac 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -2749,7 +2749,7 @@ TEBCresume( pc += 1; /* yield next instruction */ TEBC_YIELD(); - /* add TEBCResume for object at top of stack */ + /* add TEBCresume for object at top of stack */ return TclNRExecuteByteCode(interp, TclCompileObj(interp, OBJ_AT_TOS, NULL, 0)); diff --git a/generic/tclIndexObj.c b/generic/tclIndexObj.c index f81f0b3..41453a5 100644 --- a/generic/tclIndexObj.c +++ b/generic/tclIndexObj.c @@ -826,7 +826,7 @@ Tcl_WrongNumArgs( objc -= toSkip; /* - * We assume no object is of index type. + * Assume no object is of index type. */ for (i=0 ; ierrorInfo/errorStack fields to describe the + * Invoked after an error occurs in an interpreter. + * Adds information to iPtr->errorInfo/errorStack fields to describe the * command that was being executed when the error occurred. When pc and * tosPtr are non-NULL, conveying a bytecode execution "inner context", - * and the offending instruction is suitable, that inner context is + * and the offending instruction is suitable, and that inner context is * recorded in errorStack. * * Results: @@ -4938,8 +4938,8 @@ TclLogCommandInfo( if (iPtr->flags & ERR_ALREADY_LOGGED) { /* - * Someone else has already logged error information for this command; - * we shouldn't add anything more. + * Someone else has already logged error information for this command. + * Don't add anything more. */ return; diff --git a/generic/tclObj.c b/generic/tclObj.c index 3130bdd..f264bcd 100644 --- a/generic/tclObj.c +++ b/generic/tclObj.c @@ -1857,12 +1857,11 @@ Tcl_HasStringRep( * * Tcl_StoreIntRep -- * - * This function is called to set the object's internal - * representation to match a particular type. + * Called to set the object's internal representation to match a + * particular type. * - * It is the caller's responsibility to guarantee that - * the value of the submitted IntRep is in agreement with - * the value of any existing string rep. + * It is the caller's resonsibility to ensure that the given IntRep is + * appropriate for the existing string. * * Results: * None. @@ -1880,7 +1879,9 @@ Tcl_StoreIntRep( const Tcl_ObjType *typePtr, /* New type for the object */ const Tcl_ObjIntRep *irPtr) /* New IntRep for the object */ { - /* Clear out any existing IntRep ( "shimmer" ) */ + /* Clear out any existing IntRep. This is the point where shimmering, i.e. + * repeated alteration of the type of the internal representation, may + * occur. */ TclFreeIntRep(objPtr); /* When irPtr == NULL, just leave objPtr with no IntRep for typePtr */ -- cgit v0.12 From 140696125600f86b585afee9b8b5f033602d5f20 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 19 Oct 2021 15:23:51 +0000 Subject: We can now assume that TCL_MAJOR_VERSION == 9 --- generic/tclObj.c | 4 ---- generic/tclZipfs.c | 20 -------------------- generic/tclZlib.c | 3 --- 3 files changed, 27 deletions(-) diff --git a/generic/tclObj.c b/generic/tclObj.c index fe4feca..9a3e3e4 100644 --- a/generic/tclObj.c +++ b/generic/tclObj.c @@ -1716,11 +1716,7 @@ Tcl_GetStringFromObj( } } if (lengthPtr != NULL) { -#if TCL_MAJOR_VERSION > 8 *lengthPtr = objPtr->length; -#else - *lengthPtr = ((size_t)(unsigned)(objPtr->length + 1)) - 1; -#endif } return objPtr->bytes; } diff --git a/generic/tclZipfs.c b/generic/tclZipfs.c index 1ac5578..ba63f01 100644 --- a/generic/tclZipfs.c +++ b/generic/tclZipfs.c @@ -358,10 +358,6 @@ static int ZipChannelClose(void *instanceData, static Tcl_DriverGetHandleProc ZipChannelGetFile; static int ZipChannelRead(void *instanceData, char *buf, int toRead, int *errloc); -#if !defined(TCL_NO_DEPRECATED) && (TCL_MAJOR_VERSION < 9) -static int ZipChannelSeek(void *instanceData, long offset, - int mode, int *errloc); -#endif static long long ZipChannelWideSeek(void *instanceData, long long offset, int mode, int *errloc); static void ZipChannelWatchChannel(void *instanceData, @@ -417,11 +413,7 @@ static Tcl_ChannelType ZipChannelType = { TCL_CLOSE2PROC, /* Close channel, clean instance data */ ZipChannelRead, /* Handle read request */ ZipChannelWrite, /* Handle write request */ -#if !defined(TCL_NO_DEPRECATED) && (TCL_MAJOR_VERSION < 9) - ZipChannelSeek, /* Move location of access point, NULL'able */ -#else NULL, /* Move location of access point, NULL'able */ -#endif NULL, /* Set options, NULL'able */ NULL, /* Get options, NULL'able */ ZipChannelWatchChannel, /* Initialize notifier */ @@ -4227,18 +4219,6 @@ ZipChannelWideSeek( info->numRead = (size_t) offset; return info->numRead; } - -#if !defined(TCL_NO_DEPRECATED) && (TCL_MAJOR_VERSION < 9) -static int -ZipChannelSeek( - void *instanceData, - long offset, - int mode, - int *errloc) -{ - return ZipChannelWideSeek(instanceData, offset, mode, errloc); -} -#endif /* *------------------------------------------------------------------------- diff --git a/generic/tclZlib.c b/generic/tclZlib.c index 85b4dc3..da88c5f 100644 --- a/generic/tclZlib.c +++ b/generic/tclZlib.c @@ -3969,9 +3969,6 @@ TclZlibInit( * Formally provide the package as a Tcl built-in. */ -#if !defined(TCL_NO_DEPRECATED) && (TCL_MAJOR_VERSION < 9) - Tcl_PkgProvideEx(interp, "zlib", TCL_ZLIB_VERSION, NULL); -#endif return Tcl_PkgProvideEx(interp, "tcl::zlib", TCL_ZLIB_VERSION, NULL); } -- cgit v0.12 From db1bea3d4bbcb4c438e5e8bfcd0c66e6a2a2cac7 Mon Sep 17 00:00:00 2001 From: dgp Date: Sat, 6 Nov 2021 15:26:38 +0000 Subject: Repair a whitespace merge error. --- generic/tcl.h | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/generic/tcl.h b/generic/tcl.h index e41364b..c3db670 100644 --- a/generic/tcl.h +++ b/generic/tcl.h @@ -937,7 +937,7 @@ typedef struct Tcl_DString { #define TCL_LINK_CHARS 15 #define TCL_LINK_BINARY 16 #define TCL_LINK_READ_ONLY 0x80 - + /* *---------------------------------------------------------------------------- * Forward declarations of Tcl_HashTable and related types. -- cgit v0.12 From 25d340d9d8ab61af8ba8f32350c06cc87e418be0 Mon Sep 17 00:00:00 2001 From: dgp Date: Sat, 6 Nov 2021 17:10:19 +0000 Subject: Repair faulty conflict resolution from some time back. --- generic/tclZipfs.c | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/generic/tclZipfs.c b/generic/tclZipfs.c index 7fb30fe..d9cb4ba 100644 --- a/generic/tclZipfs.c +++ b/generic/tclZipfs.c @@ -214,7 +214,7 @@ typedef struct ZipFile { typedef struct ZipEntry { char *name; /* The full pathname of the virtual file */ ZipFile *zipFilePtr; /* The ZIP file holding this virtual file */ - long long offset; /* Data offset into memory mapped ZIP file */ + size_t offset; /* Data offset into memory mapped ZIP file */ int numBytes; /* Uncompressed size of the virtual file */ int numCompressedBytes; /* Compressed size of the virtual file */ int compressMethod; /* Compress method */ @@ -4395,7 +4395,7 @@ ZipChannelOpen( * Wrap the ZipChannel into a Tcl_Channel. */ - sprintf(cname, "zipfs_%" TCL_LL_MODIFIER "x_%d", z->offset, + sprintf(cname, "zipfs_%" TCL_Z_MODIFIER "x_%d", z->offset, ZipFS.idCount++); z->zipFilePtr->numOpen++; Unlock(); -- cgit v0.12 From d5ad600360d03a4a6d07f54c1521cc9d90659ae8 Mon Sep 17 00:00:00 2001 From: dgp Date: Sat, 6 Nov 2021 17:38:17 +0000 Subject: Clean up another old failed merge. --- generic/tclTestObj.c | 19 ++++++++++--------- 1 file changed, 10 insertions(+), 9 deletions(-) diff --git a/generic/tclTestObj.c b/generic/tclTestObj.c index 2d94e03..654208d 100644 --- a/generic/tclTestObj.c +++ b/generic/tclTestObj.c @@ -1167,6 +1167,7 @@ TeststringobjCmd( { Tcl_UniChar *unicode; int varIndex, option, i, length; + size_t size; #define MAX_STRINGS 11 const char *index, *string, *strings[MAX_STRINGS+1]; String *strPtr; @@ -1299,12 +1300,12 @@ TeststringobjCmd( * is "copy on write". */ - string = Tcl_GetStringFromObj(objv[3], &length); + string = Tcl_GetStringFromObj(objv[3], &size); if ((varPtr[varIndex] != NULL) && !Tcl_IsShared(varPtr[varIndex])) { - Tcl_SetStringObj(varPtr[varIndex], string, length); + Tcl_SetStringObj(varPtr[varIndex], string, size); } else { - SetVarToObj(varPtr, varIndex, Tcl_NewStringObj(string, length)); + SetVarToObj(varPtr, varIndex, Tcl_NewStringObj(string, size)); } Tcl_SetObjResult(interp, varPtr[varIndex]); break; @@ -1356,18 +1357,18 @@ TeststringobjCmd( SetVarToObj(varPtr, varIndex, Tcl_DuplicateObj(varPtr[varIndex])); } - string = Tcl_GetStringFromObj(varPtr[varIndex], &length); + string = Tcl_GetStringFromObj(varPtr[varIndex], &size); if (Tcl_GetIntFromObj(interp, objv[3], &i) != TCL_OK) { return TCL_ERROR; } - if ((i < 0) || (i > length)) { + if ((i < 0) || ((size_t)i > size)) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "index value out of range", -1)); return TCL_ERROR; } - Tcl_AppendToObj(varPtr[varIndex], string + i, length - i); + Tcl_AppendToObj(varPtr[varIndex], string + i, size - i); Tcl_SetObjResult(interp, varPtr[varIndex]); break; case 11: /* appendself2 */ @@ -1387,18 +1388,18 @@ TeststringobjCmd( SetVarToObj(varPtr, varIndex, Tcl_DuplicateObj(varPtr[varIndex])); } - unicode = Tcl_GetUnicodeFromObj(varPtr[varIndex], &length); + unicode = Tcl_GetUnicodeFromObj(varPtr[varIndex], &size); if (Tcl_GetIntFromObj(interp, objv[3], &i) != TCL_OK) { return TCL_ERROR; } - if ((i < 0) || (i > length)) { + if ((i < 0) || ((size_t)i > size)) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "index value out of range", -1)); return TCL_ERROR; } - TclAppendUnicodeToObj(varPtr[varIndex], unicode + i, length - i); + TclAppendUnicodeToObj(varPtr[varIndex], unicode + i, size - i); Tcl_SetObjResult(interp, varPtr[varIndex]); break; } -- cgit v0.12 From 6574848ee46baa0fae419a52e6aa1b56dee16867 Mon Sep 17 00:00:00 2001 From: dgp Date: Sat, 6 Nov 2021 17:55:48 +0000 Subject: Eliminate more branch diffs with trunk that have no apparent connection to TIP 568. --- generic/tclFCmd.c | 2 +- generic/tclObj.c | 25 ++++++++++++++----------- generic/tclStrToD.c | 10 +++++----- generic/tclStringObj.c | 10 +++++----- 4 files changed, 25 insertions(+), 22 deletions(-) diff --git a/generic/tclFCmd.c b/generic/tclFCmd.c index 23942db..4e37574 100644 --- a/generic/tclFCmd.c +++ b/generic/tclFCmd.c @@ -1541,7 +1541,7 @@ TclFileTempDirCmd( } if (objc > 1) { - size_t length; + int length; Tcl_Obj *templateObj = objv[1]; const char *string = Tcl_GetStringFromObj(templateObj, &length); const int onWindows = (tclPlatform == TCL_PLATFORM_WINDOWS); diff --git a/generic/tclObj.c b/generic/tclObj.c index c4d636a..e67dfab 100644 --- a/generic/tclObj.c +++ b/generic/tclObj.c @@ -1620,7 +1620,7 @@ Tcl_GetString( /* *---------------------------------------------------------------------- * - * Tcl_GetStringFromObj -- + * Tcl_GetStringFromObj/TclGetStringFromObj -- * * Returns the string representation's byte array pointer and length for * an object. @@ -1640,12 +1640,12 @@ Tcl_GetString( *---------------------------------------------------------------------- */ -#undef Tcl_GetStringFromObj +#undef TclGetStringFromObj char * -Tcl_GetStringFromObj( +TclGetStringFromObj( Tcl_Obj *objPtr, /* Object whose string rep byte pointer should * be returned. */ - size_t *lengthPtr) /* If non-NULL, the location where the string + int *lengthPtr) /* If non-NULL, the location where the string * rep's byte array length should * be stored. * If NULL, no length is stored. */ { @@ -1675,16 +1675,17 @@ Tcl_GetStringFromObj( } } if (lengthPtr != NULL) { - *lengthPtr = objPtr->length; + *lengthPtr = (objPtr->length < INT_MAX)? objPtr->length: INT_MAX; } return objPtr->bytes; } +#undef Tcl_GetStringFromObj char * -TclGetStringFromObj( +Tcl_GetStringFromObj( Tcl_Obj *objPtr, /* Object whose string rep byte pointer should * be returned. */ - int *lengthPtr) /* If non-NULL, the location where the string + size_t *lengthPtr) /* If non-NULL, the location where the string * rep's byte array length should * be stored. * If NULL, no length is stored. */ { @@ -1706,7 +1707,7 @@ TclGetStringFromObj( objPtr->typePtr->name); } objPtr->typePtr->updateStringProc(objPtr); - if (objPtr->bytes == NULL || objPtr->length == TCL_INDEX_NONE + if (objPtr->bytes == NULL || objPtr->bytes[objPtr->length] != '\0') { Tcl_Panic("UpdateStringProc for type '%s' " "failed to create a valid string rep", @@ -1714,11 +1715,12 @@ TclGetStringFromObj( } } if (lengthPtr != NULL) { - *lengthPtr = (objPtr->length < INT_MAX)? objPtr->length: INT_MAX; + *lengthPtr = objPtr->length; } return objPtr->bytes; } + /* *---------------------------------------------------------------------- * @@ -2484,6 +2486,7 @@ Tcl_GetIntFromObj( return TCL_OK; #endif } + /* *---------------------------------------------------------------------- @@ -3909,8 +3912,8 @@ TclHashObjKey( void *keyPtr) /* Key from which to compute hash value. */ { Tcl_Obj *objPtr = (Tcl_Obj *)keyPtr; - const char *string = TclGetString(objPtr); - size_t length = objPtr->length; + size_t length; + const char *string = Tcl_GetStringFromObj(objPtr, &length); TCL_HASH_TYPE result = 0; /* diff --git a/generic/tclStrToD.c b/generic/tclStrToD.c index dfadf74..c428552 100644 --- a/generic/tclStrToD.c +++ b/generic/tclStrToD.c @@ -5190,23 +5190,23 @@ TclFormatNaN( #else union { double dv; - unsigned long long iv; + uint64_t iv; } bitwhack; bitwhack.dv = value; if (n770_fp) { bitwhack.iv = Nokia770Twiddle(bitwhack.iv); } - if (bitwhack.iv & (1ULL << 63)) { - bitwhack.iv &= ~ (1ULL << 63); + if (bitwhack.iv & (UINT64_C(1) << 63)) { + bitwhack.iv &= ~ (UINT64_C(1) << 63); *buffer++ = '-'; } *buffer++ = 'N'; *buffer++ = 'a'; *buffer++ = 'N'; - bitwhack.iv &= ((1ULL) << 51) - 1; + bitwhack.iv &= ((UINT64_C(1)) << 51) - 1; if (bitwhack.iv != 0) { - sprintf(buffer, "(%" TCL_LL_MODIFIER "x)", bitwhack.iv); + sprintf(buffer, "(%" PRIx64 ")", bitwhack.iv); } else { *buffer = '\0'; } diff --git a/generic/tclStringObj.c b/generic/tclStringObj.c index 3b65d99..dc47f3f 100644 --- a/generic/tclStringObj.c +++ b/generic/tclStringObj.c @@ -578,7 +578,7 @@ Tcl_GetUniChar( /* *---------------------------------------------------------------------- * - * Tcl_GetUnicodeFromObj -- + * Tcl_GetUnicodeFromObj/TclGetUnicodeFromObj -- * * Get the Unicode form of the String object with length. If the object * is not already a String object, it will be converted to one. If the @@ -596,10 +596,10 @@ Tcl_GetUniChar( #undef Tcl_GetUnicodeFromObj Tcl_UniChar * -Tcl_GetUnicodeFromObj( +TclGetUnicodeFromObj( Tcl_Obj *objPtr, /* The object to find the unicode string * for. */ - size_t *lengthPtr) /* If non-NULL, the location where the string + int *lengthPtr) /* If non-NULL, the location where the string * rep's unichar length should be stored. If * NULL, no length is stored. */ { @@ -620,10 +620,10 @@ Tcl_GetUnicodeFromObj( } Tcl_UniChar * -TclGetUnicodeFromObj( +Tcl_GetUnicodeFromObj( Tcl_Obj *objPtr, /* The object to find the unicode string * for. */ - int *lengthPtr) /* If non-NULL, the location where the string + size_t *lengthPtr) /* If non-NULL, the location where the string * rep's unichar length should be stored. If * NULL, no length is stored. */ { -- cgit v0.12 From 5a30c6515f08410a8064d8ecf30a152996e7d189 Mon Sep 17 00:00:00 2001 From: dgp Date: Sat, 6 Nov 2021 18:12:01 +0000 Subject: Eliminate more branch diffs. --- generic/tclStringObj.c | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/generic/tclStringObj.c b/generic/tclStringObj.c index dc47f3f..d66e0d0 100644 --- a/generic/tclStringObj.c +++ b/generic/tclStringObj.c @@ -614,7 +614,7 @@ TclGetUnicodeFromObj( } if (lengthPtr != NULL) { - *lengthPtr = stringPtr->numChars; + *lengthPtr = (int)stringPtr->numChars; } return stringPtr->unicode; } @@ -642,7 +642,7 @@ Tcl_GetUnicodeFromObj( } return stringPtr->unicode; } - + /* *---------------------------------------------------------------------- * -- cgit v0.12 From 084b76b92a5ec029401f05a4138c1559602c23e7 Mon Sep 17 00:00:00 2001 From: dgp Date: Sun, 7 Nov 2021 04:25:39 +0000 Subject: Updates to TIP 568 implementation for Tcl 9: Use the argument numBytes instead of length. Update the docs to the TIP spec. Clarify and simplify the code. --- doc/ByteArrObj.3 | 176 ++++++++++++++++++++++++++++++---------------- doc/binary.n | 11 +-- generic/tclBinary.c | 196 +++++++++++++++------------------------------------- generic/tclDecls.h | 4 +- 4 files changed, 181 insertions(+), 206 deletions(-) diff --git a/doc/ByteArrObj.3 b/doc/ByteArrObj.3 index 053401a..7fdaea6 100644 --- a/doc/ByteArrObj.3 +++ b/doc/ByteArrObj.3 @@ -4,87 +4,147 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.TH Tcl_ByteArrayObj 3 8.1 Tcl "Tcl Library Procedures" +.TH Tcl_ByteArrayObj 3 9.0 Tcl "Tcl Library Procedures" .so man.macros .BS .SH NAME -Tcl_NewByteArrayObj, Tcl_SetByteArrayObj, Tcl_GetByteArrayFromObj, Tcl_SetByteArrayLength \- manipulate Tcl values as a arrays of bytes +Tcl_NewByteArrayObj, Tcl_SetByteArrayObj, Tcl_GetBytesFromObj, Tcl_GetByteArrayFromObj, Tcl_SetByteArrayLength \- manipulate a Tcl value as an array of bytes .SH SYNOPSIS .nf \fB#include \fR .sp Tcl_Obj * -\fBTcl_NewByteArrayObj\fR(\fIbytes, length\fR) +\fBTcl_NewByteArrayObj\fR(\fIbytes, numBytes\fR) .sp void -\fBTcl_SetByteArrayObj\fR(\fIobjPtr, bytes, length\fR) +\fBTcl_SetByteArrayObj\fR(\fIobjPtr, bytes, numBytes\fR) .sp +.VS TIP568 unsigned char * -\fBTcl_GetByteArrayFromObj\fR(\fIobjPtr, lengthPtr\fR) +\fBTcl_GetBytesFromObj\fR(\fIinterp, objPtr, numBytesPtr\fR) +.VE TIP568 .sp unsigned char * -\fBTcl_SetByteArrayLength\fR(\fIobjPtr, length\fR) +\fBTcl_GetByteArrayFromObj\fR(\fIobjPtr, numBytesPtr\fR) +.sp +unsigned char * +\fBTcl_SetByteArrayLength\fR(\fIobjPtr, numBytes\fR) .SH ARGUMENTS -.AS "const unsigned char" *lengthPtr in/out +.AS "const unsigned char" *numBytesPtr in/out .AP "const unsigned char" *bytes in The array of bytes used to initialize or set a byte-array value. May be NULL -even if \fIlength\fR is non-zero. -.AP size_t length in -The length of the array of bytes. +even if \fInumBytes\fR is non-zero. +.AP size_t numBytes in +The number of bytes in the array. .AP Tcl_Obj *objPtr in/out -For \fBTcl_SetByteArrayObj\fR, this points to the value to be converted to -byte-array type. For \fBTcl_GetByteArrayFromObj\fR and -\fBTcl_SetByteArrayLength\fR, this points to the value from which to get -the byte-array value; if \fIobjPtr\fR does not already point to a byte-array -value, it will be converted to one. -.AP size_t | int *lengthPtr out -Filled with the length of the array of bytes in the value. -May be (int *)NULL when not used. +For \fBTcl_SetByteArrayObj\fR, this points to an unshared value to be +overwritten by a byte-array value. For \fBTcl_GetBytesFromObj\fR, +\fBTcl_GetByteArrayFromObj\fR and \fBTcl_SetByteArrayLength\fR, this points +to the value from which to extract an array of bytes. +.AP Tcl_Interp *interp in +Interpreter to use for error reporting. +.AP "size_t | int" *numBytesPtr out +Points to space where the number of bytes in the array may be written. +Caller may pass NULL when it does not need this information. .BE .SH DESCRIPTION .PP -These procedures are used to create, modify, and read Tcl byte-array values -from C code. Byte-array values are typically used to hold the -results of binary IO operations or data structures created with the -\fBbinary\fR command. In Tcl, an array of bytes is not equivalent to a -string. Conceptually, a string is an array of Unicode characters, while a -byte-array is an array of 8-bit quantities with no implicit meaning. -Accessor functions are provided to get the string representation of a -byte-array or to convert an arbitrary value to a byte-array. Obtaining the +These routines are used to create, modify, store, transfer, and retrieve +arbitrary binary data in Tcl values. Specifically, data that can be +represented as a sequence of arbitrary byte values is supported. +This includes data read from binary channels, values created by the +\fBbinary\fR command, encrypted data, or other information representable as +a finite byte sequence. +.PP +A byte is an 8-bit quantity with no inherent meaning. When the 8 bits are +interpreted as an integer value, the range of possible values is (0-255). +The C type best suited to store a byte is the \fBunsigned char\fR. +An \fBunsigned char\fR array of size \fIN\fR stores an aribtrary binary +value of size \fIN\fR bytes. We call this representation a byte-array. +Here we document the routines that allow us to operate on Tcl values as +byte-arrays. +.PP +All Tcl values must correspond to a string representation. +When a byte-array value must be processed as a string, the sequence +of \fIN\fR bytes is transformed into the corresponding sequence +of \fIN\fR characters, where each byte value transforms to the same +character codepoint value in the range (U+0000 - U+00FF). Obtaining the string representation of a byte-array value (by calling -\fBTcl_GetStringFromObj\fR) produces a properly formed UTF-8 sequence with a -one-to-one mapping between the bytes in the internal representation and the -UTF-8 characters in the string representation. +\fBTcl_GetStringFromObj\fR) produces this string in Tcl's usual +Modified UTF-8 encoding. .PP -\fBTcl_NewByteArrayObj\fR and \fBTcl_SetByteArrayObj\fR will -create a new value of byte-array type or modify an existing value to have a -byte-array type. Both of these procedures set the value's type to be -byte-array and set the value's internal representation to a copy of the -array of bytes given by \fIbytes\fR. \fBTcl_NewByteArrayObj\fR returns a -pointer to a newly allocated value with a reference count of zero. -\fBTcl_SetByteArrayObj\fR invalidates any old string representation and, if -the value is not already a byte-array value, frees any old internal -representation. If \fIbytes\fR is NULL then the new byte array contains -arbitrary values. +\fBTcl_NewByteArrayObj\fR and \fBTcl_SetByteArrayObj\fR +create a new value or overwrite an existing unshared value, respectively, +to hold a byte-array value of \fInumBytes\fR bytes. When a caller +passes a non-NULL value of \fIbytes\fR, it must point to memory from +which \fInumBytes\fR bytes can be read. These routines +allocate \fInumBytes\fR bytes of memory, copy \fInumBytes\fR +bytes from \fIbytes\fR into it, and keep the result in the internal +representation of the new or overwritten value. +When the caller passes a NULL value of \fIbytes\fR, the data copying +step is skipped, and the bytes stored in the value are undefined. +A \fIbytes\fR value of NULL is useful only when the caller will arrange +to write known contents into the byte-array through a pointer retrieved +by a call to one of the routines explained below. \fBTcl_NewByteArrayObj\fR +returns a pointer to the created value with a reference count of zero. +\fBTcl_SetByteArrayObj\fR overwrites and invalidates any old contents +of the unshared \fIobjPtr\fR as appropriate, and keeps its reference +count (0 or 1) unchanged. The value produced by these routines has no +string representation. Any memory allocation failure may cause a panic. .PP -\fBTcl_GetByteArrayFromObj\fR converts a Tcl value to byte-array type and -returns a pointer to the value's new internal representation as an array of -bytes. The length of this array is stored in \fIlengthPtr\fR if -\fIlengthPtr\fR is non-NULL. The storage for the array of bytes is owned by -the value and should not be freed. The contents of the array may be -modified by the caller only if the value is not shared and the caller -invalidates the string representation. +\fBTcl_GetBytesFromObj\fR performs the opposite function of +\fBTcl_SetByteArrayObj\fR, providing access to read a byte-array from +a Tcl value that was previously written into it. When \fIobjPtr\fR +is a value previously produced by \fBTcl_NewByteArrayObj\fR or +\fBTcl_SetByteArrayObj\fR, then \fBTcl_GetBytesFromObj\fR returns +a pointer to the byte-array kept in the value's internal representation. +If the caller provides a non-NULL value for \fInumBytesPtr\fR, it must +point to memory where \fBTcl_GetBytesFromObj\fR can write the number +of bytes in the value's internal byte-array. With both pieces of +information, the caller is able to retrieve any information about the +contents of that byte-array that it seeks. When \fIobjPtr\fR does +not already contain an internal byte-array, \fBTcl_GetBytesFromObj\fR +will try to create one from the value's string representation. Any +string value that does not include any character codepoints outside +the range (U+0000 - U+00FF) will successfully translate to a unique +byte-array value. With the created byte-array, the routine returns +as before. For any string representation which does contain +a forbidden character codepoint, the conversion fails, and +\fBTcl_GetBytesFromObj\fR returns NULL to signal that failure. On +failure, nothing will be written to \fInumBytesPtr\fR, and if +the \fIinterp\fR argument is non-NULL, then error messages and +codes are left in it recording the error. .PP -\fBTcl_SetByteArrayLength\fR converts the Tcl value to byte-array type -and changes the length of the value's internal representation as an -array of bytes. If \fIlength\fR is greater than the space currently -allocated for the array, the array is reallocated to the new length; the -newly allocated bytes at the end of the array have arbitrary values. If -\fIlength\fR is less than the space currently allocated for the array, -the length of array is reduced to the new length. The return value is a -pointer to the value's new array of bytes. - +\fBTcl_GetByteArrayFromObj\fR performs exactly the same function as +\fBTcl_GetBytesFromObj\fR does when called with the \fIinterp\fR +argument passed the value NULL. This is incompatible with the +way \fBTcl_GetByteArrayFromObj\fR functioned in Tcl 8. +\fBTcl_GetBytesFromObj\fR is the more capable interface and should +usually be favored for use over \fBTcl_GetByteArrayFromObj\fR. +.PP +On success, both \fBTcl_GetByteFromObj\fR and \fBTcl_GetByteArrayFromObj\fR +return a pointer into the internal representation of a \fBTcl_Obj\fR. +That pointer must not be freed by the caller, and should not be retained +for use beyond the known time the internal representation of the value +has not been disturbed. The pointer may be used to overwrite the byte +contents of the internal representation, so long as the value is unshared +and any string representation is invalidated. +.PP +\fBTcl_SetByteArrayLength\fR enables a caller to change the size of a +byte-array in the internal representation of an unshared \fIobjPtr\fR to +become \fInumBytes\fR bytes. This is most often useful after the +bytes of the internal byte-array have been directly overwritten and it +has been discovered that the required size differs from the first +estimate used in the allocation. \fBTcl_SetByteArrayLength\fR returns +a pointer to the resized byte-array. Because resizing the byte-array +changes the internal representation, \fBTcl_SetByteArrayLength\fR +also invalidates any string representation in \fIobjPtr\fR. If resizing +grows the byte-array, the new byte values are undefined. If \fIobjPtr\fR +does not already possess an internal byte-array, one is produced in the +same way that \fBTcl_GetBytesFromObj\fR does, also returning NULL +when any characters of the value in \fIobjPtr\fR (up to +\fInumBytes\fR of them) are not valid bytes. .SH "REFERENCE COUNT MANAGEMENT" .PP \fBTcl_NewByteArrayObj\fR always returns a zero-reference object, much @@ -94,11 +154,11 @@ like \fBTcl_NewObj\fR. reference count of their \fIobjPtr\fR arguments, but do require that the object be unshared. .PP -\fBTcl_GetByteArrayFromObj\fR does not modify the reference count of its -\fIobjPtr\fR argument; it only reads. +\fBTcl_GetBytesFromObj\fR and \fBTcl_GetByteArrayFromObj\fR do not modify +the reference count of \fIobjPtr\fR; they only read. .SH "SEE ALSO" Tcl_GetStringFromObj, Tcl_NewObj, Tcl_IncrRefCount, Tcl_DecrRefCount .SH KEYWORDS -value, binary data, byte array, utf, unicode, internationalization +value, binary data, byte array, utf, unicode diff --git a/doc/binary.n b/doc/binary.n index 9ab694e..1a62ad6 100644 --- a/doc/binary.n +++ b/doc/binary.n @@ -44,8 +44,9 @@ the range \eu0000\-\eu00FF. When encoding binary data as a readable string, the starting binary data is passed to the \fBbinary encode\fR command, together with the name of the encoding to use and any encoding-specific options desired. Data which has been -encoded can be converted back to binary form using \fBbinary decode\fR. The -following formats and options are supported. +encoded can be converted back to binary form using \fBbinary decode\fR. +The \fBbinary encode\fR command raises an error if the \fIdata\fR argument +is not binary data. The following formats and options are supported. .TP \fBbase64\fR . @@ -607,9 +608,9 @@ will return .PP The \fBbinary scan\fR command parses fields from a binary string, returning the number of conversions performed. \fIString\fR gives the -input bytes to be parsed (one byte per character, and characters not -representable as a byte have their high bits chopped) -and \fIformatString\fR indicates how to parse it. +input bytes to be parsed and \fIformatString\fR indicates how to parse it. +An error is raised if \fIstring\fR is anything other than a valid binary +data value. Each \fIvarName\fR gives the name of a variable; when a field is scanned from \fIstring\fR the result is assigned to the corresponding variable. diff --git a/generic/tclBinary.c b/generic/tclBinary.c index 0486521..af16ca0 100644 --- a/generic/tclBinary.c +++ b/generic/tclBinary.c @@ -140,84 +140,21 @@ static const EnsembleImplMap decodeMap[] = { }; /* - * The following object types represent an array of bytes. The intent is to + * The following Tcl_ObjType represents an array of bytes. The intent is to * allow arbitrary binary data to pass through Tcl as a Tcl value without loss * or damage. Such values are useful for things like encoded strings or Tk * images to name just two. * * A bytearray is an ordered sequence of bytes. Each byte is an integer value * in the range [0-255]. To be a Tcl value type, we need a way to encode each - * value in the value set as a Tcl string. The simplest encoding is to + * value in the value set as a Tcl string. A simple encoding is to * represent each byte value as the same codepoint value. A bytearray of N * bytes is encoded into a Tcl string of N characters where the codepoint of * each character is the value of corresponding byte. This approach creates a * one-to-one map between all bytearray values and a subset of Tcl string - * values. - * - * When converting a Tcl string value to the bytearray internal rep, the - * question arises what to do with strings outside that subset? That is, - * those Tcl strings containing at least one codepoint greater than 255? The - * obviously correct answer is to raise an error! That string value does not - * represent any valid bytearray value. Full Stop. The setFromAnyProc - * signature has a completion code return value for just this reason, to - * reject invalid inputs. - * - * Unfortunately this was not the path taken by the authors of the original - * tclByteArrayType. They chose to accept all Tcl string values as acceptable - * string encodings of the bytearray values that result from masking away the - * high bits of any codepoint value at all. This meant that every bytearray - * value had multiple accepted string representations. - * - * The implications of this choice are truly ugly. When a Tcl value has a - * string representation, we are required to accept that as the true value. - * Bytearray values that possess a string representation cannot be processed - * as bytearrays because we cannot know which true value that bytearray - * represents. The consequence is that we drag around an internal rep that we - * cannot make any use of. This painful price is extracted at any point after - * a string rep happens to be generated for the value. This happens even when - * the troublesome codepoints outside the byte range never show up. This - * happens rather routinely in normal Tcl operations unless we burden the - * script writer with the cognitive burden of avoiding it. The price is also - * paid by callers of the C interface. The routine - * - * unsigned char *Tcl_GetByteArrayFromObj(objPtr, lenPtr) - * - * has a guarantee to always return a non-NULL value, but that value points to - * a byte sequence that cannot be used by the caller to process the Tcl value - * absent some sideband testing that objPtr is "pure". Tcl offers no public - * interface to perform this test, so callers either break encapsulation or - * are unavoidably buggy. Tcl has defined a public interface that cannot be - * used correctly. The Tcl source code itself suffers the same problem, and - * has been buggy, but progressively less so as more and more portions of the - * code have been retrofitted with the required "purity testing". The set of - * values able to pass the purity test can be increased via the introduction - * of a "canonical" flag marker, but the only way the broken interface itself - * can be discarded is to start over and define the Tcl_ObjType properly. - * Bytearrays should simply be usable as bytearrays without a kabuki dance of - * testing. - * - * The Tcl_ObjType "properByteArrayType" is (nearly) a correct implementation - * of bytearrays. Any Tcl value with the type properByteArrayType can have - * its bytearray value fetched and used with confidence that acting on that - * value is equivalent to acting on the true Tcl string value. This still - * implies a side testing burden -- past mistakes will not let us avoid that - * immediately, but it is at least a conventional test of type, and can be - * implemented entirely by examining the objPtr fields, with no need to query - * the intrep, as a canonical flag would require. - * - * Until Tcl_GetByteArrayFromObj() and Tcl_SetByteArrayLength() can be revised - * to admit the possibility of returning NULL when the true value is not a - * valid bytearray, we need a mechanism to retain compatibility with the - * deployed callers of the broken interface. That's what the retained - * "tclByteArrayType" provides. In those unusual circumstances where we - * convert an invalid bytearray value to a bytearray type, it is to this - * legacy type. Essentially any time this legacy type gets used, it's a - * signal of a bug being ignored. A TIP should be drafted to remove this - * connection to the broken past so that Tcl 9 will no longer have any trace - * of it. Prescribing a migration path will be the key element of that work. - * The internal changes now in place are the limit of what can be done short - * of interface repair. They provide a great expansion of the histories over - * which bytearray values can be useful in the meanwhile. + * values. Tcl string values outside that subset do no represent any valid + * bytearray value. Attempts to treat those values as bytearrays will lead + * to errors. See TIP 568 for how this differs from Tcl 8. */ static const Tcl_ObjType properByteArrayType = { @@ -282,15 +219,15 @@ Tcl_Obj * Tcl_NewByteArrayObj( const unsigned char *bytes, /* The array of bytes used to initialize the * new object. */ - size_t length) /* Length of the array of bytes */ + size_t numBytes) /* Number of bytes in the array */ { #ifdef TCL_MEM_DEBUG - return Tcl_DbNewByteArrayObj(bytes, length, "unknown", 0); + return Tcl_DbNewByteArrayObj(bytes, numBytes, "unknown", 0); #else /* if not TCL_MEM_DEBUG */ Tcl_Obj *objPtr; TclNewObj(objPtr); - Tcl_SetByteArrayObj(objPtr, bytes, length); + Tcl_SetByteArrayObj(objPtr, bytes, numBytes); return objPtr; #endif /* TCL_MEM_DEBUG */ } @@ -311,7 +248,7 @@ Tcl_NewByteArrayObj( * result of calling Tcl_NewByteArrayObj. * * Results: - * The newly create object is returned. This object will have no initial + * The newly created object is returned. This object has no initial * string representation. The returned object has a ref count of 0. * * Side effects: @@ -325,7 +262,7 @@ Tcl_Obj * Tcl_DbNewByteArrayObj( const unsigned char *bytes, /* The array of bytes used to initialize the * new object. */ - size_t length, /* Length of the array of bytes. */ + size_t numBytes, /* Number of bytes in the array */ const char *file, /* The name of the source file calling this * procedure; used for debugging. */ int line) /* Line number in the source file; used for @@ -334,7 +271,7 @@ Tcl_DbNewByteArrayObj( Tcl_Obj *objPtr; TclDbNewObj(objPtr, file, line); - Tcl_SetByteArrayObj(objPtr, bytes, length); + Tcl_SetByteArrayObj(objPtr, bytes, numBytes); return objPtr; } #else /* if not TCL_MEM_DEBUG */ @@ -342,12 +279,11 @@ Tcl_Obj * Tcl_DbNewByteArrayObj( const unsigned char *bytes, /* The array of bytes used to initialize the * new object. */ - size_t length, /* Length of the array of bytes, which must be - * >= 0. */ + size_t numBytes, /* Number of bytes in the array */ TCL_UNUSED(const char *) /*file*/, TCL_UNUSED(int) /*line*/) { - return Tcl_NewByteArrayObj(bytes, length); + return Tcl_NewByteArrayObj(bytes, numBytes); } #endif /* TCL_MEM_DEBUG */ @@ -373,9 +309,8 @@ void Tcl_SetByteArrayObj( Tcl_Obj *objPtr, /* Object to initialize as a ByteArray. */ const unsigned char *bytes, /* The array of bytes to use as the new value. - * May be NULL even if length > 0. */ - size_t length) /* Length of the array of bytes, which must - * be >= 0. */ + * May be NULL even if numBytes > 0. */ + size_t numBytes) /* Number of bytes in the array */ { ByteArray *byteArrayPtr; Tcl_ObjInternalRep ir; @@ -385,12 +320,12 @@ Tcl_SetByteArrayObj( } TclInvalidateStringRep(objPtr); - byteArrayPtr = (ByteArray *)Tcl_Alloc(BYTEARRAY_SIZE(length)); - byteArrayPtr->used = length; - byteArrayPtr->allocated = length; + byteArrayPtr = (ByteArray *)Tcl_Alloc(BYTEARRAY_SIZE(numBytes)); + byteArrayPtr->used = numBytes; + byteArrayPtr->allocated = numBytes; - if ((bytes != NULL) && (length > 0)) { - memcpy(byteArrayPtr->bytes, bytes, length); + if ((bytes != NULL) && (numBytes > 0)) { + memcpy(byteArrayPtr->bytes, bytes, numBytes); } SET_BYTEARRAY(&ir, byteArrayPtr); @@ -408,8 +343,8 @@ Tcl_SetByteArrayObj( * interp (if not NULL). * * Results: - * Pointer to array of bytes, or NULL. representing the ByteArray object. - * Writes number of bytes in array to *lengthPtr. + * NULL or pointer to array of bytes representing the ByteArray object. + * Writes number of bytes in array to *numBytesPtr. * *---------------------------------------------------------------------- */ @@ -419,11 +354,12 @@ unsigned char * Tcl_GetBytesFromObj( Tcl_Interp *interp, /* For error reporting */ Tcl_Obj *objPtr, /* Value to extract from */ - size_t *lengthPtr) /* If non-NULL, filled with length of the - * array of bytes in the ByteArray object. */ + size_t *numBytesPtr) /* If non-NULL, write the number of bytes + * in the array here */ { ByteArray *baPtr; - const Tcl_ObjInternalRep *irPtr = TclFetchInternalRep(objPtr, &properByteArrayType); + const Tcl_ObjInternalRep *irPtr + = TclFetchInternalRep(objPtr, &properByteArrayType); if (irPtr == NULL) { if (TCL_ERROR == SetByteArrayFromAny(interp, TCL_INDEX_NONE, objPtr)) { @@ -433,8 +369,8 @@ Tcl_GetBytesFromObj( } baPtr = GET_BYTEARRAY(irPtr); - if (lengthPtr != NULL) { - *lengthPtr = baPtr->used; + if (numBytesPtr != NULL) { + *numBytesPtr = baPtr->used; } return baPtr->bytes; } @@ -443,26 +379,25 @@ unsigned char * TclGetBytesFromObj( Tcl_Interp *interp, /* For error reporting */ Tcl_Obj *objPtr, /* Value to extract from */ - int *lengthPtr) /* If non-NULL, filled with length of the - * array of bytes in the ByteArray object. */ + int *numBytesPtr) /* If non-NULL, write the number of bytes + * in the array here */ { size_t numBytes = 0; unsigned char *bytes = Tcl_GetBytesFromObj(interp, objPtr, &numBytes); - if (lengthPtr) { + if (bytes && numBytesPtr) { if (numBytes > INT_MAX) { - /* Caller asked for an int length, but true length is outside - * the int range. This case will be developed out of existence - * in Tcl 9. As interim measure, fail. */ + /* Caller asked for numBytes to be written to an int, but the + * value is outside the int range. */ if (interp) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "byte sequence length exceeds INT_MAX", -1)); + Tcl_SetErrorCode(interp, "TCL", "API", "OUTDATED", NULL); } - *lengthPtr = 0; return NULL; } else { - *lengthPtr = (int) numBytes; + *numBytesPtr = (int) numBytes; } } return bytes; @@ -490,42 +425,19 @@ TclGetBytesFromObj( unsigned char * TclGetByteArrayFromObj( Tcl_Obj *objPtr, /* The ByteArray object. */ - int *lengthPtr) /* If non-NULL, filled with length of the - * array of bytes in the ByteArray object. */ + int *numBytesPtr) /* If non-NULL, write the number of bytes + * in the array here */ { - size_t numBytes = 0; - unsigned char *bytes = Tcl_GetBytesFromObj(NULL, objPtr, &numBytes); - - /* Macro TclGetByteArrayFromObj passes NULL for lengthPtr as - * a trick to get around changing size. */ - if (lengthPtr) { - if (numBytes > INT_MAX) { - /* Caller asked for an int length, but true length is outside - * the int range. */ - *lengthPtr = 0; - return NULL; - } else { - *lengthPtr = (int) numBytes; - } - } - return bytes; + return TclGetBytesFromObj(NULL, objPtr, numBytesPtr); } unsigned char * Tcl_GetByteArrayFromObj( Tcl_Obj *objPtr, /* The ByteArray object. */ - size_t *lengthPtr) /* If non-NULL, filled with length of the - * array of bytes in the ByteArray object. */ + size_t *numBytesPtr) /* If non-NULL, write the number of bytes + * in the array here */ { - size_t numBytes = 0; - unsigned char *bytes = Tcl_GetBytesFromObj(NULL, objPtr, &numBytes); - - /* Macro TclGetByteArrayFromObj passes NULL for lengthPtr as - * a trick to get around changing size. */ - if (lengthPtr) { - *lengthPtr = numBytes; - } - return bytes; + return Tcl_GetBytesFromObj(NULL, objPtr, numBytesPtr); } /* @@ -553,7 +465,7 @@ Tcl_GetByteArrayFromObj( unsigned char * Tcl_SetByteArrayLength( Tcl_Obj *objPtr, /* The ByteArray object. */ - size_t length) /* New length for internal byte array. */ + size_t numBytes) /* Number of bytes in resized array */ { ByteArray *byteArrayPtr; Tcl_ObjInternalRep *irPtr; @@ -564,20 +476,21 @@ Tcl_SetByteArrayLength( irPtr = TclFetchInternalRep(objPtr, &properByteArrayType); if (irPtr == NULL) { - if (TCL_ERROR == SetByteArrayFromAny(NULL, length, objPtr)) { + if (TCL_ERROR == SetByteArrayFromAny(NULL, numBytes, objPtr)) { return NULL; } irPtr = TclFetchInternalRep(objPtr, &properByteArrayType); } byteArrayPtr = GET_BYTEARRAY(irPtr); - if (length > byteArrayPtr->allocated) { - byteArrayPtr = (ByteArray *)Tcl_Realloc(byteArrayPtr, BYTEARRAY_SIZE(length)); - byteArrayPtr->allocated = length; + if (numBytes > byteArrayPtr->allocated) { + byteArrayPtr = (ByteArray *)Tcl_Realloc(byteArrayPtr, + BYTEARRAY_SIZE(numBytes)); + byteArrayPtr->allocated = numBytes; SET_BYTEARRAY(irPtr, byteArrayPtr); } TclInvalidateStringRep(objPtr); - byteArrayPtr->used = length; + byteArrayPtr->used = numBytes; return byteArrayPtr->bytes; } @@ -645,7 +558,7 @@ MakeByteArray( *dst++ = UCHAR(ch); } byteArrayPtr->used = dst - byteArrayPtr->bytes; - byteArrayPtr->allocated = length; + byteArrayPtr->allocated = numBytes; *byteArrayPtrPtr = byteArrayPtr; return proper; @@ -873,9 +786,14 @@ TclAppendBytesToByteArray( } byteArrayPtr = GET_BYTEARRAY(irPtr); + /* Size limit check now commented out. Used to protect calls to + * Tcl_*Alloc*() limited by unsigned int arguments. + * if (len > UINT_MAX - byteArrayPtr->used) { Tcl_Panic("max size for a Tcl value (%u bytes) exceeded", UINT_MAX); } + * + */ needed = byteArrayPtr->used + len; /* @@ -899,11 +817,7 @@ TclAppendBytesToByteArray( * Try to allocate double the increment that is needed (plus). */ - size_t limit = UINT_MAX - needed; - size_t extra = len + TCL_MIN_GROWTH; - size_t growth = (extra > limit) ? limit : extra; - - attempt = needed + growth; + attempt = needed + len + TCL_MIN_GROWTH; ptr = (ByteArray *)Tcl_AttemptRealloc(byteArrayPtr, BYTEARRAY_SIZE(attempt)); } if (ptr == NULL) { diff --git a/generic/tclDecls.h b/generic/tclDecls.h index 71e49c4..459ddc5 100644 --- a/generic/tclDecls.h +++ b/generic/tclDecls.h @@ -3839,14 +3839,14 @@ extern const TclStubs *tclStubsPtr; #define Tcl_GetStringFromObj(objPtr, sizePtr) \ (sizeof(*sizePtr) <= sizeof(int) ? tclStubsPtr->tclGetStringFromObj(objPtr, (int *)sizePtr) : tclStubsPtr->tcl_GetStringFromObj(objPtr, (size_t *)sizePtr)) #define Tcl_GetByteArrayFromObj(objPtr, sizePtr) \ - (sizeof(*sizePtr) <= sizeof(int) ? tclStubsPtr->tclGetByteArrayFromObj(objPtr, (int *)sizePtr) : tclStubsPtr->tcl_GetByteArrayFromObj(objPtr, (size_t *)sizePtr)) + (sizeof(*sizePtr) <= sizeof(int) ? tclStubsPtr->tclGetBytesFromObj(NULL, objPtr, (int *)sizePtr) : tclStubsPtr->tcl_GetBytesFromObj(NULL, objPtr, (size_t *)sizePtr)) #define Tcl_GetUnicodeFromObj(objPtr, sizePtr) \ (sizeof(*sizePtr) <= sizeof(int) ? tclStubsPtr->tclGetUnicodeFromObj(objPtr, (int *)sizePtr) : tclStubsPtr->tcl_GetUnicodeFromObj(objPtr, (size_t *)sizePtr)) #else #define Tcl_GetStringFromObj(objPtr, sizePtr) \ (sizeof(*sizePtr) <= sizeof(int) ? (TclGetStringFromObj)(objPtr, (int *)sizePtr) : (Tcl_GetStringFromObj)(objPtr, (size_t *)sizePtr)) #define Tcl_GetByteArrayFromObj(objPtr, sizePtr) \ - (sizeof(*sizePtr) <= sizeof(int) ? (TclGetByteArrayFromObj)(objPtr, (int *)sizePtr) : Tcl_GetByteArrayFromObj(objPtr, (size_t *)sizePtr)) + (sizeof(*sizePtr) <= sizeof(int) ? (TclGetBytesFromObj)(NULL, objPtr, (int *)sizePtr) : Tcl_GetBytesFromObj(NULL, objPtr, (size_t *)sizePtr)) #define Tcl_GetUnicodeFromObj(objPtr, sizePtr) \ (sizeof(*sizePtr) <= sizeof(int) ? (TclGetUnicodeFromObj)(objPtr, (int *)sizePtr) : Tcl_GetUnicodeFromObj(objPtr, (size_t *)sizePtr)) #endif -- cgit v0.12 From 2c7899f9eaac69983a697b016a7b6262ed2aa5cf Mon Sep 17 00:00:00 2001 From: dgp Date: Sun, 7 Nov 2021 14:52:29 +0000 Subject: Dodge a few macro games. --- generic/tclExecute.c | 2 +- generic/tclIO.c | 2 +- generic/tclStringObj.c | 6 +++--- generic/tclZipfs.c | 2 +- generic/tclZlib.c | 8 ++++---- 5 files changed, 10 insertions(+), 10 deletions(-) diff --git a/generic/tclExecute.c b/generic/tclExecute.c index 3cba67a..a216a56 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -5113,7 +5113,7 @@ TEBCresume( TclNewObj(objResultPtr); } else if (TclIsPureByteArray(valuePtr)) { objResultPtr = Tcl_NewByteArrayObj( - Tcl_GetByteArrayFromObj(valuePtr, (size_t *)NULL)+index, 1); + (Tcl_GetBytesFromObj)(NULL, valuePtr, NULL)+index, 1); } else if (valuePtr->bytes && slength == valuePtr->length) { objResultPtr = Tcl_NewStringObj((const char *) valuePtr->bytes+index, 1); diff --git a/generic/tclIO.c b/generic/tclIO.c index cce7f64..9f6fc1d 100644 --- a/generic/tclIO.c +++ b/generic/tclIO.c @@ -4564,7 +4564,7 @@ Tcl_GetsObj( if ((statePtr->encoding == NULL) && ((statePtr->inputTranslation == TCL_TRANSLATE_LF) || (statePtr->inputTranslation == TCL_TRANSLATE_CR)) - && Tcl_GetByteArrayFromObj(objPtr, (size_t *)NULL) != NULL) { + && (Tcl_GetBytesFromObj)(NULL, objPtr, NULL) != NULL) { return TclGetsObjBinary(chan, objPtr); } diff --git a/generic/tclStringObj.c b/generic/tclStringObj.c index d66e0d0..cde9a1d 100644 --- a/generic/tclStringObj.c +++ b/generic/tclStringObj.c @@ -1344,7 +1344,7 @@ Tcl_AppendObjToObj( */ TclAppendBytesToByteArray(objPtr, - Tcl_GetByteArrayFromObj(appendObjPtr, (size_t *)NULL), lengthSrc); + (Tcl_GetBytesFromObj)(NULL, appendObjPtr, NULL), lengthSrc); return; } @@ -2855,7 +2855,7 @@ TclStringRepeat( done *= 2; } TclAppendBytesToByteArray(objResultPtr, - Tcl_GetByteArrayFromObj(objResultPtr, (size_t *)NULL), + (Tcl_GetBytesFromObj)(NULL, objResultPtr, NULL), (count - done) * length); } else if (unichar) { /* @@ -3732,7 +3732,7 @@ TclStringReverse( if (!inPlace || Tcl_IsShared(objPtr)) { objPtr = Tcl_NewByteArrayObj(NULL, numBytes); } - ReverseBytes(Tcl_GetByteArrayFromObj(objPtr, (size_t *)NULL), from, numBytes); + ReverseBytes((Tcl_GetBytesFromObj)(NULL, objPtr, NULL), from, numBytes); return objPtr; } diff --git a/generic/tclZipfs.c b/generic/tclZipfs.c index d9cb4ba..bfd594c 100644 --- a/generic/tclZipfs.c +++ b/generic/tclZipfs.c @@ -2412,7 +2412,7 @@ ZipFSMkKeyObjCmd( } passObj = Tcl_NewByteArrayObj(NULL, 264); - passBuf = Tcl_GetByteArrayFromObj(passObj, (int *)NULL); + passBuf = Tcl_GetBytesFromObj(NULL, passObj, NULL); while (len > 0) { int ch = pw[len - 1]; diff --git a/generic/tclZlib.c b/generic/tclZlib.c index 6944ff6..ab42ddd 100644 --- a/generic/tclZlib.c +++ b/generic/tclZlib.c @@ -2351,7 +2351,7 @@ ZlibStreamSubcmd( } if (compDictObj) { - if (NULL == Tcl_GetBytesFromObj(interp, compDictObj, NULL)) { + if (NULL == (Tcl_GetBytesFromObj)(interp, compDictObj, NULL)) { return TCL_ERROR; } } @@ -2533,7 +2533,7 @@ ZlibPushSubcmd( } } - if (compDictObj && (NULL == Tcl_GetBytesFromObj(interp, compDictObj, NULL))) { + if (compDictObj && (NULL == (Tcl_GetBytesFromObj)(interp, compDictObj, NULL))) { return TCL_ERROR; } @@ -3330,7 +3330,7 @@ ZlibTransformSetOption( /* not used */ TclNewStringObj(compDictObj, value, strlen(value)); Tcl_IncrRefCount(compDictObj); - if (NULL == Tcl_GetBytesFromObj(interp, compDictObj, NULL)) { + if (NULL == (Tcl_GetBytesFromObj)(interp, compDictObj, NULL)) { Tcl_DecrRefCount(compDictObj); return TCL_ERROR; } @@ -3721,7 +3721,7 @@ ZlibStackChannelTransform( if (compDictObj != NULL) { cd->compDictObj = Tcl_DuplicateObj(compDictObj); Tcl_IncrRefCount(cd->compDictObj); - Tcl_GetByteArrayFromObj(cd->compDictObj, (size_t *)NULL); + (Tcl_GetBytesFromObj)(NULL, cd->compDictObj, NULL); } if (format == TCL_ZLIB_FORMAT_RAW) { -- cgit v0.12 From 4a0e8877b7088f635557ae59f44a7eec07eac424 Mon Sep 17 00:00:00 2001 From: dgp Date: Sun, 7 Nov 2021 21:34:20 +0000 Subject: Document the flexibility of numBytesPtr to point to int or size_t space. --- doc/ByteArrObj.3 | 12 ++++++++++++ 1 file changed, 12 insertions(+) diff --git a/doc/ByteArrObj.3 b/doc/ByteArrObj.3 index 7fdaea6..ad1eb32 100644 --- a/doc/ByteArrObj.3 +++ b/doc/ByteArrObj.3 @@ -131,6 +131,18 @@ has not been disturbed. The pointer may be used to overwrite the byte contents of the internal representation, so long as the value is unshared and any string representation is invalidated. .PP +On success, both \fBTcl_GetBytesFromObj\fR and \fBTcl_GetByteArrayFromObj\fR +write the number of bytes in the byte-array value of \fIobjPtr\fR +to the space pointed to by \fInumBytesPtr\fR. This space may be of type +\fBsize_t\fR or of type \fBint\fR. It is recommended that callers provide +a \fBsize_t\fR space for this purpose. If the caller provides only +an \fBint\fR space and the number of bytes in the byte-array value of +\fIobjPtr\fR is greater than \fBINT_MAX\fR, the routine will fail due +to being unable to correctly report the byte-array size to the caller. +The ability to provide an \fBint\fR space is best considered a migration +aid for codebases constrained to continue operating with Tcl releases +older than 8.7. +.PP \fBTcl_SetByteArrayLength\fR enables a caller to change the size of a byte-array in the internal representation of an unshared \fIobjPtr\fR to become \fInumBytes\fR bytes. This is most often useful after the -- cgit v0.12 From 5a18f3341176bbf31f4d49e29fbb08fecc10323b Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 8 Nov 2021 10:19:09 +0000 Subject: Doc fix for Tcl_GetIntForIndex() --- doc/IntObj.3 | 6 ++++-- generic/tclInt.h | 2 +- 2 files changed, 5 insertions(+), 3 deletions(-) diff --git a/doc/IntObj.3 b/doc/IntObj.3 index d640dbb..703f2ce 100644 --- a/doc/IntObj.3 +++ b/doc/IntObj.3 @@ -32,7 +32,7 @@ int \fBTcl_GetIntFromObj\fR(\fIinterp, objPtr, intPtr\fR) .sp int -\fBTcl_GetIntForIndex\fR(\fIinterp, objPtr, endValue, intPtr\fR) +\fBTcl_GetIntForIndex\fR(\fIinterp, objPtr, endValue, indexPtr\fR) .sp int \fBTcl_GetLongFromObj\fR(\fIinterp, objPtr, longPtr\fR) @@ -58,7 +58,7 @@ int \fBTcl_InitBignumFromDouble\fR(\fIinterp, doubleValue, bigValue\fR) .SH ARGUMENTS .AS Tcl_WideInt doubleValue in/out -.AP int endValue in +.AP size_t endValue in \fBTcl_GetIntForIndex\fR will return this when the input value is "end". .AP int intValue in Integer value used to initialize or set a Tcl value. @@ -80,6 +80,8 @@ retrieval fails. Points to place to store the integer value retrieved from \fIobjPtr\fR. .AP long *longPtr out Points to place to store the long integer value retrieved from \fIobjPtr\fR. +.AP size_t *indexPtr out +Points to place to store the size_t value retrieved from \fIobjPtr\fR. .AP Tcl_WideInt *widePtr out Points to place to store the wide integer value retrieved from \fIobjPtr\fR. .AP mp_int *bigValue in/out diff --git a/generic/tclInt.h b/generic/tclInt.h index c2478fc..6aa7415 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -4435,7 +4435,7 @@ MODULE_SCOPE void TclDbInitNewObj(Tcl_Obj *objPtr, const char *file, * already has a string representation. The caller must use * this macro properly. Improper use can lead to dangerous results. * Because "len" is referenced multiple times, take care that it is an - * expression with the same value each use. + * expression with the same value each use. * * The ANSI C "prototype" for this macro is: * -- cgit v0.12 From c7157e0bbdcf351b626e52b5b521a8a68d6334d6 Mon Sep 17 00:00:00 2001 From: oehhar Date: Fri, 3 Dec 2021 12:04:40 +0000 Subject: RFE [eb64b1520] http: be tolerant against invalid content encoding header responses --- library/http/http.tcl | 8 ++++++-- library/http/pkgIndex.tcl | 2 +- unix/Makefile.in | 4 ++-- win/Makefile.in | 4 ++-- 4 files changed, 11 insertions(+), 7 deletions(-) diff --git a/library/http/http.tcl b/library/http/http.tcl index b0f87de..9f8d7ff 100644 --- a/library/http/http.tcl +++ b/library/http/http.tcl @@ -11,7 +11,7 @@ package require Tcl 8.6- # Keep this in sync with pkgIndex.tcl and with the install directories in # Makefiles -package provide http 2.9.5 +package provide http 2.9.6 namespace eval http { # Allow resourcing to not clobber existing data @@ -3457,8 +3457,12 @@ proc http::ContentEncoding {token} { gzip - x-gzip { lappend r gunzip } compress - x-compress { lappend r decompress } identity {} + br { + return -code error\ + "content-encoding \"br\" not implemented" + } default { - return -code error "unsupported content-encoding \"$coding\"" + Log "unknown content-encoding \"$coding\" ignored" } } } diff --git a/library/http/pkgIndex.tcl b/library/http/pkgIndex.tcl index 74c4841..7249547 100644 --- a/library/http/pkgIndex.tcl +++ b/library/http/pkgIndex.tcl @@ -1,2 +1,2 @@ if {![package vsatisfies [package provide Tcl] 8.6-]} {return} -package ifneeded http 2.9.5 [list tclPkgSetup $dir http 2.9.5 {{http.tcl source {::http::config ::http::formatQuery ::http::geturl ::http::reset ::http::wait ::http::register ::http::unregister ::http::mapReply}}}] +package ifneeded http 2.9.6 [list tclPkgSetup $dir http 2.9.6 {{http.tcl source {::http::config ::http::formatQuery ::http::geturl ::http::reset ::http::wait ::http::register ::http::unregister ::http::mapReply}}}] diff --git a/unix/Makefile.in b/unix/Makefile.in index d187c84..de18d5d 100644 --- a/unix/Makefile.in +++ b/unix/Makefile.in @@ -946,8 +946,8 @@ install-libraries: libraries do \ $(INSTALL_DATA) $$i "$(SCRIPT_INSTALL_DIR)/http1.0"; \ done - @echo "Installing package http 2.9.5 as a Tcl Module"; - @$(INSTALL_DATA) $(TOP_DIR)/library/http/http.tcl "$(MODULE_INSTALL_DIR)/8.6/http-2.9.5.tm" + @echo "Installing package http 2.9.6 as a Tcl Module"; + @$(INSTALL_DATA) $(TOP_DIR)/library/http/http.tcl "$(MODULE_INSTALL_DIR)/8.6/http-2.9.6.tm" @echo "Installing package opt0.4 files to $(SCRIPT_INSTALL_DIR)/opt0.4/"; @for i in $(TOP_DIR)/library/opt/*.tcl; do \ $(INSTALL_DATA) $$i "$(SCRIPT_INSTALL_DIR)/opt0.4"; \ diff --git a/win/Makefile.in b/win/Makefile.in index 41ab5b1..6a67db1 100644 --- a/win/Makefile.in +++ b/win/Makefile.in @@ -726,8 +726,8 @@ install-libraries: libraries install-tzdata install-msgs do \ $(COPY) "$$j" "$(SCRIPT_INSTALL_DIR)/http1.0"; \ done; - @echo "Installing package http 2.9.5 as a Tcl Module"; - @$(COPY) $(ROOT_DIR)/library/http/http.tcl "$(MODULE_INSTALL_DIR)/8.6/http-2.9.5.tm"; + @echo "Installing package http 2.9.6 as a Tcl Module"; + @$(COPY) $(ROOT_DIR)/library/http/http.tcl "$(MODULE_INSTALL_DIR)/8.6/http-2.9.6.tm"; @echo "Installing library opt0.4 directory"; @for j in $(ROOT_DIR)/library/opt/*.tcl; \ do \ -- cgit v0.12 From c5ed34e7e6933f734555cbc8eea44eaae31be32c Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Sat, 4 Dec 2021 18:10:07 +0000 Subject: Rename some function argument names from "length" to "numBytes", as they are named in 8.7 --- generic/tcl.decls | 22 +++++++++++----------- generic/tclDecls.h | 28 ++++++++++++++-------------- 2 files changed, 25 insertions(+), 25 deletions(-) diff --git a/generic/tcl.decls b/generic/tcl.decls index 5b013e6..40598e9 100644 --- a/generic/tcl.decls +++ b/generic/tcl.decls @@ -109,7 +109,7 @@ declare 21 { # Tcl_Obj *Tcl_DbNewBooleanObj(int boolValue, const char *file, int line) #} declare 23 { - Tcl_Obj *Tcl_DbNewByteArrayObj(const unsigned char *bytes, size_t length, + Tcl_Obj *Tcl_DbNewByteArrayObj(const unsigned char *bytes, size_t numBytes, const char *file, int line) } declare 24 { @@ -206,7 +206,7 @@ declare 48 { # Tcl_Obj *Tcl_NewBooleanObj(int boolValue) #} declare 50 { - Tcl_Obj *Tcl_NewByteArrayObj(const unsigned char *bytes, size_t length) + Tcl_Obj *Tcl_NewByteArrayObj(const unsigned char *bytes, size_t numBytes) } declare 51 { Tcl_Obj *Tcl_NewDoubleObj(double doubleValue) @@ -233,11 +233,11 @@ declare 56 { # void Tcl_SetBooleanObj(Tcl_Obj *objPtr, int boolValue) #} declare 58 { - unsigned char *Tcl_SetByteArrayLength(Tcl_Obj *objPtr, size_t length) + unsigned char *Tcl_SetByteArrayLength(Tcl_Obj *objPtr, size_t numBytes) } declare 59 { void Tcl_SetByteArrayObj(Tcl_Obj *objPtr, const unsigned char *bytes, - size_t length) + size_t numBytes) } declare 60 { void Tcl_SetDoubleObj(Tcl_Obj *objPtr, double doubleValue) @@ -1294,12 +1294,12 @@ declare 351 { } # Removed in 9.0: #declare 352 { -# size_t Tcl_UniCharLen(const Tcl_UniChar *uniStr) +# int Tcl_UniCharLen(const Tcl_UniChar *uniStr) #} # Removed in 9.0: #declare 353 { # int Tcl_UniCharNcmp(const Tcl_UniChar *ucs, const Tcl_UniChar *uct, -# size_t numChars) +# unsigned long numChars) #} declare 354 { char *Tcl_Char16ToUtfDString(const unsigned short *uniStr, @@ -1412,7 +1412,7 @@ declare 383 { # Removed in 9.0 #declare 384 { # void Tcl_AppendUnicodeToObj(Tcl_Obj *objPtr, const Tcl_UniChar *unicode, -# size_t length) +# int length) #} declare 385 { int Tcl_RegExpMatchObj(Tcl_Interp *interp, Tcl_Obj *textObj, @@ -1541,7 +1541,7 @@ declare 418 { # Removed in 9.0: #declare 419 { # int Tcl_UniCharNcasecmp(const Tcl_UniChar *ucs, const Tcl_UniChar *uct, -# size_t numChars) +# unsigned long numChars) #} # Removed in 9.0: #declare 420 { @@ -2468,11 +2468,11 @@ declare 648 { # TIP #568 declare 649 { unsigned char *TclGetBytesFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr, - int *lengthPtr) + int *numBytesPtr) } declare 650 { unsigned char *Tcl_GetBytesFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr, - size_t *lengthPtr) + size_t *numBytesPtr) } # TIP #481 @@ -2483,7 +2483,7 @@ declare 652 { Tcl_UniChar *Tcl_GetUnicodeFromObj(Tcl_Obj *objPtr, size_t *lengthPtr) } declare 653 { - unsigned char *Tcl_GetByteArrayFromObj(Tcl_Obj *objPtr, size_t *lengthPtr) + unsigned char *Tcl_GetByteArrayFromObj(Tcl_Obj *objPtr, size_t *numBytesPtr) } # TIP #575 diff --git a/generic/tclDecls.h b/generic/tclDecls.h index 459ddc5..503823e 100644 --- a/generic/tclDecls.h +++ b/generic/tclDecls.h @@ -108,7 +108,7 @@ EXTERN int Tcl_DbIsShared(Tcl_Obj *objPtr, const char *file, /* Slot 22 is reserved */ /* 23 */ EXTERN Tcl_Obj * Tcl_DbNewByteArrayObj(const unsigned char *bytes, - size_t length, const char *file, int line); + size_t numBytes, const char *file, int line); /* 24 */ EXTERN Tcl_Obj * Tcl_DbNewDoubleObj(double doubleValue, const char *file, int line); @@ -180,7 +180,7 @@ EXTERN int Tcl_ListObjReplace(Tcl_Interp *interp, /* Slot 49 is reserved */ /* 50 */ EXTERN Tcl_Obj * Tcl_NewByteArrayObj(const unsigned char *bytes, - size_t length); + size_t numBytes); /* 51 */ EXTERN Tcl_Obj * Tcl_NewDoubleObj(double doubleValue); /* Slot 52 is reserved */ @@ -194,10 +194,10 @@ EXTERN Tcl_Obj * Tcl_NewStringObj(const char *bytes, size_t length); /* Slot 57 is reserved */ /* 58 */ EXTERN unsigned char * Tcl_SetByteArrayLength(Tcl_Obj *objPtr, - size_t length); + size_t numBytes); /* 59 */ EXTERN void Tcl_SetByteArrayObj(Tcl_Obj *objPtr, - const unsigned char *bytes, size_t length); + const unsigned char *bytes, size_t numBytes); /* 60 */ EXTERN void Tcl_SetDoubleObj(Tcl_Obj *objPtr, double doubleValue); /* Slot 61 is reserved */ @@ -1731,10 +1731,10 @@ EXTERN int * Tcl_UtfToUniCharDString(const char *src, size_t length, Tcl_DString *dsPtr); /* 649 */ EXTERN unsigned char * TclGetBytesFromObj(Tcl_Interp *interp, - Tcl_Obj *objPtr, int *lengthPtr); + Tcl_Obj *objPtr, int *numBytesPtr); /* 650 */ EXTERN unsigned char * Tcl_GetBytesFromObj(Tcl_Interp *interp, - Tcl_Obj *objPtr, size_t *lengthPtr); + Tcl_Obj *objPtr, size_t *numBytesPtr); /* 651 */ EXTERN char * Tcl_GetStringFromObj(Tcl_Obj *objPtr, size_t *lengthPtr); @@ -1743,7 +1743,7 @@ EXTERN Tcl_UniChar * Tcl_GetUnicodeFromObj(Tcl_Obj *objPtr, size_t *lengthPtr); /* 653 */ EXTERN unsigned char * Tcl_GetByteArrayFromObj(Tcl_Obj *objPtr, - size_t *lengthPtr); + size_t *numBytesPtr); /* 654 */ EXTERN int Tcl_UtfCharComplete(const char *src, size_t length); /* 655 */ @@ -1791,7 +1791,7 @@ typedef struct TclStubs { void (*tcl_DbIncrRefCount) (Tcl_Obj *objPtr, const char *file, int line); /* 20 */ int (*tcl_DbIsShared) (Tcl_Obj *objPtr, const char *file, int line); /* 21 */ void (*reserved22)(void); - Tcl_Obj * (*tcl_DbNewByteArrayObj) (const unsigned char *bytes, size_t length, const char *file, int line); /* 23 */ + Tcl_Obj * (*tcl_DbNewByteArrayObj) (const unsigned char *bytes, size_t numBytes, const char *file, int line); /* 23 */ Tcl_Obj * (*tcl_DbNewDoubleObj) (double doubleValue, const char *file, int line); /* 24 */ Tcl_Obj * (*tcl_DbNewListObj) (int objc, Tcl_Obj *const *objv, const char *file, int line); /* 25 */ void (*reserved26)(void); @@ -1818,7 +1818,7 @@ typedef struct TclStubs { int (*tcl_ListObjLength) (Tcl_Interp *interp, Tcl_Obj *listPtr, int *lengthPtr); /* 47 */ int (*tcl_ListObjReplace) (Tcl_Interp *interp, Tcl_Obj *listPtr, int first, int count, int objc, Tcl_Obj *const objv[]); /* 48 */ void (*reserved49)(void); - Tcl_Obj * (*tcl_NewByteArrayObj) (const unsigned char *bytes, size_t length); /* 50 */ + Tcl_Obj * (*tcl_NewByteArrayObj) (const unsigned char *bytes, size_t numBytes); /* 50 */ Tcl_Obj * (*tcl_NewDoubleObj) (double doubleValue); /* 51 */ void (*reserved52)(void); Tcl_Obj * (*tcl_NewListObj) (int objc, Tcl_Obj *const objv[]); /* 53 */ @@ -1826,8 +1826,8 @@ typedef struct TclStubs { Tcl_Obj * (*tcl_NewObj) (void); /* 55 */ Tcl_Obj * (*tcl_NewStringObj) (const char *bytes, size_t length); /* 56 */ void (*reserved57)(void); - unsigned char * (*tcl_SetByteArrayLength) (Tcl_Obj *objPtr, size_t length); /* 58 */ - void (*tcl_SetByteArrayObj) (Tcl_Obj *objPtr, const unsigned char *bytes, size_t length); /* 59 */ + unsigned char * (*tcl_SetByteArrayLength) (Tcl_Obj *objPtr, size_t numBytes); /* 58 */ + void (*tcl_SetByteArrayObj) (Tcl_Obj *objPtr, const unsigned char *bytes, size_t numBytes); /* 59 */ void (*tcl_SetDoubleObj) (Tcl_Obj *objPtr, double doubleValue); /* 60 */ void (*reserved61)(void); void (*tcl_SetListObj) (Tcl_Obj *objPtr, int objc, Tcl_Obj *const objv[]); /* 62 */ @@ -2417,11 +2417,11 @@ typedef struct TclStubs { int (*tcl_UtfToUniChar) (const char *src, int *chPtr); /* 646 */ char * (*tcl_UniCharToUtfDString) (const int *uniStr, size_t uniLength, Tcl_DString *dsPtr); /* 647 */ int * (*tcl_UtfToUniCharDString) (const char *src, size_t length, Tcl_DString *dsPtr); /* 648 */ - unsigned char * (*tclGetBytesFromObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, int *lengthPtr); /* 649 */ - unsigned char * (*tcl_GetBytesFromObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, size_t *lengthPtr); /* 650 */ + unsigned char * (*tclGetBytesFromObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, int *numBytesPtr); /* 649 */ + unsigned char * (*tcl_GetBytesFromObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, size_t *numBytesPtr); /* 650 */ char * (*tcl_GetStringFromObj) (Tcl_Obj *objPtr, size_t *lengthPtr); /* 651 */ Tcl_UniChar * (*tcl_GetUnicodeFromObj) (Tcl_Obj *objPtr, size_t *lengthPtr); /* 652 */ - unsigned char * (*tcl_GetByteArrayFromObj) (Tcl_Obj *objPtr, size_t *lengthPtr); /* 653 */ + unsigned char * (*tcl_GetByteArrayFromObj) (Tcl_Obj *objPtr, size_t *numBytesPtr); /* 653 */ int (*tcl_UtfCharComplete) (const char *src, size_t length); /* 654 */ const char * (*tcl_UtfNext) (const char *src); /* 655 */ const char * (*tcl_UtfPrev) (const char *src, const char *start); /* 656 */ -- cgit v0.12 From 2d2b28f51aceca3697f87d716687214b7c860e7a Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 8 Dec 2021 15:49:24 +0000 Subject: Update tcltest package to version 2.5.4 (backported from Tcl 8.7) --- library/tcltest/pkgIndex.tcl | 2 +- library/tcltest/tcltest.tcl | 26 ++++++++++++++++++++++---- unix/Makefile.in | 4 ++-- win/Makefile.in | 4 ++-- 4 files changed, 27 insertions(+), 9 deletions(-) diff --git a/library/tcltest/pkgIndex.tcl b/library/tcltest/pkgIndex.tcl index a56a0d6..da78df0 100644 --- a/library/tcltest/pkgIndex.tcl +++ b/library/tcltest/pkgIndex.tcl @@ -9,4 +9,4 @@ # full path name of this file's directory. if {![package vsatisfies [package provide Tcl] 8.5-]} {return} -package ifneeded tcltest 2.5.3 [list source [file join $dir tcltest.tcl]] +package ifneeded tcltest 2.5.4 [list source [file join $dir tcltest.tcl]] diff --git a/library/tcltest/tcltest.tcl b/library/tcltest/tcltest.tcl index dedcd7a..72c7b94 100644 --- a/library/tcltest/tcltest.tcl +++ b/library/tcltest/tcltest.tcl @@ -10,9 +10,9 @@ # initially implemented by Mary Ann May-Pumphrey of Sun # Microsystems. # -# Copyright (c) 1994-1997 Sun Microsystems, Inc. -# Copyright (c) 1998-1999 Scriptics Corporation. -# Copyright (c) 2000 Ajuba Solutions +# Copyright © 1994-1997 Sun Microsystems, Inc. +# Copyright © 1998-1999 Scriptics Corporation. +# Copyright © 2000 Ajuba Solutions # Contributions from Don Porter, NIST, 2002. (not subject to US copyright) # All rights reserved. @@ -22,7 +22,7 @@ namespace eval tcltest { # When the version number changes, be sure to update the pkgIndex.tcl file, # and the install directory in the Makefiles. When the minor version # changes (new feature) be sure to update the man page as well. - variable Version 2.5.3 + variable Version 2.5.4 # Compatibility support for dumb variables defined in tcltest 1 # Do not use these. Call [package provide Tcl] and [info patchlevel] @@ -399,6 +399,9 @@ namespace eval tcltest { } default { set outputChannel [open $filename a] + if {[package vsatisfies [package provide Tcl] 8.7-]} { + fconfigure $outputChannel -encoding utf-8 + } set ChannelsWeOpened($outputChannel) 1 # If we created the file in [temporaryDirectory], then @@ -443,6 +446,9 @@ namespace eval tcltest { } default { set errorChannel [open $filename a] + if {[package vsatisfies [package provide Tcl] 8.7-]} { + fconfigure $errorChannel -encoding utf-8 + } set ChannelsWeOpened($errorChannel) 1 # If we created the file in [temporaryDirectory], then @@ -785,6 +791,9 @@ namespace eval tcltest { variable Option if {$Option(-loadfile) eq {}} {return} set tmp [open $Option(-loadfile) r] + if {[package vsatisfies [package provide Tcl] 8.7-]} { + fconfigure $tmp -encoding utf-8 + } loadScript [read $tmp] close $tmp } @@ -1330,6 +1339,9 @@ proc tcltest::DefineConstraintInitializers {} { ConstraintInitializer stdio { set code 0 if {![catch {set f [open "|[list [interpreter]]" w]}]} { + if {[package vsatisfies [package provide Tcl] 8.7-]} { + fconfigure $f -encoding utf-8 + } if {![catch {puts $f exit}]} { if {![catch {close $f}]} { set code 1 @@ -2177,6 +2189,9 @@ proc tcltest::test {name description args} { set testFile [file normalize [uplevel 1 {info script}]] if {[file readable $testFile]} { set testFd [open $testFile r] + if {[package vsatisfies [package provide Tcl] 8.7-]} { + fconfigure $testFd -encoding utf-8 + } set testLine [expr {[lsearch -regexp \ [split [read $testFd] "\n"] \ "^\[ \t\]*test [string map {. \\.} $name] "] + 1}] @@ -2885,6 +2900,9 @@ proc tcltest::runAllTests { {shell ""} } { if {[catch { incr numTestFiles set pipeFd [open $cmd "r"] + if {[package vsatisfies [package provide Tcl] 8.7-]} { + fconfigure $pipeFd -encoding utf-8 + } while {[gets $pipeFd line] >= 0} { if {[regexp [join { {^([^:]+):\t} diff --git a/unix/Makefile.in b/unix/Makefile.in index bb726ab..74df6fb 100644 --- a/unix/Makefile.in +++ b/unix/Makefile.in @@ -960,9 +960,9 @@ install-libraries: libraries @echo "Installing package msgcat 1.6.1 as a Tcl Module" @$(INSTALL_DATA) $(TOP_DIR)/library/msgcat/msgcat.tcl \ "$(MODULE_INSTALL_DIR)/8.5/msgcat-1.6.1.tm" - @echo "Installing package tcltest 2.5.3 as a Tcl Module" + @echo "Installing package tcltest 2.5.4 as a Tcl Module" @$(INSTALL_DATA) $(TOP_DIR)/library/tcltest/tcltest.tcl \ - "$(MODULE_INSTALL_DIR)/8.5/tcltest-2.5.3.tm" + "$(MODULE_INSTALL_DIR)/8.5/tcltest-2.5.4.tm" @echo "Installing package platform 1.0.18 as a Tcl Module" @$(INSTALL_DATA) $(TOP_DIR)/library/platform/platform.tcl \ "$(MODULE_INSTALL_DIR)/8.4/platform-1.0.18.tm" diff --git a/win/Makefile.in b/win/Makefile.in index dbec774..71b40cd 100644 --- a/win/Makefile.in +++ b/win/Makefile.in @@ -740,8 +740,8 @@ install-libraries: libraries install-tzdata install-msgs done; @echo "Installing package msgcat 1.6.1 as a Tcl Module"; @$(COPY) $(ROOT_DIR)/library/msgcat/msgcat.tcl "$(MODULE_INSTALL_DIR)/8.5/msgcat-1.6.1.tm"; - @echo "Installing package tcltest 2.5.3 as a Tcl Module"; - @$(COPY) $(ROOT_DIR)/library/tcltest/tcltest.tcl "$(MODULE_INSTALL_DIR)/8.5/tcltest-2.5.3.tm"; + @echo "Installing package tcltest 2.5.4 as a Tcl Module"; + @$(COPY) $(ROOT_DIR)/library/tcltest/tcltest.tcl "$(MODULE_INSTALL_DIR)/8.5/tcltest-2.5.4.tm"; @echo "Installing package platform 1.0.18 as a Tcl Module"; @$(COPY) $(ROOT_DIR)/library/platform/platform.tcl "$(MODULE_INSTALL_DIR)/8.4/platform-1.0.18.tm"; @echo "Installing package platform::shell 1.1.4 as a Tcl Module"; -- cgit v0.12 From 5d92b3dc112a0525e4c00cba1b4b9e9b5c29425d Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 9 Dec 2021 14:46:41 +0000 Subject: TIP #613: New INDEX_NULL_OK flag for Tcl_GetIndexFromObj*() --- doc/GetIndex.3 | 6 ++++-- generic/tcl.h | 3 +++ generic/tclIndexObj.c | 20 +++++++++++++++----- generic/tclTest.c | 17 ++++++++++------- tests/indexObj.test | 4 ++++ 5 files changed, 36 insertions(+), 14 deletions(-) diff --git a/doc/GetIndex.3 b/doc/GetIndex.3 index a788848..1af1663 100644 --- a/doc/GetIndex.3 +++ b/doc/GetIndex.3 @@ -54,7 +54,7 @@ Null-terminated string describing what is being looked up, such as .AP int flags in OR-ed combination of bits providing additional information for operation. The only bits that are currently defined are \fBTCL_EXACT\fR -and \fBTCL_INDEX_TEMP_TABLE\fR. +, \fBTCL_INDEX_TEMP_TABLE\fR, and \fBTCL_INDEX_NULL_OK\fR. .AP int *indexPtr out The index of the string in \fItablePtr\fR that matches the value of \fIobjPtr\fR is returned here. @@ -91,7 +91,9 @@ operation. Note: \fBTcl_GetIndexFromObj\fR assumes that the entries in \fItablePtr\fR are static: they must not change between invocations. This caching mechanism can be disallowed by specifying the \fBTCL_INDEX_TEMP_TABLE\fR flag. -If the value of \fIobjPtr\fR is the empty string, +If the \fBTCL_INDEX_NULL_OK\fR flag was specified, objPtr is allowed +to be NULL or the empty string. The resulting index is -1. +Otherwise, if the value of \fIobjPtr\fR is the empty string, \fBTcl_GetIndexFromObj\fR will treat it as a non-matching value and return \fBTCL_ERROR\fR. .PP diff --git a/generic/tcl.h b/generic/tcl.h index 346b79c..b82cf0a 100644 --- a/generic/tcl.h +++ b/generic/tcl.h @@ -979,10 +979,13 @@ typedef struct Tcl_DString { * TCL_EXACT disallows abbreviated strings. * TCL_INDEX_TEMP_TABLE disallows caching of lookups. A possible use case is * a table that will not live long enough to make it worthwhile. + * TCL_INDEX_NULL_OK allows the empty string or NULL to return TCL_OK. + * The returned value will be -1; */ #define TCL_EXACT 1 #define TCL_INDEX_TEMP_TABLE 2 +#define TCL_INDEX_NULL_OK 4 /* *---------------------------------------------------------------------------- diff --git a/generic/tclIndexObj.c b/generic/tclIndexObj.c index c2812ea..e9c453a 100644 --- a/generic/tclIndexObj.c +++ b/generic/tclIndexObj.c @@ -261,7 +261,7 @@ Tcl_GetIndexFromObjStruct( int offset, /* The number of bytes between entries */ const char *msg, /* Identifying word to use in error * messages. */ - int flags, /* 0 or TCL_EXACT */ + int flags, /* 0, TCL_EXACT, TCL_INDEX_TEMP_TABLE or TCL_INDEX_NULL_OK */ int *indexPtr) /* Place to store resulting integer index. */ { int index, idx, numAbbrev; @@ -280,7 +280,10 @@ Tcl_GetIndexFromObjStruct( * See if there is a valid cached result from a previous lookup. */ - if (!(flags & TCL_INDEX_TEMP_TABLE)) { + if (!objPtr && (flags & TCL_INDEX_NULL_OK)) { + *indexPtr = -1; + return TCL_OK; + } else if (objPtr && !(flags & TCL_INDEX_TEMP_TABLE)) { irPtr = TclFetchInternalRep(objPtr, &indexType); if (irPtr) { indexRep = (IndexRep *)irPtr->twoPtrValue.ptr1; @@ -296,10 +299,14 @@ Tcl_GetIndexFromObjStruct( * abbreviations unless TCL_EXACT is set in flags. */ - key = TclGetString(objPtr); + key = objPtr ? TclGetString(objPtr) : ""; index = -1; numAbbrev = 0; + if (!*key && (flags & TCL_INDEX_NULL_OK)) { + *indexPtr = -1; + return TCL_OK; + } /* * Scan the table looking for one of: * - An exact match (always preferred) @@ -344,7 +351,7 @@ Tcl_GetIndexFromObjStruct( * operation. */ - if (!(flags & TCL_INDEX_TEMP_TABLE)) { + if (objPtr && !(flags & TCL_INDEX_TEMP_TABLE)) { irPtr = TclFetchInternalRep(objPtr, &indexType); if (irPtr) { indexRep = (IndexRep *)irPtr->twoPtrValue.ptr1; @@ -386,7 +393,7 @@ Tcl_GetIndexFromObjStruct( *entryPtr, NULL); entryPtr = NEXT_ENTRY(entryPtr, offset); while (*entryPtr != NULL) { - if (*NEXT_ENTRY(entryPtr, offset) == NULL) { + if ((*NEXT_ENTRY(entryPtr, offset) == NULL) && !(flags & TCL_INDEX_NULL_OK)) { Tcl_AppendStringsToObj(resultPtr, (count > 0 ? "," : ""), " or ", *entryPtr, NULL); } else if (**entryPtr) { @@ -395,6 +402,9 @@ Tcl_GetIndexFromObjStruct( } entryPtr = NEXT_ENTRY(entryPtr, offset); } + if ((flags & TCL_INDEX_NULL_OK)) { + Tcl_AppendStringsToObj(resultPtr, ", or \"\"", NULL); + } } Tcl_SetObjResult(interp, resultPtr); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "INDEX", msg, key, NULL); diff --git a/generic/tclTest.c b/generic/tclTest.c index 46a1459..e18283d 100644 --- a/generic/tclTest.c +++ b/generic/tclTest.c @@ -6285,17 +6285,20 @@ TestGetIndexFromObjStructObjCmd( const char *const ary[] = { "a", "b", "c", "d", "e", "f", NULL, NULL }; - int idx,target; + int idx,target, flags = 0; - if (objc != 3) { - Tcl_WrongNumArgs(interp, 1, objv, "argument targetvalue"); + if (objc != 3 && objc != 4) { + Tcl_WrongNumArgs(interp, 1, objv, "argument targetvalue ?flags?"); return TCL_ERROR; } - if (Tcl_GetIndexFromObjStruct(interp, objv[1], ary, 2*sizeof(char *), - "dummy", 0, &idx) != TCL_OK) { + if (Tcl_GetIntFromObj(interp, objv[2], &target) != TCL_OK) { return TCL_ERROR; } - if (Tcl_GetIntFromObj(interp, objv[2], &target) != TCL_OK) { + if ((objc > 3) && (Tcl_GetIntFromObj(interp, objv[3], &flags) != TCL_OK)) { + return TCL_ERROR; + } + if (Tcl_GetIndexFromObjStruct(interp, (Tcl_GetString(objv[1])[0] ? objv[1] : NULL), ary, 2*sizeof(char *), + "dummy", flags, &idx) != TCL_OK) { return TCL_ERROR; } if (idx != target) { @@ -6307,7 +6310,7 @@ TestGetIndexFromObjStructObjCmd( Tcl_AppendResult(interp, " when ", buffer, " expected", NULL); return TCL_ERROR; } - Tcl_WrongNumArgs(interp, 3, objv, NULL); + Tcl_WrongNumArgs(interp, objc, objv, NULL); return TCL_OK; } diff --git a/tests/indexObj.test b/tests/indexObj.test index bd6a2c2..c615e15 100644 --- a/tests/indexObj.test +++ b/tests/indexObj.test @@ -131,6 +131,10 @@ test indexObj-6.4 {Tcl_GetIndexFromObjStruct} testindexobj { testgetindexfromobjstruct $x 1 testgetindexfromobjstruct $x 1 } "wrong # args: should be \"testgetindexfromobjstruct c 1\"" +test indexObj-6.5 {Tcl_GetIndexFromObjStruct} testindexobj { + set x "" + testgetindexfromobjstruct $x -1 4 +} "wrong # args: should be \"testgetindexfromobjstruct {} -1 4\"" test indexObj-7.1 {Tcl_ParseArgsObjv} testparseargs { testparseargs -- cgit v0.12 From 401b464a4d657490333388130b1fc7ae0d212646 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Sun, 12 Dec 2021 17:59:11 +0000 Subject: Fix [ac6792195d]: avoid signed integer overflow in BinaryEncodeUu() --- generic/tclBinary.c | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/generic/tclBinary.c b/generic/tclBinary.c index 0f8f77e..0296770 100644 --- a/generic/tclBinary.c +++ b/generic/tclBinary.c @@ -69,7 +69,7 @@ static void UpdateStringOfByteArray(Tcl_Obj *listPtr); static void DeleteScanNumberCache(Tcl_HashTable *numberCachePtr); static int NeedReversing(int format); static void CopyNumber(const void *from, void *to, - unsigned length, int type); + unsigned int length, int type); /* Binary ensemble commands */ static Tcl_ObjCmdProc BinaryFormatCmd; static Tcl_ObjCmdProc BinaryScanCmd; @@ -1649,7 +1649,7 @@ GetFormatSpec( (*formatPtr)++; *countPtr = BINARY_ALL; } else if (isdigit(UCHAR(**formatPtr))) { /* INTL: digit */ - unsigned long int count; + unsigned long count; errno = 0; count = strtoul(*formatPtr, (char **) formatPtr, 10); @@ -2599,7 +2599,8 @@ BinaryEncodeUu( { Tcl_Obj *resultObj; unsigned char *data, *start, *cursor; - int offset, count, rawLength, n, i, j, bits, index; + int offset, count, rawLength, i, j, bits, index; + unsigned int n; int lineLength = 61; const unsigned char SingleNewline[] = { UCHAR('\n') }; const unsigned char *wrapchar = SingleNewline; -- cgit v0.12 From 4d561210e91f94161688da0a87616ff34a6a7fcf Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 13 Dec 2021 10:35:19 +0000 Subject: Prevent crash in Tcl_GetIndexFromObj*() when objPtr == NULL. Just let it produce a normal error-message then. Also add some more type-casts --- generic/tclIndexObj.c | 52 +++++++++++++++++++++++++-------------------------- 1 file changed, 26 insertions(+), 26 deletions(-) diff --git a/generic/tclIndexObj.c b/generic/tclIndexObj.c index bdcd653..e2969c2 100644 --- a/generic/tclIndexObj.c +++ b/generic/tclIndexObj.c @@ -193,7 +193,7 @@ GetIndexFromObjList( * Build a string table from the list. */ - tablePtr = ckalloc((objc + 1) * sizeof(char *)); + tablePtr = (const char **)ckalloc((objc + 1) * sizeof(char *)); for (t = 0; t < objc; t++) { if (objv[t] == objPtr) { /* @@ -278,7 +278,7 @@ Tcl_GetIndexFromObjStruct( * See if there is a valid cached result from a previous lookup. */ - if (objPtr->typePtr == &indexType) { + if (objPtr && (objPtr->typePtr == &indexType)) { indexRep = objPtr->internalRep.twoPtrValue.ptr1; if (indexRep->tablePtr==tablePtr && indexRep->offset==offset) { *indexPtr = indexRep->index; @@ -291,7 +291,7 @@ Tcl_GetIndexFromObjStruct( * abbreviations unless TCL_EXACT is set in flags. */ - key = TclGetString(objPtr); + key = objPtr ? TclGetString(objPtr) : ""; index = -1; numAbbrev = 0; @@ -302,7 +302,7 @@ Tcl_GetIndexFromObjStruct( * - Several abbreviations (never allowed, but overridden by exact match) */ - for (entryPtr = tablePtr, idx = 0; *entryPtr != NULL; + for (entryPtr = (const char* const*)tablePtr, idx = 0; *entryPtr != NULL; entryPtr = NEXT_ENTRY(entryPtr, offset), idx++) { for (p1 = key, p2 = *entryPtr; *p1 == *p2; p1++, p2++) { if (*p1 == '\0') { @@ -339,17 +339,19 @@ Tcl_GetIndexFromObjStruct( * operation. */ - if (objPtr->typePtr == &indexType) { - indexRep = objPtr->internalRep.twoPtrValue.ptr1; - } else { - TclFreeIntRep(objPtr); - indexRep = ckalloc(sizeof(IndexRep)); - objPtr->internalRep.twoPtrValue.ptr1 = indexRep; - objPtr->typePtr = &indexType; + if (objPtr) { + if (objPtr->typePtr == &indexType) { + indexRep = objPtr->internalRep.twoPtrValue.ptr1; + } else { + TclFreeIntRep(objPtr); + indexRep = ckalloc(sizeof(IndexRep)); + objPtr->internalRep.twoPtrValue.ptr1 = indexRep; + objPtr->typePtr = &indexType; + } + indexRep->tablePtr = (void *) tablePtr; + indexRep->offset = offset; + indexRep->index = index; } - indexRep->tablePtr = (void *) tablePtr; - indexRep->offset = offset; - indexRep->index = index; *indexPtr = index; return TCL_OK; @@ -363,7 +365,7 @@ Tcl_GetIndexFromObjStruct( int count = 0; TclNewObj(resultPtr); - entryPtr = tablePtr; + entryPtr = (const char* const *)tablePtr; while ((*entryPtr != NULL) && !**entryPtr) { entryPtr = NEXT_ENTRY(entryPtr, offset); } @@ -414,7 +416,7 @@ static void UpdateStringOfIndex( Tcl_Obj *objPtr) { - IndexRep *indexRep = objPtr->internalRep.twoPtrValue.ptr1; + IndexRep *indexRep = (IndexRep *)objPtr->internalRep.twoPtrValue.ptr1; char *buf; unsigned len; const char *indexStr = EXPAND_OF(indexRep); @@ -449,8 +451,8 @@ DupIndex( Tcl_Obj *srcPtr, Tcl_Obj *dupPtr) { - IndexRep *srcIndexRep = srcPtr->internalRep.twoPtrValue.ptr1; - IndexRep *dupIndexRep = ckalloc(sizeof(IndexRep)); + IndexRep *srcIndexRep = (IndexRep *)srcPtr->internalRep.twoPtrValue.ptr1; + IndexRep *dupIndexRep = (IndexRep *)ckalloc(sizeof(IndexRep)); memcpy(dupIndexRep, srcIndexRep, sizeof(IndexRep)); dupPtr->internalRep.twoPtrValue.ptr1 = dupIndexRep; @@ -548,7 +550,7 @@ PrefixMatchObjCmd( static const char *const matchOptions[] = { "-error", "-exact", "-message", NULL }; - enum matchOptions { + enum matchOptionsEnum { PRFMATCH_ERROR, PRFMATCH_EXACT, PRFMATCH_MESSAGE }; @@ -562,7 +564,7 @@ PrefixMatchObjCmd( &index) != TCL_OK) { return TCL_ERROR; } - switch ((enum matchOptions) index) { + switch ((enum matchOptionsEnum) index) { case PRFMATCH_EXACT: flags |= TCL_EXACT; break; @@ -931,8 +933,7 @@ Tcl_WrongNumArgs( len = TclScanElement(elementStr, elemLen, &flags); if (MAY_QUOTE_WORD && len != elemLen) { - char *quotedElementStr = TclStackAlloc(interp, - (unsigned)len + 1); + char *quotedElementStr = (char *)TclStackAlloc(interp, len + 1); len = TclConvertElement(elementStr, elemLen, quotedElementStr, flags); @@ -982,8 +983,7 @@ Tcl_WrongNumArgs( len = TclScanElement(elementStr, elemLen, &flags); if (MAY_QUOTE_WORD && len != elemLen) { - char *quotedElementStr = TclStackAlloc(interp, - (unsigned) len + 1); + char *quotedElementStr = (char *)TclStackAlloc(interp, len + 1); len = TclConvertElement(elementStr, elemLen, quotedElementStr, flags); @@ -1089,7 +1089,7 @@ Tcl_ParseArgsObjv( */ nrem = 1; - leftovers = ckalloc((1 + *objcPtr) * sizeof(Tcl_Obj *)); + leftovers = (Tcl_Obj **)ckalloc((1 + *objcPtr) * sizeof(Tcl_Obj *)); leftovers[0] = objv[0]; } else { nrem = 0; @@ -1273,7 +1273,7 @@ Tcl_ParseArgsObjv( } leftovers[nrem] = NULL; *objcPtr = nrem++; - *remObjv = ckrealloc(leftovers, nrem * sizeof(Tcl_Obj *)); + *remObjv = (Tcl_Obj **)ckrealloc(leftovers, nrem * sizeof(Tcl_Obj *)); return TCL_OK; /* -- cgit v0.12 From f17186825609c292c275e963cefff8e953504e63 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 13 Dec 2021 11:39:15 +0000 Subject: Fix [41b1406f51]: AppendUtfToUtfRep(): undefined behavior involving pointers --- generic/tclStringObj.c | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/generic/tclStringObj.c b/generic/tclStringObj.c index 22e025c..e30b9af 100644 --- a/generic/tclStringObj.c +++ b/generic/tclStringObj.c @@ -1737,8 +1737,8 @@ AppendUtfToUtfRep( * the reallocs below. */ - if (bytes && bytes >= objPtr->bytes - && bytes <= objPtr->bytes + objPtr->length) { + if (bytes && objPtr->bytes && (bytes >= objPtr->bytes) + && (bytes <= objPtr->bytes + objPtr->length)) { offset = bytes - objPtr->bytes; } -- cgit v0.12 From cacd6930cf7caa54e575401e527dae2156bc8424 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 15 Dec 2021 16:58:08 +0000 Subject: Addendum to [41b1406f51]: change '<=' in range-check to '<' --- generic/tclStringObj.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/generic/tclStringObj.c b/generic/tclStringObj.c index e30b9af..234ad0f 100644 --- a/generic/tclStringObj.c +++ b/generic/tclStringObj.c @@ -1738,7 +1738,7 @@ AppendUtfToUtfRep( */ if (bytes && objPtr->bytes && (bytes >= objPtr->bytes) - && (bytes <= objPtr->bytes + objPtr->length)) { + && (bytes < objPtr->bytes + objPtr->length)) { offset = bytes - objPtr->bytes; } -- cgit v0.12 From 187de15e2bd4cc19b14e2a9b97ca1b12d847a2c9 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 15 Dec 2021 17:03:03 +0000 Subject: Fix [90612089d8]: signed integer overflow in ExprRandFunc() --- generic/tclBasic.c | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/generic/tclBasic.c b/generic/tclBasic.c index fb85241..1cc22e1 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -7781,15 +7781,15 @@ ExprRandFunc( * take into consideration the thread this interp is running in. */ - iPtr->randSeed = TclpGetClicks() + (PTR2INT(Tcl_GetCurrentThread())<<12); + iPtr->randSeed = TclpGetClicks() + ((unsigned long)PTR2UINT(Tcl_GetCurrentThread())*4093); /* * Make sure 1 <= randSeed <= (2^31) - 2. See below. */ - iPtr->randSeed &= (unsigned long) 0x7FFFFFFF; - if ((iPtr->randSeed == 0) || (iPtr->randSeed == 0x7FFFFFFF)) { - iPtr->randSeed ^= 123459876; + iPtr->randSeed &= 0x7FFFFFFFL; + if ((iPtr->randSeed == 0) || (iPtr->randSeed == 0x7FFFFFFFL)) { + iPtr->randSeed ^= 123459876L; } } -- cgit v0.12 From b95cae5898b3abfb286c5bd99cb00bdd14049eb7 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 16 Dec 2021 08:03:39 +0000 Subject: Undo prevous commit. See [41b1406f51] for the reason --- generic/tclStringObj.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/generic/tclStringObj.c b/generic/tclStringObj.c index 234ad0f..e30b9af 100644 --- a/generic/tclStringObj.c +++ b/generic/tclStringObj.c @@ -1738,7 +1738,7 @@ AppendUtfToUtfRep( */ if (bytes && objPtr->bytes && (bytes >= objPtr->bytes) - && (bytes < objPtr->bytes + objPtr->length)) { + && (bytes <= objPtr->bytes + objPtr->length)) { offset = bytes - objPtr->bytes; } -- cgit v0.12 From 76f73fbad9f75076442b2d7c0c4bab22583b26a4 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 16 Dec 2021 08:35:37 +0000 Subject: Fix [31e302fcf7]: signed integer overflow in generic/tclHash.c --- generic/tclHash.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/generic/tclHash.c b/generic/tclHash.c index bcf6eee..5de8168 100644 --- a/generic/tclHash.c +++ b/generic/tclHash.c @@ -35,7 +35,7 @@ */ #define RANDOM_INDEX(tablePtr, i) \ - ((((i)*1103515245L) >> (tablePtr)->downShift) & (tablePtr)->mask) + ((((i)*1103515245UL) >> (tablePtr)->downShift) & (tablePtr)->mask) /* * Prototypes for the array hash key methods. -- cgit v0.12 From fcc9c57804bed50e0acafd815c13b3426cb3f3d2 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 16 Dec 2021 09:02:59 +0000 Subject: Fix [6ef312dcf5]: memcpy() with NULL source in Tcl_CreateMathFunc() --- generic/tclBasic.c | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/generic/tclBasic.c b/generic/tclBasic.c index 875fec5..aebcab7 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -3551,7 +3551,9 @@ Tcl_CreateMathFunc( data->proc = proc; data->numArgs = numArgs; data->argTypes = (Tcl_ValueType *)ckalloc(numArgs * sizeof(Tcl_ValueType)); - memcpy(data->argTypes, argTypes, numArgs * sizeof(Tcl_ValueType)); + if ((numArgs > 0) && (argTypes != NULL)) { + memcpy(data->argTypes, argTypes, numArgs * sizeof(Tcl_ValueType)); + } data->clientData = clientData; Tcl_DStringInit(&bigName); -- cgit v0.12 From 22325d1e0843a7d1511f7ec81a4958939ab3faaf Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 16 Dec 2021 12:09:11 +0000 Subject: Add 2 new testcases, for Tcl_GetIndexFromObjStruct with TCL_EXACT flag and for Tcl_GetIndexFromObjStruct with NULL argument --- generic/tclIndexObj.c | 8 ++++---- generic/tclTest.c | 27 +++++++++++++++------------ tests/indexObj.test | 32 ++++++++++++++++++++------------ 3 files changed, 39 insertions(+), 28 deletions(-) diff --git a/generic/tclIndexObj.c b/generic/tclIndexObj.c index e2969c2..efa7373 100644 --- a/generic/tclIndexObj.c +++ b/generic/tclIndexObj.c @@ -105,7 +105,7 @@ int Tcl_GetIndexFromObj( Tcl_Interp *interp, /* Used for error reporting if not NULL. */ Tcl_Obj *objPtr, /* Object containing the string to lookup. */ - const char *const*tablePtr, /* Array of strings to compare against the + const char *const *tablePtr, /* Array of strings to compare against the * value of objPtr; last entry must be NULL * and there must not be duplicate entries. */ const char *msg, /* Identifying word to use in error @@ -128,7 +128,7 @@ Tcl_GetIndexFromObj( * on odd platforms like a Cray PVP... */ - if (indexRep->tablePtr == (void *) tablePtr + if (indexRep->tablePtr == (void *)tablePtr && indexRep->offset == sizeof(char *)) { *indexPtr = indexRep->index; return TCL_OK; @@ -302,7 +302,7 @@ Tcl_GetIndexFromObjStruct( * - Several abbreviations (never allowed, but overridden by exact match) */ - for (entryPtr = (const char* const*)tablePtr, idx = 0; *entryPtr != NULL; + for (entryPtr = (const char *const *)tablePtr, idx = 0; *entryPtr != NULL; entryPtr = NEXT_ENTRY(entryPtr, offset), idx++) { for (p1 = key, p2 = *entryPtr; *p1 == *p2; p1++, p2++) { if (*p1 == '\0') { @@ -365,7 +365,7 @@ Tcl_GetIndexFromObjStruct( int count = 0; TclNewObj(resultPtr); - entryPtr = (const char* const *)tablePtr; + entryPtr = (const char *const *)tablePtr; while ((*entryPtr != NULL) && !**entryPtr) { entryPtr = NEXT_ENTRY(entryPtr, offset); } diff --git a/generic/tclTest.c b/generic/tclTest.c index a759e74..5774dfc 100644 --- a/generic/tclTest.c +++ b/generic/tclTest.c @@ -1622,7 +1622,7 @@ TestdoubledigitsObjCmd(ClientData unused, Tcl_Obj* const objv[]) /* Parameter vector */ { - static const char* options[] = { + static const char *options[] = { "shortest", "Steele", "e", @@ -1643,8 +1643,8 @@ TestdoubledigitsObjCmd(ClientData unused, int type; int decpt; int signum; - char* str; - char* endPtr; + char * str; + char *endPtr; Tcl_Obj* strObj; Tcl_Obj* retval; @@ -1759,7 +1759,7 @@ TestdstringCmd( strcpy(s, "This is a malloc-ed string"); Tcl_SetResult(interp, s, TCL_DYNAMIC); } else if (strcmp(argv[2], "special") == 0) { - char *s = (char*)ckalloc(100) + 16; + char *s = (char *)ckalloc(100) + 16; strcpy(s, "This is a specially-allocated string"); Tcl_SetResult(interp, s, SpecialFree); } else { @@ -6176,19 +6176,22 @@ TestGetIndexFromObjStructObjCmd( Tcl_Obj *const objv[]) /* Argument objects. */ { const char *const ary[] = { - "a", "b", "c", "d", "e", "f", NULL, NULL + "a", "b", "c", "d", "ee", "ff", NULL, NULL }; - int idx,target; + int idx,target, flags = 0; - if (objc != 3) { - Tcl_WrongNumArgs(interp, 1, objv, "argument targetvalue"); + if (objc != 3 && objc != 4) { + Tcl_WrongNumArgs(interp, 1, objv, "argument targetvalue ?flags?"); return TCL_ERROR; } - if (Tcl_GetIndexFromObjStruct(interp, objv[1], ary, 2*sizeof(char *), - "dummy", 0, &idx) != TCL_OK) { + if (Tcl_GetIntFromObj(interp, objv[2], &target) != TCL_OK) { return TCL_ERROR; } - if (Tcl_GetIntFromObj(interp, objv[2], &target) != TCL_OK) { + if ((objc > 3) && (Tcl_GetIntFromObj(interp, objv[3], &flags) != TCL_OK)) { + return TCL_ERROR; + } + if (Tcl_GetIndexFromObjStruct(interp, (Tcl_GetString(objv[1])[0] ? objv[1] : NULL), ary, 2*sizeof(char *), + "dummy", flags, &idx) != TCL_OK) { return TCL_ERROR; } if (idx != target) { @@ -6200,7 +6203,7 @@ TestGetIndexFromObjStructObjCmd( Tcl_AppendResult(interp, " when ", buffer, " expected", NULL); return TCL_ERROR; } - Tcl_WrongNumArgs(interp, 3, objv, NULL); + Tcl_WrongNumArgs(interp, objc, objv, NULL); return TCL_OK; } diff --git a/tests/indexObj.test b/tests/indexObj.test index 60ee61a..b992373 100644 --- a/tests/indexObj.test +++ b/tests/indexObj.test @@ -3,7 +3,7 @@ # organized in the standard fashion for Tcl tests. # # Copyright (c) 1997 Sun Microsystems, Inc. -# Copyright (c) 1998-1999 by Scriptics Corporation. +# Copyright (c) 1998-1999 Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. @@ -91,46 +91,54 @@ test indexObj-4.1 {free old internal representation} testindexobj { test indexObj-5.1 {Tcl_WrongNumArgs} testindexobj { testwrongnumargs 1 "?-switch?" mycmd -} "wrong # args: should be \"mycmd ?-switch?\"" +} {wrong # args: should be "mycmd ?-switch?"} test indexObj-5.2 {Tcl_WrongNumArgs} testindexobj { testwrongnumargs 2 "bar" mycmd foo -} "wrong # args: should be \"mycmd foo bar\"" +} {wrong # args: should be "mycmd foo bar"} test indexObj-5.3 {Tcl_WrongNumArgs} testindexobj { testwrongnumargs 0 "bar" mycmd foo -} "wrong # args: should be \"bar\"" +} {wrong # args: should be "bar"} test indexObj-5.4 {Tcl_WrongNumArgs} testindexobj { testwrongnumargs 0 "" mycmd foo -} "wrong # args: should be \"\"" +} {wrong # args: should be ""} test indexObj-5.5 {Tcl_WrongNumArgs} testindexobj { testwrongnumargs 1 "" mycmd foo -} "wrong # args: should be \"mycmd\"" +} {wrong # args: should be "mycmd"} test indexObj-5.6 {Tcl_WrongNumArgs} testindexobj { testwrongnumargs 2 "" mycmd foo -} "wrong # args: should be \"mycmd foo\"" +} {wrong # args: should be "mycmd foo"} # Contrast this with test proc-3.6; they have to be like this because # of [Bug 1066837] so Itcl won't break. test indexObj-5.7 {Tcl_WrongNumArgs} testindexobj { testwrongnumargs 2 "fee fi" "fo fum" foo bar -} "wrong # args: should be \"fo fum foo fee fi\"" +} {wrong # args: should be "fo fum foo fee fi"} test indexObj-6.1 {Tcl_GetIndexFromObjStruct} testindexobj { set x a testgetindexfromobjstruct $x 0 -} "wrong # args: should be \"testgetindexfromobjstruct a 0\"" +} {wrong # args: should be "testgetindexfromobjstruct a 0"} test indexObj-6.2 {Tcl_GetIndexFromObjStruct} testindexobj { set x a testgetindexfromobjstruct $x 0 testgetindexfromobjstruct $x 0 -} "wrong # args: should be \"testgetindexfromobjstruct a 0\"" +} {wrong # args: should be "testgetindexfromobjstruct a 0"} test indexObj-6.3 {Tcl_GetIndexFromObjStruct} testindexobj { set x c testgetindexfromobjstruct $x 1 -} "wrong # args: should be \"testgetindexfromobjstruct c 1\"" +} {wrong # args: should be "testgetindexfromobjstruct c 1"} test indexObj-6.4 {Tcl_GetIndexFromObjStruct} testindexobj { set x c testgetindexfromobjstruct $x 1 testgetindexfromobjstruct $x 1 -} "wrong # args: should be \"testgetindexfromobjstruct c 1\"" +} {wrong # args: should be "testgetindexfromobjstruct c 1"} +test indexObj-6.5 {Tcl_GetIndexFromObjStruct with TCL_EXACT flag} -constraints testindexobj -body { + set x e + testgetindexfromobjstruct $x 0 1 +} -returnCodes error -result {bad dummy "e": must be a, c, or ee} +test indexObj-6.6 {Tcl_GetIndexFromObjStruct with NULL input} -constraints testindexobj -body { + set x "" + testgetindexfromobjstruct $x 0 +} -returnCodes error -result {ambiguous dummy "": must be a, c, or ee} test indexObj-7.1 {Tcl_ParseArgsObjv} testparseargs { testparseargs -- cgit v0.12 From 6a3a8ae8ff86616bd067ce4fdc775550903afab9 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 16 Dec 2021 21:02:15 +0000 Subject: Suggested fix for [b0f84119c8]: TEBCresume(): undefined behavior for INST_LSHIFT --- generic/tclExecute.c | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/generic/tclExecute.c b/generic/tclExecute.c index 8963472..7e014d4 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -6379,10 +6379,10 @@ TEBCresume( * Handle shifts within the native long range. */ - if ((size_t) shift < CHAR_BIT*sizeof(long) && (l1 != 0) + if (((size_t) shift < CHAR_BIT*sizeof(long)) && !((l1>0 ? l1 : ~l1) & - -(1L<<(CHAR_BIT*sizeof(long) - 1 - shift)))) { - lResult = l1 << shift; + -(1UL<<(CHAR_BIT*sizeof(long) - 1 - shift)))) { + lResult = (unsigned long)l1 << shift; goto longResultOfArithmetic; } } -- cgit v0.12 From f3edde2f64fa0a8ca5db52a25ae371832a9af65b Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 16 Dec 2021 21:25:52 +0000 Subject: Fix [d1434179b5]: avoid signed integer overflow in AppendUtfToUtfRep() --- generic/tclStringObj.c | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/generic/tclStringObj.c b/generic/tclStringObj.c index e30b9af..75b449d 100644 --- a/generic/tclStringObj.c +++ b/generic/tclStringObj.c @@ -1722,10 +1722,10 @@ AppendUtfToUtfRep( objPtr->length = 0; } oldLength = objPtr->length; - newLength = numBytes + oldLength; - if (newLength < 0) { + if (numBytes > INT_MAX - oldLength) { Tcl_Panic("max size for a Tcl value (%d bytes) exceeded", INT_MAX); } + newLength = numBytes + oldLength; stringPtr = GET_STRING(objPtr); if (newLength > stringPtr->allocated) { -- cgit v0.12 From a128b4d651075c9263df3e8959beaac5a403e54d Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Sat, 18 Dec 2021 15:03:29 +0000 Subject: Fix [5507a9c096]: Small error on https://www.tcl.tk/man/tcl/TclCmd/try.html --- doc/try.n | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/doc/try.n b/doc/try.n index eae4dc7..992dcea 100644 --- a/doc/try.n +++ b/doc/try.n @@ -87,7 +87,7 @@ Handle different reasons for a file to not be openable for reading: .PP .CS \fBtry\fR { - set f [open /some/file/name w] + set f [open /some/file/name r] } \fBtrap\fR {POSIX EISDIR} {} { puts "failed to open /some/file/name: it's a directory" } \fBtrap\fR {POSIX ENOENT} {} { -- cgit v0.12 From f60e1647996f8494c8eb64899086f74a43dc0120 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Sat, 18 Dec 2021 18:55:50 +0000 Subject: Make it impossible for the indexType object to cache negative index values. And - if it happens - at least don't crash on it. --- generic/tclIndexObj.c | 8 +++++--- 1 file changed, 5 insertions(+), 3 deletions(-) diff --git a/generic/tclIndexObj.c b/generic/tclIndexObj.c index efa7373..8911f00 100644 --- a/generic/tclIndexObj.c +++ b/generic/tclIndexObj.c @@ -73,7 +73,7 @@ typedef struct { #define NEXT_ENTRY(table, offset) \ (&(STRING_AT(table, offset))) #define EXPAND_OF(indexRep) \ - STRING_AT((indexRep)->tablePtr, (indexRep)->offset*(indexRep)->index) + (((indexRep)->index >= 0) ? STRING_AT((indexRep)->tablePtr, (indexRep)->offset*(indexRep)->index) : "") /* *---------------------------------------------------------------------- @@ -280,7 +280,9 @@ Tcl_GetIndexFromObjStruct( if (objPtr && (objPtr->typePtr == &indexType)) { indexRep = objPtr->internalRep.twoPtrValue.ptr1; - if (indexRep->tablePtr==tablePtr && indexRep->offset==offset) { + if ((indexRep->tablePtr == tablePtr) + && (indexRep->offset == offset) + && (indexRep->index >= 0)) { *indexPtr = indexRep->index; return TCL_OK; } @@ -339,7 +341,7 @@ Tcl_GetIndexFromObjStruct( * operation. */ - if (objPtr) { + if (objPtr && (index >= 0)) { if (objPtr->typePtr == &indexType) { indexRep = objPtr->internalRep.twoPtrValue.ptr1; } else { -- cgit v0.12 From ead6c0d0543e7a3ccb5a45d79554f7852d70a1df Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 20 Dec 2021 00:58:30 +0000 Subject: Unbreak windows build caused by [066a9b81b8|this] commit --- generic/tclExecute.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/generic/tclExecute.c b/generic/tclExecute.c index bbb7dee..765b726 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -6020,7 +6020,7 @@ TEBCresume( if (((size_t) shift < CHAR_BIT*sizeof(long)) && !((w1>0 ? w1 : ~w1) & -(1UL<<(CHAR_BIT*sizeof(long) - 1 - shift)))) { - wResult = (unsigned long)w1 << shift; + wResult = (Tcl_WideUInt)w1 << shift; goto wideResultOfArithmetic; } } -- cgit v0.12 From 48cff4f47c0343d658ad32b1763b8461e9c71114 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 20 Dec 2021 14:10:05 +0000 Subject: formatting --- generic/tclTest.c | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/generic/tclTest.c b/generic/tclTest.c index 1c9e605..7b97a65 100644 --- a/generic/tclTest.c +++ b/generic/tclTest.c @@ -6286,7 +6286,7 @@ TestGetIndexFromObjStructObjCmd( "a", "b", "c", "d", "ee", "ff", NULL, NULL }; int target, flags = 0; - signed char idx[8]; + signed char idx[8]; if (objc != 3 && objc != 4) { Tcl_WrongNumArgs(interp, 1, objv, "argument targetvalue ?flags?"); @@ -6300,15 +6300,15 @@ TestGetIndexFromObjStructObjCmd( } memset(idx, 85, sizeof(idx)); if (Tcl_GetIndexFromObjStruct(interp, (Tcl_GetString(objv[1])[0] ? objv[1] : NULL), ary, 2*sizeof(char *), - "dummy", flags, &idx[0]) != TCL_OK) { + "dummy", flags, &idx[1]) != TCL_OK) { return TCL_ERROR; } - if (idx[1] != 85) { - Tcl_AppendResult(interp, "Tcl_GetIndexFromObjStruct overwrites size", NULL); + if (idx[0] != 85 || idx[2] != 85) { + Tcl_AppendResult(interp, "Tcl_GetIndexFromObjStruct overwrites bytes near index variable", NULL); return TCL_ERROR; - } else if (idx[0] != target) { + } else if (idx[1] != target) { char buffer[64]; - sprintf(buffer, "%d", idx[0]); + sprintf(buffer, "%d", idx[1]); Tcl_AppendResult(interp, "index value comparison failed: got ", buffer, NULL); sprintf(buffer, "%d", target); -- cgit v0.12 From fc5ef30f8cb501a35c696d8356e1e89e3004efaa Mon Sep 17 00:00:00 2001 From: oehhar Date: Mon, 20 Dec 2021 14:38:13 +0000 Subject: binary encode/decode hex: document upper/lower character use. --- doc/binary.n | 2 ++ 1 file changed, 2 insertions(+) diff --git a/doc/binary.n b/doc/binary.n index 43df4cc..d39fd11 100644 --- a/doc/binary.n +++ b/doc/binary.n @@ -87,6 +87,8 @@ RFC 2045 calls for base64 decoders to be non-strict. . The \fBhex\fR binary encoding converts each byte to a pair of hexadecimal digits that represent the byte value as a hexadecimal integer. +When encoding, lower characters are used. +When decoding, upper and lower characters are accepted. .RS .PP No options are supported during encoding. During decoding, the following -- cgit v0.12 From c220ae0d43a2ad241eeedde1f7b0c14ed90d36b2 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 7 Jan 2022 17:17:09 +0000 Subject: Fix [0386e9a967]: Bitrot in tclZlib.c --- generic/tclZipfs.c | 106 ++++++++++++++++++++++++++++++++--------------------- generic/tclZlib.c | 12 +++--- 2 files changed, 70 insertions(+), 48 deletions(-) diff --git a/generic/tclZipfs.c b/generic/tclZipfs.c index 98a2820..d9c6712 100644 --- a/generic/tclZipfs.c +++ b/generic/tclZipfs.c @@ -36,6 +36,39 @@ #include #endif +/* + * Macros to report errors only if an interp is present. + */ + +#define ZIPFS_ERROR(interp,errstr) \ + do { \ + if (interp) { \ + Tcl_SetObjResult(interp, Tcl_NewStringObj(errstr, -1)); \ + } \ + } while (0) +#define ZIPFS_MEM_ERROR(interp) \ + do { \ + if (interp) { \ + Tcl_SetObjResult(interp, Tcl_NewStringObj( \ + "out of memory", -1)); \ + Tcl_SetErrorCode(interp, "TCL", "MALLOC", NULL); \ + } \ + } while (0) +#define ZIPFS_POSIX_ERROR(interp,errstr) \ + do { \ + if (interp) { \ + Tcl_SetObjResult(interp, Tcl_ObjPrintf( \ + "%s: %s", errstr, Tcl_PosixError(interp))); \ + } \ + } while (0) +#define ZIPFS_ERROR_CODE(interp,errcode) \ + do { \ + if (interp) { \ + Tcl_SetErrorCode(interp, "TCL", "ZIPFS", errcode, NULL); \ + } \ + } while (0) + + #ifdef HAVE_ZLIB #include "zlib.h" #include "crypt.h" @@ -125,38 +158,6 @@ #define DEFAULT_WRITE_MAX_SIZE (2 * 1024 * 1024) /* - * Macros to report errors only if an interp is present. - */ - -#define ZIPFS_ERROR(interp,errstr) \ - do { \ - if (interp) { \ - Tcl_SetObjResult(interp, Tcl_NewStringObj(errstr, -1)); \ - } \ - } while (0) -#define ZIPFS_MEM_ERROR(interp) \ - do { \ - if (interp) { \ - Tcl_SetObjResult(interp, Tcl_NewStringObj( \ - "out of memory", -1)); \ - Tcl_SetErrorCode(interp, "TCL", "MALLOC", NULL); \ - } \ - } while (0) -#define ZIPFS_POSIX_ERROR(interp,errstr) \ - do { \ - if (interp) { \ - Tcl_SetObjResult(interp, Tcl_ObjPrintf( \ - "%s: %s", errstr, Tcl_PosixError(interp))); \ - } \ - } while (0) -#define ZIPFS_ERROR_CODE(interp,errcode) \ - do { \ - if (interp) { \ - Tcl_SetErrorCode(interp, "TCL", "ZIPFS", errcode, NULL); \ - } \ - } while (0) - -/* * Windows drive letters. */ @@ -5707,6 +5708,8 @@ TclZipfs_Init( #endif /* HAVE_ZLIB */ } +#ifdef HAVE_ZLIB + #if !defined(STATIC_BUILD) static int ZipfsAppHookFindTclInit( @@ -5791,7 +5794,7 @@ ZipfsMountExitHandler( } } - + /* *------------------------------------------------------------------------- * @@ -5927,7 +5930,7 @@ TclZipfs_AppHook( return version; } -#ifndef HAVE_ZLIB +#else /* !HAVE_ZLIB */ /* *------------------------------------------------------------------------- @@ -5942,9 +5945,9 @@ TclZipfs_AppHook( int TclZipfs_Mount( Tcl_Interp *interp, /* Current interpreter. */ - const char *mountPoint, /* Mount point path. */ - const char *zipname, /* Path to ZIP file to mount. */ - const char *passwd) /* Password for opening the ZIP, or NULL if + TCL_UNUSED(const char *), /* Mount point path. */ + TCL_UNUSED(const char *), /* Path to ZIP file to mount. */ + TCL_UNUSED(const char *)) /* Password for opening the ZIP, or NULL if * the ZIP is unprotected. */ { ZIPFS_ERROR(interp, "no zlib available"); @@ -5955,10 +5958,10 @@ TclZipfs_Mount( int TclZipfs_MountBuffer( Tcl_Interp *interp, /* Current interpreter. NULLable. */ - const char *mountPoint, /* Mount point path. */ - unsigned char *data, - size_t datalen, - int copy) + TCL_UNUSED(const char *), /* Mount point path. */ + TCL_UNUSED(unsigned char *), + TCL_UNUSED(size_t), + TCL_UNUSED(int)) { ZIPFS_ERROR(interp, "no zlib available"); ZIPFS_ERROR_CODE(interp, "NO_ZLIB"); @@ -5968,12 +5971,31 @@ TclZipfs_MountBuffer( int TclZipfs_Unmount( Tcl_Interp *interp, /* Current interpreter. */ - const char *mountPoint) /* Mount point path. */ + TCL_UNUSED(const char *)) /* Mount point path. */ { ZIPFS_ERROR(interp, "no zlib available"); ZIPFS_ERROR_CODE(interp, "NO_ZLIB"); return TCL_ERROR; } + +const char * +TclZipfs_AppHook( + TCL_UNUSED(int *), /*argcPtr*/ +#ifdef _WIN32 + TCL_UNUSED(WCHAR ***)) /* argvPtr */ +#else /* !_WIN32 */ + TCL_UNUSED(char ***)) /* Pointer to argv */ +#endif /* _WIN32 */ +{ + return NULL; +} + +Tcl_Obj * +TclZipfs_TclLibrary(void) +{ + return NULL; +} + #endif /* !HAVE_ZLIB */ /* diff --git a/generic/tclZlib.c b/generic/tclZlib.c index c9bc77f..daf2a91 100644 --- a/generic/tclZlib.c +++ b/generic/tclZlib.c @@ -4072,18 +4072,18 @@ Tcl_ZlibInflate( unsigned int Tcl_ZlibCRC32( - unsigned int crc, - const char *buf, - int len) + TCL_UNUSED(unsigned int), + TCL_UNUSED(const unsigned char *), + TCL_UNUSED(int)) { return 0; } unsigned int Tcl_ZlibAdler32( - unsigned int adler, - const char *buf, - int len) + TCL_UNUSED(unsigned int), + TCL_UNUSED(const unsigned char *), + TCL_UNUSED(int)) { return 0; } -- cgit v0.12 From 5608e51a46c5ddb594d05a3d9cbeace701b5dcc6 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 7 Jan 2022 19:52:34 +0000 Subject: tcltk-man2html-utils.tcl: Before doing a "string range", check if that makes sense at all --- tools/tcltk-man2html-utils.tcl | 24 +++++++++++++++++------- 1 file changed, 17 insertions(+), 7 deletions(-) diff --git a/tools/tcltk-man2html-utils.tcl b/tools/tcltk-man2html-utils.tcl index bdd6065..6e4f1fb 100644 --- a/tools/tcltk-man2html-utils.tcl +++ b/tools/tcltk-man2html-utils.tcl @@ -889,7 +889,9 @@ proc insert-cross-references {text} { } switch -exact -- $invert([lindex $offsets 1]) { end-quote { - append result [string range $text 0 [expr {$offset(quote)-1}]] + if {$offset(quote) > 0} { + append result [string range $text 0 [expr {$offset(quote)-1}]] + } set body [string range $text [expr {$offset(quote)+2}] \ [expr {$offset(end-quote)-1}]] set text [string range $text[set text ""] \ @@ -916,8 +918,10 @@ proc insert-cross-references {text} { } switch -exact -- $invert([lindex $offsets 1]) { url - end-bold { - append result \ - [string range $text 0 [expr {$offset(bold)-1}]] + if {$offset(bold) > 0} { + append result \ + [string range $text 0 [expr {$offset(bold)-1}]] + } set body [string range $text [expr {$offset(bold)+3}] \ [expr {$offset(end-bold)-1}]] set text [string range $text[set text ""] \ @@ -939,8 +943,10 @@ proc insert-cross-references {text} { } } c.tk - c.ttk - c.tcl - c.tdbc - c.itcl { - append result [string range $text 0 \ - [expr {[lindex $offsets 0]-1}]] + if {[lindex $offsets 0] > 0} { + append result [string range $text 0 \ + [expr {[lindex $offsets 0]-1}]] + } regexp -indices -start [lindex $offsets 0] {\w+} $text range set body [string range $text {*}$range] set text [string range $text[set text ""] \ @@ -950,14 +956,18 @@ proc insert-cross-references {text} { } Tcl1 - Tcl2 { set off [lindex $offsets 0] - append result [string range $text 0 [expr {$off-1}]] + if {$off > 0} { + append result [string range $text 0 [expr {$off-1}]] + } set text [string range $text[set text ""] [expr {$off+3}] end] append result [cross-reference Tcl] continue } url { set off [lindex $offsets 0] - append result [string range $text 0 [expr {$off-1}]] + if {$off > 0} { + append result [string range $text 0 [expr {$off-1}]] + } regexp -indices -start $off {http://[\w/.-]+} $text range set url [string range $text {*}$range] append result "$url" -- cgit v0.12 From 2161463b5bc87cbef712465067c0b4fde52a699d Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Sun, 9 Jan 2022 16:54:08 +0000 Subject: Rename "testConstraint nodep" to "testConstraint deprecated", making it the same as in Tk --- tests/info.test | 2 +- tests/regexp.test | 2 +- tests/regexpComp.test | 2 +- tests/string.test | 8 ++++---- tests/stringObj.test | 8 ++++---- tests/tcltests.tcl | 2 +- 6 files changed, 12 insertions(+), 12 deletions(-) diff --git a/tests/info.test b/tests/info.test index 46f85e7..c17588f 100644 --- a/tests/info.test +++ b/tests/info.test @@ -101,7 +101,7 @@ test info-2.5 {info body option, returning bytecompiled bodies} -body { # Fix for problem tested for in info-2.5 caused problems when # procedure body had no string rep (i.e. was not yet bytecode) # causing an empty string to be returned [Bug #545644] -test info-2.6 {info body option, returning list bodies} nodep { +test info-2.6 {info body option, returning list bodies} deprecated { proc foo args [list subst bar] list [string bytelength [info body foo]] \ [foo; string bytelength [info body foo]] diff --git a/tests/regexp.test b/tests/regexp.test index a44f2e3..f0f05a0 100644 --- a/tests/regexp.test +++ b/tests/regexp.test @@ -765,7 +765,7 @@ test regexp-19.2 {regsub null replacement} { string equal $result $expected } 1 -test regexp-20.1 {regsub shared object shimmering} -constraints nodep -body { +test regexp-20.1 {regsub shared object shimmering} -constraints deprecated -body { # Bug #461322 set a abcdefghijklmnopqurstuvwxyz set b $a diff --git a/tests/regexpComp.test b/tests/regexpComp.test index e78c0df..a556b7a 100644 --- a/tests/regexpComp.test +++ b/tests/regexpComp.test @@ -793,7 +793,7 @@ test regexpComp-19.1 {regsub null replacement} { } } "\0a\0hel\0a\0lo\0a\0 14" -test regexpComp-20.1 {regsub shared object shimmering} nodep { +test regexpComp-20.1 {regsub shared object shimmering} deprecated { evalInProc { # Bug #461322 set a abcdefghijklmnopqurstuvwxyz diff --git a/tests/string.test b/tests/string.test index 6750a5c..7da50e9 100644 --- a/tests/string.test +++ b/tests/string.test @@ -1036,16 +1036,16 @@ test string-7.16.$noComp {string last, start index} { run {string last Üa ÜadÜad end-1} } 3 -test string-8.1.$noComp {string bytelength} nodep { +test string-8.1.$noComp {string bytelength} deprecated { list [catch {run {string bytelength}} msg] $msg } {1 {wrong # args: should be "string bytelength string"}} -test string-8.2.$noComp {string bytelength} nodep { +test string-8.2.$noComp {string bytelength} deprecated { list [catch {run {string bytelength a b}} msg] $msg } {1 {wrong # args: should be "string bytelength string"}} -test string-8.3.$noComp {string bytelength} nodep { +test string-8.3.$noComp {string bytelength} deprecated { run {string bytelength "\xC7"} } 2 -test string-8.4.$noComp {string bytelength} nodep { +test string-8.4.$noComp {string bytelength} deprecated { run {string b ""} } 0 diff --git a/tests/stringObj.test b/tests/stringObj.test index 4402185..abe02b2 100644 --- a/tests/stringObj.test +++ b/tests/stringObj.test @@ -455,19 +455,19 @@ 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 nodep} { +test stringObj-15.5 {Tcl_Append*ToObj: self appends} {testobj tip389 deprecated} { teststringobj set 1 foo teststringobj appendself2 1 0 } foofoo -test stringObj-15.6 {Tcl_Append*ToObj: self appends} {testobj tip389 nodep} { +test stringObj-15.6 {Tcl_Append*ToObj: self appends} {testobj tip389 deprecated} { teststringobj set 1 foo teststringobj appendself2 1 1 } foooo -test stringObj-15.7 {Tcl_Append*ToObj: self appends} {testobj tip389 nodep} { +test stringObj-15.7 {Tcl_Append*ToObj: self appends} {testobj tip389 deprecated} { teststringobj set 1 foo teststringobj appendself2 1 2 } fooo -test stringObj-15.8 {Tcl_Append*ToObj: self appends} {testobj tip389 nodep} { +test stringObj-15.8 {Tcl_Append*ToObj: self appends} {testobj tip389 deprecated} { teststringobj set 1 foo teststringobj appendself2 1 3 } foo diff --git a/tests/tcltests.tcl b/tests/tcltests.tcl index 61076f5..cc0d6a7 100644 --- a/tests/tcltests.tcl +++ b/tests/tcltests.tcl @@ -3,7 +3,7 @@ package require tcltest 2.5 namespace import ::tcltest::* testConstraint exec [llength [info commands exec]] -testConstraint nodep [expr {![tcl::build-info no-deprecate]}] +testConstraint deprecated [expr {![tcl::build-info no-deprecate]}] testConstraint debug [tcl::build-info debug] testConstraint purify [tcl::build-info purify] testConstraint debugpurify [ -- cgit v0.12 From 2fa8967c62a728986e69c0adfcc433c8da2d6dd4 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 12 Jan 2022 14:19:04 +0000 Subject: Proposed fix for [26f1328a86]: sizeof(int) < sizeof(void*) -> Crash --- generic/tclCompile.h | 18 +++++++++--------- 1 file changed, 9 insertions(+), 9 deletions(-) diff --git a/generic/tclCompile.h b/generic/tclCompile.h index 03b4a90..997f08e 100644 --- a/generic/tclCompile.h +++ b/generic/tclCompile.h @@ -1509,22 +1509,22 @@ MODULE_SCOPE int TclPushProcCallFrame(ClientData clientData, # define TclGetInt1AtPtr(p) ((int) *((signed char *) p)) #else # define TclGetInt1AtPtr(p) \ - (((int) *((char *) p)) | ((*(p) & 0200) ? (-256) : 0)) + ((int) ((*((char *) p)) | ((*(p) & 0200) ? (-256) : 0))) #endif #define TclGetInt4AtPtr(p) \ - (((int) (TclGetUInt1AtPtr(p) << 24)) | \ - (*((p)+1) << 16) | \ - (*((p)+2) << 8) | \ - (*((p)+3))) + ((int) ((TclGetUInt1AtPtr(p) << 24) | \ + (*((p)+1) << 16) | \ + (*((p)+2) << 8) | \ + (*((p)+3)))) #define TclGetUInt1AtPtr(p) \ ((unsigned int) *(p)) #define TclGetUInt4AtPtr(p) \ - ((unsigned int) (*(p) << 24) | \ - (*((p)+1) << 16) | \ - (*((p)+2) << 8) | \ - (*((p)+3))) + ((unsigned int) ((*(p) << 24) | \ + (*((p)+1) << 16) | \ + (*((p)+2) << 8) | \ + (*((p)+3)))) /* * Macros used to compute the minimum and maximum of two integers. The ANSI C -- cgit v0.12 From 2171b321cf1ec2d7c671d02dfea59860bccc06f2 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 12 Jan 2022 15:50:30 +0000 Subject: Fix [69218ab7b]: TEBCResume(): buffer over-read in INST_STR_MAP --- generic/tclExecute.c | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/generic/tclExecute.c b/generic/tclExecute.c index 7e014d4..aa5730a 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -5855,7 +5855,9 @@ TEBCresume( p = ustring1; end = ustring1 + length; for (; ustring1 < end; ustring1++) { - if ((*ustring1 == *ustring2) && (length2==1 || + if ((*ustring1 == *ustring2) && + /* Fix bug [69218ab7b]: restrict max compare length. */ + (end-ustring1 >= length2) && (length2==1 || memcmp(ustring1, ustring2, sizeof(Tcl_UniChar) * length2) == 0)) { if (p != ustring1) { -- cgit v0.12 From 05dc6d00c28c40fef2b65cf96d5753927599c4d5 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 12 Jan 2022 16:33:51 +0000 Subject: Fix [da6f155ca4]: STRING_SIZE() macro: parenthesize numChars usage. Fix more macro's like this. --- generic/tclCkalloc.c | 2 +- generic/tclDate.c | 4 ++-- generic/tclExecute.c | 14 +++++++------- generic/tclGetDate.y | 4 ++-- generic/tclIORChan.c | 2 +- generic/tclIORTrans.c | 2 +- generic/tclInt.h | 2 +- generic/tclOOInt.h | 2 +- generic/tclStringRep.h | 2 +- generic/tclTrace.c | 4 ++-- 10 files changed, 19 insertions(+), 19 deletions(-) diff --git a/generic/tclCkalloc.c b/generic/tclCkalloc.c index 48832d9..8c83aeb 100644 --- a/generic/tclCkalloc.c +++ b/generic/tclCkalloc.c @@ -41,7 +41,7 @@ typedef struct MemTag { * last field in the structure. */ } MemTag; -#define TAG_SIZE(bytesInString) ((unsigned) ((TclOffset(MemTag, string) + 1) + bytesInString)) +#define TAG_SIZE(bytesInString) ((unsigned) ((TclOffset(MemTag, string) + 1) + (bytesInString))) static MemTag *curTagPtr = NULL;/* Tag to use in all future mem_headers (set * by "memory tag" command). */ diff --git a/generic/tclDate.c b/generic/tclDate.c index aa199c3..23cf336 100644 --- a/generic/tclDate.c +++ b/generic/tclDate.c @@ -185,9 +185,9 @@ typedef struct DateInfo { #define TM_YEAR_BASE 1900 -#define HOUR(x) ((int) (60 * x)) +#define HOUR(x) ((int) (60 * (x))) #define SECSPERDAY (24L * 60L * 60L) -#define IsLeapYear(x) ((x % 4 == 0) && (x % 100 != 0 || x % 400 == 0)) +#define IsLeapYear(x) (((x) % 4 == 0) && ((x) % 100 != 0 || (x) % 400 == 0)) /* * An entry in the lexical lookup table. diff --git a/generic/tclExecute.c b/generic/tclExecute.c index 7e014d4..5dc506a 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -193,10 +193,10 @@ typedef struct TEBCdata { #define PUSH_TAUX_OBJ(objPtr) \ do { \ if (auxObjList) { \ - objPtr->length += auxObjList->length; \ + (objPtr)->length += auxObjList->length; \ } \ - objPtr->internalRep.twoPtrValue.ptr1 = auxObjList; \ - auxObjList = objPtr; \ + (objPtr)->internalRep.twoPtrValue.ptr1 = auxObjList; \ + auxObjList = (objPtr); \ } while (0) #define POP_TAUX_OBJ() \ @@ -8462,24 +8462,24 @@ ExecuteExtendedBinaryMathOp( { #define LONG_RESULT(l) \ if (Tcl_IsShared(valuePtr)) { \ - TclNewLongObj(objResultPtr, l); \ + TclNewLongObj(objResultPtr, (l)); \ return objResultPtr; \ } else { \ - Tcl_SetLongObj(valuePtr, l); \ + Tcl_SetLongObj(valuePtr, (l)); \ return NULL; \ } #define WIDE_RESULT(w) \ if (Tcl_IsShared(valuePtr)) { \ return Tcl_NewWideIntObj(w); \ } else { \ - Tcl_SetWideIntObj(valuePtr, w); \ + Tcl_SetWideIntObj(valuePtr, (w)); \ return NULL; \ } #define BIG_RESULT(b) \ if (Tcl_IsShared(valuePtr)) { \ return Tcl_NewBignumObj(b); \ } else { \ - Tcl_SetBignumObj(valuePtr, b); \ + Tcl_SetBignumObj(valuePtr, (b)); \ return NULL; \ } #define DOUBLE_RESULT(d) \ diff --git a/generic/tclGetDate.y b/generic/tclGetDate.y index e6748a4..7e26b37 100644 --- a/generic/tclGetDate.y +++ b/generic/tclGetDate.y @@ -136,9 +136,9 @@ typedef struct DateInfo { #define TM_YEAR_BASE 1900 -#define HOUR(x) ((int) (60 * x)) +#define HOUR(x) ((int) (60 * (x))) #define SECSPERDAY (24L * 60L * 60L) -#define IsLeapYear(x) ((x % 4 == 0) && (x % 100 != 0 || x % 400 == 0)) +#define IsLeapYear(x) (((x) % 4 == 0) && ((x) % 100 != 0 || (x) % 400 == 0)) /* * An entry in the lexical lookup table. diff --git a/generic/tclIORChan.c b/generic/tclIORChan.c index c48c904..8e358e0 100644 --- a/generic/tclIORChan.c +++ b/generic/tclIORChan.c @@ -200,7 +200,7 @@ typedef enum { #define IMPLIES(a,b) ((!(a)) || (b)) #define NEGIMPL(a,b) -#define HAS(x,f) (x & FLAG(f)) +#define HAS(x,f) ((x) & FLAG(f)) #ifdef TCL_THREADS /* diff --git a/generic/tclIORTrans.c b/generic/tclIORTrans.c index 039b594..e0c39ad 100644 --- a/generic/tclIORTrans.c +++ b/generic/tclIORTrans.c @@ -216,7 +216,7 @@ typedef enum { #define IMPLIES(a,b) ((!(a)) || (b)) #define NEGIMPL(a,b) -#define HAS(x,f) (x & FLAG(f)) +#define HAS(x,f) ((x) & FLAG(f)) #ifdef TCL_THREADS /* diff --git a/generic/tclInt.h b/generic/tclInt.h index 491abe6..1954a13 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -4958,7 +4958,7 @@ typedef struct NRE_callback { #define TCLNR_FREE(interp, ptr) TclSmallFreeEx((interp), (ptr)) #else #define TCLNR_ALLOC(interp, ptr) \ - (ptr = ((ClientData) ckalloc(sizeof(NRE_callback)))) + ((ptr) = ((void *)ckalloc(sizeof(NRE_callback)))) #define TCLNR_FREE(interp, ptr) ckfree((char *) (ptr)) #endif diff --git a/generic/tclOOInt.h b/generic/tclOOInt.h index 44316ac..f061bc6 100644 --- a/generic/tclOOInt.h +++ b/generic/tclOOInt.h @@ -561,7 +561,7 @@ MODULE_SCOPE void TclOOSetupVariableResolver(Tcl_Namespace *nsPtr); #define FOREACH(var,ary) \ for(i=0 ; i<(ary).num; i++) if ((ary).list[i] == NULL) { \ continue; \ - } else if (var = (ary).list[i], 1) + } else if ((var) = (ary).list[i], 1) /* * Convenience macros for iterating through hash tables. FOREACH_HASH_DECLS diff --git a/generic/tclStringRep.h b/generic/tclStringRep.h index 25b854e..59e9499 100644 --- a/generic/tclStringRep.h +++ b/generic/tclStringRep.h @@ -67,7 +67,7 @@ typedef struct String { #define STRING_MAXCHARS \ (int)(((size_t)UINT_MAX - 1 - TclOffset(String, unicode))/sizeof(Tcl_UniChar)) #define STRING_SIZE(numChars) \ - (TclOffset(String, unicode) + ((numChars + 1) * sizeof(Tcl_UniChar))) + (TclOffset(String, unicode) + (((numChars) + 1) * sizeof(Tcl_UniChar))) #define stringCheckLimits(numChars) \ do { \ if ((numChars) < 0 || (numChars) > STRING_MAXCHARS) { \ diff --git a/generic/tclTrace.c b/generic/tclTrace.c index c82fc14..5ce4b95 100644 --- a/generic/tclTrace.c +++ b/generic/tclTrace.c @@ -160,8 +160,8 @@ typedef struct StringTraceData { #define FOREACH_COMMAND_TRACE(interp, name, clientData) \ (clientData) = NULL; \ - while ((clientData = Tcl_CommandTraceInfo(interp, name, 0, \ - TraceCommandProc, clientData)) != NULL) + while (((clientData) = Tcl_CommandTraceInfo((interp), (name), 0, \ + TraceCommandProc, (clientData))) != NULL) /* *---------------------------------------------------------------------- -- cgit v0.12 From 32ab46ae406d7fd3db0516dd45f38c7c48c6bd3c Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 12 Jan 2022 21:39:40 +0000 Subject: Fix [fba9c1fc12]: pointer arithmetic using NULL in PrintParse() --- generic/tclTest.c | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/generic/tclTest.c b/generic/tclTest.c index 5774dfc..ed016fe 100644 --- a/generic/tclTest.c +++ b/generic/tclTest.c @@ -3596,8 +3596,9 @@ PrintParse( Tcl_NewIntObj(tokenPtr->numComponents)); } Tcl_ListObjAppendElement(NULL, objPtr, + parsePtr->commandStart ? Tcl_NewStringObj(parsePtr->commandStart + parsePtr->commandSize, - -1)); + -1) : Tcl_NewObj()); } /* -- cgit v0.12 From e874b759fc95fea19afd03d71388ed379872493f Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 13 Jan 2022 11:12:40 +0000 Subject: Suggested fix for [bca10e3790]: Undefined behavior in ResultAdd(). Make functions like ResultAdd() equal in tclIOGt.c and tclIOTrans.c --- generic/tclIOGT.c | 8 ++++---- generic/tclIORTrans.c | 30 +++++++++++++++--------------- 2 files changed, 19 insertions(+), 19 deletions(-) diff --git a/generic/tclIOGT.c b/generic/tclIOGT.c index dadcb53..6b1c341 100644 --- a/generic/tclIOGT.c +++ b/generic/tclIOGT.c @@ -108,7 +108,7 @@ typedef struct ResultBuffer ResultBuffer; static inline void ResultClear(ResultBuffer *r); static inline void ResultInit(ResultBuffer *r); static inline int ResultEmpty(ResultBuffer *r); -static inline int ResultCopy(ResultBuffer *r, unsigned char *buf, +static inline size_t ResultCopy(ResultBuffer *r, unsigned char *buf, size_t toRead); static inline void ResultAdd(ResultBuffer *r, unsigned char *buf, size_t toWrite); @@ -1361,13 +1361,13 @@ ResultEmpty( *---------------------------------------------------------------------- */ -static inline int +static inline size_t ResultCopy( ResultBuffer *r, /* The buffer to read from. */ unsigned char *buf, /* The buffer to copy into. */ size_t toRead) /* Number of requested bytes. */ { - if (r->used == 0) { + if (ResultEmpty(r)) { /* * Nothing to copy in the case of an empty buffer. */ @@ -1424,7 +1424,7 @@ ResultAdd( unsigned char *buf, /* The buffer to read from. */ size_t toWrite) /* The number of bytes in 'buf'. */ { - if (r->used + toWrite > r->allocated) { + if ((r->used + toWrite + 1) > r->allocated) { /* * Extension of the internal buffer is required. */ diff --git a/generic/tclIORTrans.c b/generic/tclIORTrans.c index e0c39ad..eecd412 100644 --- a/generic/tclIORTrans.c +++ b/generic/tclIORTrans.c @@ -85,22 +85,22 @@ static const Tcl_ChannelType tclRTransformType = { * layers upon reading from the channel, plus the functions to manage such. */ -typedef struct _ResultBuffer_ { +typedef struct { unsigned char *buf; /* Reference to the buffer area. */ - int allocated; /* Allocated size of the buffer area. */ - int used; /* Number of bytes in the buffer, + size_t allocated; /* Allocated size of the buffer area. */ + size_t used; /* Number of bytes in the buffer, * <= allocated. */ } ResultBuffer; #define ResultLength(r) ((r)->used) /* static int ResultLength(ResultBuffer *r); */ -static void ResultClear(ResultBuffer *r); -static void ResultInit(ResultBuffer *r); -static void ResultAdd(ResultBuffer *r, unsigned char *buf, - int toWrite); -static int ResultCopy(ResultBuffer *r, unsigned char *buf, - int toRead); +static inline void ResultClear(ResultBuffer *r); +static inline void ResultInit(ResultBuffer *r); +static inline void ResultAdd(ResultBuffer *r, unsigned char *buf, + size_t toWrite); +static inline size_t ResultCopy(ResultBuffer *r, unsigned char *buf, + size_t toRead); #define RB_INCREMENT (512) @@ -2934,7 +2934,7 @@ TimerRun( *---------------------------------------------------------------------- */ -static void +static inline void ResultInit( ResultBuffer *rPtr) /* Reference to the structure to * initialize. */ @@ -2959,7 +2959,7 @@ ResultInit( *---------------------------------------------------------------------- */ -static void +static inline void ResultClear( ResultBuffer *rPtr) /* Reference to the buffer to clear out */ { @@ -2990,11 +2990,11 @@ ResultClear( *---------------------------------------------------------------------- */ -static void +static inline void ResultAdd( ResultBuffer *rPtr, /* The buffer to extend */ unsigned char *buf, /* The buffer to read from */ - int toWrite) /* The number of bytes in 'buf' */ + size_t toWrite) /* The number of bytes in 'buf' */ { if ((rPtr->used + toWrite + 1) > rPtr->allocated) { /* @@ -3038,11 +3038,11 @@ ResultAdd( *---------------------------------------------------------------------- */ -static int +static inline size_t ResultCopy( ResultBuffer *rPtr, /* The buffer to read from */ unsigned char *buf, /* The buffer to copy into */ - int toRead) /* Number of requested bytes */ + size_t toRead) /* Number of requested bytes */ { int copied; -- cgit v0.12 From d679a49bc0da1e368daa6af07fcf72af2e3dceb4 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 13 Jan 2022 11:46:50 +0000 Subject: Fix [6cb3db4965]: pointer arithmetic using NULL in InitArgsAndLocals() --- generic/tclProc.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/generic/tclProc.c b/generic/tclProc.c index 642294c..7921d38 100644 --- a/generic/tclProc.c +++ b/generic/tclProc.c @@ -1428,7 +1428,6 @@ InitArgsAndLocals( numArgs = procPtr->numArgs; argCt = framePtr->objc - skip; /* Set it to the number of args to the * procedure. */ - argObjs = framePtr->objv + skip; if (numArgs == 0) { if (argCt) { goto incorrectArgs; @@ -1436,6 +1435,7 @@ InitArgsAndLocals( goto correctArgs; } } + argObjs = framePtr->objv + skip; imax = ((argCt < numArgs-1) ? argCt : numArgs-1); for (i = 0; i < imax; i++, varPtr++, defPtr ? defPtr++ : defPtr) { /* -- cgit v0.12 From 1bc44ec32ab03ebaec021f52129ee1fefcac7850 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 13 Jan 2022 12:22:51 +0000 Subject: Fix [816913a65e]: GrowStringBuffer(): signed integer overflow. And a few similar situations in other place --- generic/tclBinary.c | 2 +- generic/tclCkalloc.c | 2 +- generic/tclCompile.c | 2 +- generic/tclObj.c | 2 +- generic/tclProc.c | 2 +- generic/tclStringObj.c | 6 +++--- generic/tclStringRep.h | 2 +- 7 files changed, 9 insertions(+), 9 deletions(-) diff --git a/generic/tclBinary.c b/generic/tclBinary.c index 0296770..6f36d54 100644 --- a/generic/tclBinary.c +++ b/generic/tclBinary.c @@ -189,7 +189,7 @@ typedef struct ByteArray { } ByteArray; #define BYTEARRAY_SIZE(len) \ - ((unsigned) (TclOffset(ByteArray, bytes) + (len))) + (((unsigned)TclOffset(ByteArray, bytes) + (len))) #define GET_BYTEARRAY(objPtr) \ ((ByteArray *) (objPtr)->internalRep.twoPtrValue.ptr1) #define SET_BYTEARRAY(objPtr, baPtr) \ diff --git a/generic/tclCkalloc.c b/generic/tclCkalloc.c index 8c83aeb..20285eb 100644 --- a/generic/tclCkalloc.c +++ b/generic/tclCkalloc.c @@ -41,7 +41,7 @@ typedef struct MemTag { * last field in the structure. */ } MemTag; -#define TAG_SIZE(bytesInString) ((unsigned) ((TclOffset(MemTag, string) + 1) + (bytesInString))) +#define TAG_SIZE(bytesInString) ((unsigned) ((TclOffset(MemTag, string) + 1U) + (bytesInString))) static MemTag *curTagPtr = NULL;/* Tag to use in all future mem_headers (set * by "memory tag" command). */ diff --git a/generic/tclCompile.c b/generic/tclCompile.c index eb2e16b..4a50089 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -3010,7 +3010,7 @@ TclFindCompiledLocal( if (create || (name == NULL)) { localVar = procPtr->numCompiledLocals; - localPtr = ckalloc(TclOffset(CompiledLocal, name) + nameBytes + 1); + localPtr = ckalloc(TclOffset(CompiledLocal, name) + 1U + nameBytes); if (procPtr->firstLocalPtr == NULL) { procPtr->firstLocalPtr = procPtr->lastLocalPtr = localPtr; } else { diff --git a/generic/tclObj.c b/generic/tclObj.c index 0950dcd..1fd674f 100644 --- a/generic/tclObj.c +++ b/generic/tclObj.c @@ -576,7 +576,7 @@ TclContinuationsEnter( ThreadSpecificData *tsdPtr = TclGetContLineTable(); Tcl_HashEntry *hPtr = Tcl_CreateHashEntry(tsdPtr->lineCLPtr, objPtr, &newEntry); - ContLineLoc *clLocPtr = (ContLineLoc *)ckalloc(TclOffset(ContLineLoc, loc) + (num + 1) *sizeof(int)); + ContLineLoc *clLocPtr = (ContLineLoc *)ckalloc(TclOffset(ContLineLoc, loc) + (num + 1U) *sizeof(int)); if (!newEntry) { /* diff --git a/generic/tclProc.c b/generic/tclProc.c index 7921d38..a533878 100644 --- a/generic/tclProc.c +++ b/generic/tclProc.c @@ -600,7 +600,7 @@ TclCreateProc( */ localPtr = (CompiledLocal *)ckalloc( - TclOffset(CompiledLocal, name) + fieldValues[0]->length + 1); + TclOffset(CompiledLocal, name) + 1U + fieldValues[0]->length); if (procPtr->firstLocalPtr == NULL) { procPtr->firstLocalPtr = procPtr->lastLocalPtr = localPtr; } else { diff --git a/generic/tclStringObj.c b/generic/tclStringObj.c index 75b449d..edfcb9f 100644 --- a/generic/tclStringObj.c +++ b/generic/tclStringObj.c @@ -151,7 +151,7 @@ GrowStringBuffer( if (flag == 0 || stringPtr->allocated > 0) { if (needed <= INT_MAX / 2) { attempt = 2 * needed; - ptr = (char *)attemptckrealloc(objPtr->bytes, attempt + 1); + ptr = (char *)attemptckrealloc(objPtr->bytes, attempt + 1U); } if (ptr == NULL) { /* @@ -164,7 +164,7 @@ GrowStringBuffer( int growth = (int) ((extra > limit) ? limit : extra); attempt = needed + growth; - ptr = (char *)attemptckrealloc(objPtr->bytes, attempt + 1); + ptr = (char *)attemptckrealloc(objPtr->bytes, attempt + 1U); } } if (ptr == NULL) { @@ -173,7 +173,7 @@ GrowStringBuffer( */ attempt = needed; - ptr = (char *)ckrealloc(objPtr->bytes, attempt + 1); + ptr = (char *)ckrealloc(objPtr->bytes, attempt + 1U); } objPtr->bytes = ptr; stringPtr->allocated = attempt; diff --git a/generic/tclStringRep.h b/generic/tclStringRep.h index 59e9499..c0adc10 100644 --- a/generic/tclStringRep.h +++ b/generic/tclStringRep.h @@ -67,7 +67,7 @@ typedef struct String { #define STRING_MAXCHARS \ (int)(((size_t)UINT_MAX - 1 - TclOffset(String, unicode))/sizeof(Tcl_UniChar)) #define STRING_SIZE(numChars) \ - (TclOffset(String, unicode) + (((numChars) + 1) * sizeof(Tcl_UniChar))) + (TclOffset(String, unicode) + (((numChars) + 1U) * sizeof(Tcl_UniChar))) #define stringCheckLimits(numChars) \ do { \ if ((numChars) < 0 || (numChars) > STRING_MAXCHARS) { \ -- cgit v0.12 From c513699e2c1d661da77c76813d7bdac494bfae91 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 14 Jan 2022 15:44:02 +0000 Subject: Fix [b241e4ccc0]: Error while building with Tcl 8.7a5... --- generic/tclTomMathDecls.h | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/generic/tclTomMathDecls.h b/generic/tclTomMathDecls.h index 1b2c05f..8d12adf 100644 --- a/generic/tclTomMathDecls.h +++ b/generic/tclTomMathDecls.h @@ -167,11 +167,11 @@ MODULE_SCOPE mp_err TclBN_mp_set_int(mp_int *a, unsigned long b); #define s_mp_toom_sqr TclBN_mp_toom_sqr #endif /* !TCL_WITH_EXTERNAL_TOMMATH */ -#define mp_init_set_int(a,b) (MP_DEPRECATED_PRAGMA("replaced by mp_init_ul") TclBN_mp_init_u64(a,(unsigned int)(b))) -#define mp_set_int(a,b) (MP_DEPRECATED_PRAGMA("replaced by mp_set_ul") (TclBN_mp_set_u64((a),((unsigned int)(b))),MP_OKAY)) -#define mp_set_long(a,b) (MP_DEPRECATED_PRAGMA("replaced by mp_set_ul") (TclBN_mp_set_u64((a),(long)(b)),MP_OKAY)) -#define mp_set_long_long(a,b) (MP_DEPRECATED_PRAGMA("replaced by mp_set_u64") (TclBN_mp_set_u64((a),(b)),MP_OKAY)) -#define mp_unsigned_bin_size(mp) (MP_DEPRECATED_PRAGMA("replaced by mp_ubin_size") (int)TclBN_mp_ubin_size(mp)) +#define mp_init_set_int(a,b) (MP_DEPRECATED_PRAGMA("replaced by mp_init_ul") mp_init_u64(a,(unsigned int)(b))) +#define mp_set_int(a,b) (MP_DEPRECATED_PRAGMA("replaced by mp_set_ul") (mp_set_u64((a),((unsigned int)(b))),MP_OKAY)) +#define mp_set_long(a,b) (MP_DEPRECATED_PRAGMA("replaced by mp_set_ul") (mp_set_u64((a),(long)(b)),MP_OKAY)) +#define mp_set_long_long(a,b) (MP_DEPRECATED_PRAGMA("replaced by mp_set_u64") (mp_set_u64((a),(b)),MP_OKAY)) +#define mp_unsigned_bin_size(mp) (MP_DEPRECATED_PRAGMA("replaced by mp_ubin_size") (int)mp_ubin_size(mp)) #undef TCL_STORAGE_CLASS #ifdef BUILD_tcl -- cgit v0.12 From 9bcfb6703d6eaa02bfcaad401aa83ce48309d4a1 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 14 Jan 2022 22:34:06 +0000 Subject: Proposed fix for [6474fbd934]: Tcl 8.7a5: why utf-8 is different? --- generic/tclEncoding.c | 3 --- tests/encoding.test | 20 ++++++++++---------- 2 files changed, 10 insertions(+), 13 deletions(-) diff --git a/generic/tclEncoding.c b/generic/tclEncoding.c index 57c6148..037beed 100644 --- a/generic/tclEncoding.c +++ b/generic/tclEncoding.c @@ -2323,9 +2323,6 @@ UtfToUtfProc( src = saveSrc; break; } - if (!(flags & TCL_ENCODING_MODIFIED)) { - ch = 0xFFFD; - } cesu8: *dst++ = (char) (((ch >> 12) | 0xE0) & 0xEF); *dst++ = (char) (((ch >> 6) | 0x80) & 0xBF); diff --git a/tests/encoding.test b/tests/encoding.test index c6f4e02..75e0dcc 100644 --- a/tests/encoding.test +++ b/tests/encoding.test @@ -349,61 +349,61 @@ test encoding-15.6 {UtfToUtfProc emoji character output} { set y [encoding convertto utf-8 \uDE02\uD83D\uDE02\uD83D] binary scan $y H* z list [string length $y] $z -} {10 efbfbdf09f9882efbfbd} +} {10 edb882f09f9882eda0bd} test encoding-15.7 {UtfToUtfProc emoji character output} { set x \uDE02\uD83D\uD83D set y [encoding convertto utf-8 \uDE02\uD83D\uD83D] binary scan $y H* z list [string length $x] [string length $y] $z -} {3 9 efbfbdefbfbdefbfbd} +} {3 9 edb882eda0bdeda0bd} test encoding-15.8 {UtfToUtfProc emoji character output} { set x \uDE02\uD83Dé set y [encoding convertto utf-8 \uDE02\uD83Dé] binary scan $y H* z list [string length $x] [string length $y] $z -} {3 8 efbfbdefbfbdc3a9} +} {3 8 edb882eda0bdc3a9} test encoding-15.9 {UtfToUtfProc emoji character output} { set x \uDE02\uD83DX set y [encoding convertto utf-8 \uDE02\uD83DX] binary scan $y H* z list [string length $x] [string length $y] $z -} {3 7 efbfbdefbfbd58} +} {3 7 edb882eda0bd58} test encoding-15.10 {UtfToUtfProc high surrogate character output} { set x \uDE02é set y [encoding convertto utf-8 \uDE02é] binary scan $y H* z list [string length $x] [string length $y] $z -} {2 5 efbfbdc3a9} +} {2 5 edb882c3a9} test encoding-15.11 {UtfToUtfProc low surrogate character output} { set x \uDA02é set y [encoding convertto utf-8 \uDA02é] binary scan $y H* z list [string length $x] [string length $y] $z -} {2 5 efbfbdc3a9} +} {2 5 eda882c3a9} test encoding-15.12 {UtfToUtfProc high surrogate character output} { set x \uDE02Y set y [encoding convertto utf-8 \uDE02Y] binary scan $y H* z list [string length $x] [string length $y] $z -} {2 4 efbfbd59} +} {2 4 edb88259} test encoding-15.13 {UtfToUtfProc low surrogate character output} { set x \uDA02Y set y [encoding convertto utf-8 \uDA02Y] binary scan $y H* z list [string length $x] [string length $y] $z -} {2 4 efbfbd59} +} {2 4 eda88259} test encoding-15.14 {UtfToUtfProc high surrogate character output} { set x \uDE02 set y [encoding convertto utf-8 \uDE02] binary scan $y H* z list [string length $x] [string length $y] $z -} {1 3 efbfbd} +} {1 3 edb882} test encoding-15.15 {UtfToUtfProc low surrogate character output} { set x \uDA02 set y [encoding convertto utf-8 \uDA02] binary scan $y H* z list [string length $x] [string length $y] $z -} {1 3 efbfbd} +} {1 3 eda882} test encoding-15.16 {UtfToUtfProc: Invalid 4-byte UTF-8, see [ed29806ba]} { set x \xF0\xA0\xA1\xC2 set y [encoding convertfrom utf-8 \xF0\xA0\xA1\xC2] -- cgit v0.12 From e5a2ebd71b2aa2b31ca5128eb47ae0a7fdd20bd5 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 17 Jan 2022 10:35:18 +0000 Subject: Follow-up to [767e070d35]: Tcl_GetRange and Tcl_GetUniChar do not validate index inputs. Now that Tcl_GetRange() checks its arguments, the callers of this function don't have to do that any more. This also shows a off-by-one error in the Tcl_GetRange() check --- generic/tclCmdMZ.c | 10 +--------- generic/tclExecute.c | 33 ++++----------------------------- generic/tclStringObj.c | 7 +++---- 3 files changed, 8 insertions(+), 42 deletions(-) diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c index da3fc8b..5422b7f 100644 --- a/generic/tclCmdMZ.c +++ b/generic/tclCmdMZ.c @@ -2183,15 +2183,7 @@ StringRangeCmd( return TCL_ERROR; } - if (first < 0) { - first = 0; - } - if (last >= length) { - last = length; - } - if (last >= first) { - Tcl_SetObjResult(interp, Tcl_GetRange(objv[1], first, last)); - } + Tcl_SetObjResult(interp, Tcl_GetRange(objv[1], first, last)); return TCL_OK; } diff --git a/generic/tclExecute.c b/generic/tclExecute.c index e5a6b71..c39bc21 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -5609,17 +5609,7 @@ TEBCresume( goto gotError; } - if (fromIdx < 0) { - fromIdx = 0; - } - if (toIdx >= length) { - toIdx = length; - } - if (toIdx >= fromIdx) { - objResultPtr = Tcl_GetRange(OBJ_AT_DEPTH(2), fromIdx, toIdx); - } else { - TclNewObj(objResultPtr); - } + objResultPtr = Tcl_GetRange(OBJ_AT_DEPTH(2), fromIdx, toIdx); TRACE_APPEND(("\"%.30s\"\n", O2S(objResultPtr))); NEXT_INST_V(1, 3, 1); @@ -5652,13 +5642,6 @@ TEBCresume( } toIdx = TclIndexDecode(toIdx, length - 1); - if (toIdx < 0) { - goto emptyRange; - } else if (toIdx >= length) { - toIdx = length - 1; - } - - assert ( toIdx >= 0 && toIdx < length ); /* assert ( fromIdx != TCL_INDEX_BEFORE ); @@ -5670,19 +5653,11 @@ TEBCresume( fromIdx = TCL_INDEX_START; } if (fromIdx == TCL_INDEX_AFTER) { - goto emptyRange; - } - - fromIdx = TclIndexDecode(fromIdx, length - 1); - if (fromIdx < 0) { - fromIdx = 0; - } - - if (fromIdx <= toIdx) { - objResultPtr = Tcl_GetRange(valuePtr, fromIdx, toIdx); - } else { emptyRange: TclNewObj(objResultPtr); + } else { + fromIdx = TclIndexDecode(fromIdx, length - 1); + objResultPtr = Tcl_GetRange(valuePtr, fromIdx, toIdx); } TRACE_APPEND(("%.30s\n", O2S(objResultPtr))); NEXT_INST_F(9, 1, 1); diff --git a/generic/tclStringObj.c b/generic/tclStringObj.c index edfcb9f..fc675cf 100644 --- a/generic/tclStringObj.c +++ b/generic/tclStringObj.c @@ -739,8 +739,7 @@ Tcl_GetUnicodeFromObj( * * Create a Tcl Object that contains the chars between first and last of * the object indicated by "objPtr". If the object is not already a - * String object, convert it to one. The first and last indices are - * assumed to be in the appropriate range. + * String object, convert it to one. * * Results: * Returns a new Tcl Object of the String type. @@ -818,8 +817,8 @@ Tcl_GetRange( FillUnicodeRep(objPtr); stringPtr = GET_STRING(objPtr); } - if (last > stringPtr->numChars) { - last = stringPtr->numChars; + if (last >= stringPtr->numChars) { + last = stringPtr->numChars - 1; } if (last < first) { return Tcl_NewObj(); -- cgit v0.12 From 01a48e2369782044a30d922c5f8ed52262ef4fcd Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 17 Jan 2022 16:44:44 +0000 Subject: Tcl_NewObj() -> TclNewObj() --- generic/tclBasic.c | 10 +++++----- generic/tclBinary.c | 10 +++++----- generic/tclCompCmds.c | 35 ++++++++++++++++++----------------- generic/tclCompCmdsGR.c | 19 ++++++++++--------- generic/tclCompCmdsSZ.c | 14 ++++++++------ generic/tclCompExpr.c | 22 ++++++++++++++-------- generic/tclCompile.c | 5 +++-- generic/tclDisassemble.c | 29 ++++++++++++++++------------- generic/tclEncoding.c | 6 ++++-- generic/tclEnsemble.c | 8 +++++--- generic/tclIOCmd.c | 8 ++++---- generic/tclIORTrans.c | 2 +- generic/tclIOUtil.c | 11 ++++++----- generic/tclInterp.c | 10 ++++++---- generic/tclOO.c | 2 +- generic/tclOOBasic.c | 2 +- generic/tclOODefineCmds.c | 18 +++++++++--------- generic/tclOOInfo.c | 36 ++++++++++++++++++------------------ generic/tclOOMethod.c | 7 ++++--- generic/tclPathObj.c | 11 ++++++----- generic/tclPipe.c | 2 +- generic/tclPkg.c | 5 +++-- generic/tclRegexp.c | 2 +- generic/tclResult.c | 10 ++++++---- generic/tclStringObj.c | 11 +++++++---- generic/tclTimer.c | 18 ++++++++++-------- 26 files changed, 172 insertions(+), 141 deletions(-) diff --git a/generic/tclBasic.c b/generic/tclBasic.c index aebcab7..5975fd3 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -517,7 +517,7 @@ Tcl_CreateInterp(void) iPtr->result = iPtr->resultSpace; iPtr->freeProc = NULL; iPtr->errorLine = 0; - iPtr->objResultPtr = Tcl_NewObj(); + TclNewObj(iPtr->objResultPtr); Tcl_IncrRefCount(iPtr->objResultPtr); iPtr->handle = TclHandleCreate(iPtr); iPtr->globalNsPtr = NULL; @@ -606,7 +606,7 @@ Tcl_CreateInterp(void) iPtr->activeInterpTracePtr = NULL; iPtr->assocData = NULL; iPtr->execEnvPtr = NULL; /* Set after namespaces initialized. */ - iPtr->emptyObjPtr = Tcl_NewObj(); + TclNewObj(iPtr->emptyObjPtr); /* Another empty object. */ Tcl_IncrRefCount(iPtr->emptyObjPtr); iPtr->resultSpace[0] = 0; @@ -671,7 +671,7 @@ Tcl_CreateInterp(void) * TIP #285, Script cancellation support. */ - iPtr->asyncCancelMsg = Tcl_NewObj(); + TclNewObj(iPtr->asyncCancelMsg); cancelInfo = (CancelInfo *)ckalloc(sizeof(CancelInfo)); cancelInfo->interp = interp; @@ -2652,7 +2652,7 @@ TclRenameCommand( } cmdNsPtr = cmdPtr->nsPtr; - oldFullName = Tcl_NewObj(); + TclNewObj(oldFullName); Tcl_IncrRefCount(oldFullName); Tcl_GetCommandFullName(interp, cmd, oldFullName); @@ -3857,7 +3857,7 @@ Tcl_ListMathFuncs( if (TCL_OK == Tcl_EvalObjEx(interp, script, 0)) { result = Tcl_DuplicateObj(Tcl_GetObjResult(interp)); } else { - result = Tcl_NewObj(); + TclNewObj(result); } Tcl_DecrRefCount(script); Tcl_RestoreInterpState(interp, state); diff --git a/generic/tclBinary.c b/generic/tclBinary.c index 6f36d54..5d317fa 100644 --- a/generic/tclBinary.c +++ b/generic/tclBinary.c @@ -927,7 +927,7 @@ BinaryFormatCmd( * bytes and filling with nulls. */ - resultPtr = Tcl_NewObj(); + TclNewObj(resultPtr); buffer = Tcl_SetByteArrayLength(resultPtr, length); memset(buffer, 0, length); @@ -1360,7 +1360,7 @@ BinaryScanCmd( } } src = buffer + offset; - valuePtr = Tcl_NewObj(); + TclNewObj(valuePtr); Tcl_SetObjLength(valuePtr, count); dest = TclGetString(valuePtr); @@ -1415,7 +1415,7 @@ BinaryScanCmd( } } src = buffer + offset; - valuePtr = Tcl_NewObj(); + TclNewObj(valuePtr); Tcl_SetObjLength(valuePtr, count); dest = TclGetString(valuePtr); @@ -1499,7 +1499,7 @@ BinaryScanCmd( if ((length - offset) < (count * size)) { goto done; } - valuePtr = Tcl_NewObj(); + TclNewObj(valuePtr); src = buffer + offset; for (i = 0; i < count; i++) { elementPtr = ScanNumber(src, cmd, flags, &numberCachePtr); @@ -2521,7 +2521,7 @@ BinaryEncode64( maxlen = 0; } - resultObj = Tcl_NewObj(); + TclNewObj(resultObj); data = Tcl_GetByteArrayFromObj(objv[objc - 1], &count); if (count > 0) { unsigned char *cursor = NULL; diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c index c8970ce..f28175b 100644 --- a/generic/tclCompCmds.c +++ b/generic/tclCompCmds.c @@ -311,7 +311,7 @@ TclCompileArraySetCmd( varTokenPtr = TokenAfter(parsePtr->tokenPtr); dataTokenPtr = TokenAfter(varTokenPtr); - literalObj = Tcl_NewObj(); + TclNewObj(literalObj); isDataLiteral = TclWordKnownAtCompileTime(dataTokenPtr, literalObj); isDataValid = (isDataLiteral && Tcl_ListObjLength(NULL, literalObj, &len) == TCL_OK); @@ -890,10 +890,10 @@ TclCompileConcatCmd( * implement with a simple push. */ - listObj = Tcl_NewObj(); + TclNewObj(listObj); for (i = 1, tokenPtr = parsePtr->tokenPtr; i < parsePtr->numWords; i++) { tokenPtr = TokenAfter(tokenPtr); - objPtr = Tcl_NewObj(); + TclNewObj(objPtr); if (!TclWordKnownAtCompileTime(tokenPtr, objPtr)) { Tcl_DecrRefCount(objPtr); Tcl_DecrRefCount(listObj); @@ -1288,10 +1288,10 @@ TclCompileDictCreateCmd( */ tokenPtr = TokenAfter(parsePtr->tokenPtr); - dictObj = Tcl_NewObj(); + TclNewObj(dictObj); Tcl_IncrRefCount(dictObj); for (i=1 ; inumWords ; i+=2) { - keyObj = Tcl_NewObj(); + TclNewObj(keyObj); Tcl_IncrRefCount(keyObj); if (!TclWordKnownAtCompileTime(tokenPtr, keyObj)) { Tcl_DecrRefCount(keyObj); @@ -1299,7 +1299,7 @@ TclCompileDictCreateCmd( goto nonConstant; } tokenPtr = TokenAfter(tokenPtr); - valueObj = Tcl_NewObj(); + TclNewObj(valueObj); Tcl_IncrRefCount(valueObj); if (!TclWordKnownAtCompileTime(tokenPtr, valueObj)) { Tcl_DecrRefCount(keyObj); @@ -2298,8 +2298,9 @@ DisassembleDictUpdateInfo( { DictUpdateInfo *duiPtr = clientData; int i; - Tcl_Obj *variables = Tcl_NewObj(); + Tcl_Obj *variables; + TclNewObj(variables); for (i=0 ; ilength ; i++) { Tcl_ListObjAppendElement(NULL, variables, Tcl_NewIntObj(duiPtr->varIndices[i])); @@ -2722,7 +2723,7 @@ CompileEachloopCmd( * a scalar, or if any var list needs substitutions. */ - varListObj = Tcl_NewObj(); + TclNewObj(varListObj); for (i = 0, tokenPtr = parsePtr->tokenPtr; i < numWords-1; i++, tokenPtr = TokenAfter(tokenPtr)) { @@ -3041,7 +3042,7 @@ DisassembleForeachInfo( * Data stores. */ - objPtr = Tcl_NewObj(); + TclNewObj(objPtr); for (i=0 ; inumLists ; i++) { Tcl_ListObjAppendElement(NULL, objPtr, Tcl_NewIntObj(infoPtr->firstValueTemp + i)); @@ -3059,9 +3060,9 @@ DisassembleForeachInfo( * Assignment targets. */ - objPtr = Tcl_NewObj(); + TclNewObj(objPtr); for (i=0 ; inumLists ; i++) { - innerPtr = Tcl_NewObj(); + TclNewObj(innerPtr); varsPtr = infoPtr->varLists[i]; for (j=0 ; jnumVars ; j++) { Tcl_ListObjAppendElement(NULL, innerPtr, @@ -3095,9 +3096,9 @@ DisassembleNewForeachInfo( * Assignment targets. */ - objPtr = Tcl_NewObj(); + TclNewObj(objPtr); for (i=0 ; inumLists ; i++) { - innerPtr = Tcl_NewObj(); + TclNewObj(innerPtr); varsPtr = infoPtr->varLists[i]; for (j=0 ; jnumVars ; j++) { Tcl_ListObjAppendElement(NULL, innerPtr, @@ -3155,7 +3156,7 @@ TclCompileFormatCmd( * a case we can handle by compiling to a constant. */ - formatObj = Tcl_NewObj(); + TclNewObj(formatObj); Tcl_IncrRefCount(formatObj); tokenPtr = TokenAfter(tokenPtr); if (!TclWordKnownAtCompileTime(tokenPtr, formatObj)) { @@ -3166,7 +3167,7 @@ TclCompileFormatCmd( objv = ckalloc((parsePtr->numWords-2) * sizeof(Tcl_Obj *)); for (i=0 ; i+2 < parsePtr->numWords ; i++) { tokenPtr = TokenAfter(tokenPtr); - objv[i] = Tcl_NewObj(); + TclNewObj(objv[i]); Tcl_IncrRefCount(objv[i]); if (!TclWordKnownAtCompileTime(tokenPtr, objv[i])) { goto checkForStringConcatCase; @@ -3258,7 +3259,7 @@ TclCompileFormatCmd( start = Tcl_GetString(formatObj); /* The start of the currently-scanned literal * in the format string. */ - tmpObj = Tcl_NewObj(); /* The buffer used to accumulate the literal + TclNewObj(tmpObj); /* The buffer used to accumulate the literal * being built. */ for (bytes = start ; *bytes ; bytes++) { if (*bytes == '%') { @@ -3276,7 +3277,7 @@ TclCompileFormatCmd( if (len > 0) { PushLiteral(envPtr, b, len); Tcl_DecrRefCount(tmpObj); - tmpObj = Tcl_NewObj(); + TclNewObj(tmpObj); i++; } diff --git a/generic/tclCompCmdsGR.c b/generic/tclCompCmdsGR.c index c453878..a324706 100644 --- a/generic/tclCompCmdsGR.c +++ b/generic/tclCompCmdsGR.c @@ -54,9 +54,10 @@ TclGetIndexFromToken( int after, int *indexPtr) { - Tcl_Obj *tmpObj = Tcl_NewObj(); + Tcl_Obj *tmpObj; int result = TCL_ERROR; + TclNewObj(tmpObj); if (TclWordKnownAtCompileTime(tokenPtr, tmpObj)) { result = TclIndexEncode(NULL, tmpObj, before, after, indexPtr); } @@ -599,7 +600,7 @@ TclCompileInfoCommandsCmd( return TCL_ERROR; } tokenPtr = TokenAfter(parsePtr->tokenPtr); - objPtr = Tcl_NewObj(); + TclNewObj(objPtr); Tcl_IncrRefCount(objPtr); if (!TclWordKnownAtCompileTime(tokenPtr, objPtr)) { goto notCompilable; @@ -1180,9 +1181,9 @@ TclCompileListCmd( numWords = parsePtr->numWords; valueTokenPtr = TokenAfter(parsePtr->tokenPtr); - listObj = Tcl_NewObj(); + TclNewObj(listObj); for (i = 1; i < numWords && listObj != NULL; i++) { - objPtr = Tcl_NewObj(); + TclNewObj(objPtr); if (TclWordKnownAtCompileTime(valueTokenPtr, objPtr)) { (void) Tcl_ListObjAppendElement(NULL, listObj, objPtr); } else { @@ -2289,7 +2290,7 @@ TclCompileRegsubCmd( Tcl_DStringInit(&pattern); tokenPtr = TokenAfter(tokenPtr); - patternObj = Tcl_NewObj(); + TclNewObj(patternObj); if (!TclWordKnownAtCompileTime(tokenPtr, patternObj)) { goto done; } @@ -2300,7 +2301,7 @@ TclCompileRegsubCmd( } tokenPtr = TokenAfter(tokenPtr); Tcl_DecrRefCount(patternObj); - patternObj = Tcl_NewObj(); + TclNewObj(patternObj); if (!TclWordKnownAtCompileTime(tokenPtr, patternObj)) { goto done; } @@ -2315,7 +2316,7 @@ TclCompileRegsubCmd( stringTokenPtr = TokenAfter(tokenPtr); tokenPtr = TokenAfter(stringTokenPtr); - replacementObj = Tcl_NewObj(); + TclNewObj(replacementObj); if (!TclWordKnownAtCompileTime(tokenPtr, replacementObj)) { goto done; } @@ -2466,7 +2467,7 @@ TclCompileReturnCmd( */ for (objc = 0; objc < numOptionWords; objc++) { - objv[objc] = Tcl_NewObj(); + TclNewObj(objv[objc]); Tcl_IncrRefCount(objv[objc]); if (!TclWordKnownAtCompileTime(wordTokenPtr, objv[objc])) { /* @@ -2686,7 +2687,7 @@ TclCompileUpvarCmd( * Push the frame index if it is known at compile time */ - objPtr = Tcl_NewObj(); + TclNewObj(objPtr); tokenPtr = TokenAfter(parsePtr->tokenPtr); if (TclWordKnownAtCompileTime(tokenPtr, objPtr)) { CallFrame *framePtr; diff --git a/generic/tclCompCmdsSZ.c b/generic/tclCompCmdsSZ.c index ddfe0dc..862ebb5 100644 --- a/generic/tclCompCmdsSZ.c +++ b/generic/tclCompCmdsSZ.c @@ -248,7 +248,7 @@ TclCompileStringCatCmd( folded = NULL; wordTokenPtr = TokenAfter(parsePtr->tokenPtr); for (i = 1; i < numWords; i++) { - obj = Tcl_NewObj(); + TclNewObj(obj); if (TclWordKnownAtCompileTime(wordTokenPtr, obj)) { if (folded) { Tcl_AppendObjToObj(folded, obj); @@ -482,7 +482,7 @@ TclCompileStringIsCmd( if (parsePtr->numWords < 3 || parsePtr->numWords > 6) { return TCL_ERROR; } - isClass = Tcl_NewObj(); + TclNewObj(isClass); if (!TclWordKnownAtCompileTime(tokenPtr, isClass)) { Tcl_DecrRefCount(isClass); return TCL_ERROR; @@ -878,7 +878,7 @@ TclCompileStringMapCmd( } mapTokenPtr = TokenAfter(parsePtr->tokenPtr); stringTokenPtr = TokenAfter(mapTokenPtr); - mapObj = Tcl_NewObj(); + TclNewObj(mapObj); Tcl_IncrRefCount(mapObj); if (!TclWordKnownAtCompileTime(mapTokenPtr, mapObj)) { Tcl_DecrRefCount(mapObj); @@ -1418,7 +1418,7 @@ TclCompileSubstCmd( objv = TclStackAlloc(interp, /*numArgs*/ numOpts * sizeof(Tcl_Obj *)); for (objc = 0; objc < /*numArgs*/ numOpts; objc++) { - objv[objc] = Tcl_NewObj(); + TclNewObj(objv[objc]); Tcl_IncrRefCount(objv[objc]); if (!TclWordKnownAtCompileTime(wordTokenPtr, objv[objc])) { objc++; @@ -2570,12 +2570,13 @@ DisassembleJumptableInfo( unsigned int pcOffset) { JumptableInfo *jtPtr = clientData; - Tcl_Obj *mapping = Tcl_NewObj(); + Tcl_Obj *mapping; Tcl_HashEntry *hPtr; Tcl_HashSearch search; const char *keyPtr; int offset; + TclNewObj(mapping); hPtr = Tcl_FirstHashEntry(&jtPtr->hashTable, &search); for (; hPtr ; hPtr = Tcl_NextHashEntry(&search)) { keyPtr = Tcl_GetHashKey(&jtPtr->hashTable, hPtr); @@ -3587,8 +3588,9 @@ TclCompileUnsetCmd( */ for (i=1,varTokenPtr=parsePtr->tokenPtr ; inumWords ; i++) { - Tcl_Obj *leadingWord = Tcl_NewObj(); + Tcl_Obj *leadingWord; + TclNewObj(leadingWord); varTokenPtr = TokenAfter(varTokenPtr); if (!TclWordKnownAtCompileTime(varTokenPtr, leadingWord)) { TclDecrRefCount(leadingWord); diff --git a/generic/tclCompExpr.c b/generic/tclCompExpr.c index 52b62fc..ca9a21a 100644 --- a/generic/tclCompExpr.c +++ b/generic/tclCompExpr.c @@ -1001,7 +1001,7 @@ ParseExpr( * later. */ - literal = Tcl_NewObj(); + TclNewObj(literal); if (TclWordKnownAtCompileTime(tokenPtr, literal)) { Tcl_ListObjAppendElement(NULL, litList, literal); complete = lastParsed = OT_LITERAL; @@ -1828,8 +1828,8 @@ Tcl_ParseExpr( { int code; OpNode *opTree = NULL; /* Will point to the tree of operators. */ - Tcl_Obj *litList = Tcl_NewObj(); /* List to hold the literals. */ - Tcl_Obj *funcList = Tcl_NewObj(); /* List to hold the functon names. */ + Tcl_Obj *litList; /* List to hold the literals. */ + Tcl_Obj *funcList; /* List to hold the functon names. */ Tcl_Parse *exprParsePtr = TclStackAlloc(interp, sizeof(Tcl_Parse)); /* Holds the Tcl_Tokens of substitutions. */ @@ -1837,6 +1837,8 @@ Tcl_ParseExpr( numBytes = (start ? strlen(start) : 0); } + TclNewObj(litList); + TclNewObj(funcList); code = ParseExpr(interp, start, numBytes, &opTree, litList, funcList, exprParsePtr, 1 /* parseOnly */); Tcl_DecrRefCount(funcList); @@ -2003,7 +2005,7 @@ ParseLexeme( } } - literal = Tcl_NewObj(); + TclNewObj(literal); if (TclParseNumber(NULL, literal, NULL, start, numBytes, &end, TCL_PARSE_NO_WHITESPACE) == TCL_OK) { if (end < start + numBytes && !TclIsBareword(*end)) { @@ -2117,12 +2119,15 @@ TclCompileExpr( int optimize) /* 0 for one-off expressions. */ { OpNode *opTree = NULL; /* Will point to the tree of operators */ - Tcl_Obj *litList = Tcl_NewObj(); /* List to hold the literals */ - Tcl_Obj *funcList = Tcl_NewObj(); /* List to hold the functon names*/ + Tcl_Obj *litList; /* List to hold the literals */ + Tcl_Obj *funcList; /* List to hold the functon names*/ Tcl_Parse *parsePtr = TclStackAlloc(interp, sizeof(Tcl_Parse)); /* Holds the Tcl_Tokens of substitutions */ + int code; - int code = ParseExpr(interp, script, numBytes, &opTree, litList, + TclNewObj(litList); + TclNewObj(funcList); + code = ParseExpr(interp, script, numBytes, &opTree, litList, funcList, parsePtr, 0 /* parseOnly */); if (code == TCL_OK) { @@ -2181,9 +2186,10 @@ ExecConstantExprTree( CompileEnv *envPtr; ByteCode *byteCodePtr; int code; - Tcl_Obj *byteCodeObj = Tcl_NewObj(); + Tcl_Obj *byteCodeObj; NRE_callback *rootPtr = TOP_CB(interp); + TclNewObj(byteCodeObj); /* * Note we are compiling an expression with literal arguments. This means * there can be no [info frame] calls when we execute the resulting diff --git a/generic/tclCompile.c b/generic/tclCompile.c index 4a50089..9a59b71 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -1710,7 +1710,7 @@ TclWordKnownAtCompileTime( } tokenPtr++; if (valuePtr != NULL) { - tempPtr = Tcl_NewObj(); + TclNewObj(tempPtr); Tcl_IncrRefCount(tempPtr); } while (numComponents--) { @@ -1999,7 +1999,7 @@ CompileCommandTokens( Interp *iPtr = (Interp *) interp; Tcl_Token *tokenPtr = parsePtr->tokenPtr; ExtCmdLoc *eclPtr = envPtr->extCmdMapPtr; - Tcl_Obj *cmdObj = Tcl_NewObj(); + Tcl_Obj *cmdObj; Command *cmdPtr = NULL; int code = TCL_ERROR; int cmdKnown, expand = -1; @@ -2010,6 +2010,7 @@ CompileCommandTokens( int startCodeOffset = envPtr->codeNext - envPtr->codeStart; int depth = TclGetStackDepth(envPtr); + TclNewObj(cmdObj); assert (parsePtr->numWords > 0); /* Pre-Compile */ diff --git a/generic/tclDisassemble.c b/generic/tclDisassemble.c index 8b137d4..3b03c42 100644 --- a/generic/tclDisassemble.c +++ b/generic/tclDisassemble.c @@ -798,8 +798,9 @@ Tcl_Obj * TclNewInstNameObj( unsigned char inst) { - Tcl_Obj *objPtr = Tcl_NewObj(); + Tcl_Obj *objPtr; + TclNewObj(objPtr); objPtr->typePtr = &tclInstNameType; objPtr->internalRep.longValue = (long) inst; objPtr->bytes = NULL; @@ -943,7 +944,7 @@ DisassembleByteCodeAsDicts( * Get the literals from the bytecode. */ - literals = Tcl_NewObj(); + TclNewObj(literals); for (i=0 ; inumLitObjects ; i++) { Tcl_ListObjAppendElement(NULL, literals, codePtr->objArrayPtr[i]); } @@ -952,7 +953,7 @@ DisassembleByteCodeAsDicts( * Get the variables from the bytecode. */ - variables = Tcl_NewObj(); + TclNewObj(variables); if (codePtr->procPtr) { int localCount = codePtr->procPtr->numCompiledLocals; CompiledLocal *localPtr = codePtr->procPtr->firstLocalPtr; @@ -960,7 +961,7 @@ DisassembleByteCodeAsDicts( for (i=0 ; inextPtr) { Tcl_Obj *descriptor[2]; - descriptor[0] = Tcl_NewObj(); + TclNewObj(descriptor[0]); if (!(localPtr->flags & (VAR_ARRAY|VAR_LINK))) { Tcl_ListObjAppendElement(NULL, descriptor[0], Tcl_NewStringObj("scalar", -1)); @@ -1000,12 +1001,12 @@ DisassembleByteCodeAsDicts( * Get the instructions from the bytecode. */ - instructions = Tcl_NewObj(); + TclNewObj(instructions); for (pc=codePtr->codeStart; pccodeStart+codePtr->numCodeBytes;){ const InstructionDesc *instDesc = &tclInstructionTable[*pc]; int address = pc - codePtr->codeStart; - inst = Tcl_NewObj(); + TclNewObj(inst); Tcl_ListObjAppendElement(NULL, inst, Tcl_NewStringObj( instDesc->name, -1)); opnd = pc + 1; @@ -1103,21 +1104,23 @@ DisassembleByteCodeAsDicts( * Get the auxiliary data from the bytecode. */ - aux = Tcl_NewObj(); + TclNewObj(aux); for (i=0 ; inumAuxDataItems ; i++) { AuxData *auxData = &codePtr->auxDataArrayPtr[i]; Tcl_Obj *auxDesc = Tcl_NewStringObj(auxData->type->name, -1); if (auxData->type->disassembleProc) { - Tcl_Obj *desc = Tcl_NewObj(); + Tcl_Obj *desc; + TclNewObj(desc); Tcl_DictObjPut(NULL, desc, Tcl_NewStringObj("name", -1), auxDesc); auxDesc = desc; auxData->type->disassembleProc(auxData->clientData, auxDesc, codePtr, 0); } else if (auxData->type->printProc) { - Tcl_Obj *desc = Tcl_NewObj(); + Tcl_Obj *desc; + TclNewObj(desc); auxData->type->printProc(auxData->clientData, desc, codePtr, 0); Tcl_ListObjAppendElement(NULL, auxDesc, desc); } @@ -1128,7 +1131,7 @@ DisassembleByteCodeAsDicts( * Get the exception ranges from the bytecode. */ - exn = Tcl_NewObj(); + TclNewObj(exn); for (i=0 ; inumExceptRanges ; i++) { ExceptionRange *rangePtr = &codePtr->exceptArrayPtr[i]; @@ -1163,7 +1166,7 @@ DisassembleByteCodeAsDicts( ? ((ptr)+=5 , TclGetInt4AtPtr((ptr)-4)) \ : ((ptr)+=1 , TclGetInt1AtPtr((ptr)-1))) - commands = Tcl_NewObj(); + TclNewObj(commands); codeOffPtr = codePtr->codeDeltaStart; codeLenPtr = codePtr->codeLengthStart; srcOffPtr = codePtr->srcDeltaStart; @@ -1176,7 +1179,7 @@ DisassembleByteCodeAsDicts( codeLength = Decode(codeLenPtr); sourceOffset += Decode(srcOffPtr); sourceLength = Decode(srcLenPtr); - cmd = Tcl_NewObj(); + TclNewObj(cmd); Tcl_DictObjPut(NULL, cmd, Tcl_NewStringObj("codefrom", -1), Tcl_NewIntObj(codeOffset)); Tcl_DictObjPut(NULL, cmd, Tcl_NewStringObj("codeto", -1), @@ -1211,7 +1214,7 @@ DisassembleByteCodeAsDicts( * Build the overall result. */ - description = Tcl_NewObj(); + TclNewObj(description); Tcl_DictObjPut(NULL, description, Tcl_NewStringObj("literals", -1), literals); Tcl_DictObjPut(NULL, description, Tcl_NewStringObj("variables", -1), diff --git a/generic/tclEncoding.c b/generic/tclEncoding.c index 8fff493..4c59bc6 100644 --- a/generic/tclEncoding.c +++ b/generic/tclEncoding.c @@ -481,12 +481,13 @@ FillEncodingFileMap(void) */ int j, numFiles; - Tcl_Obj *directory, *matchFileList = Tcl_NewObj(); + Tcl_Obj *directory, *matchFileList; Tcl_Obj **filev; Tcl_GlobTypeData readableFiles = { TCL_GLOB_TYPE_FILE, TCL_GLOB_PERM_R, NULL, NULL }; + TclNewObj(matchFileList); Tcl_ListObjIndex(NULL, searchPath, i, &directory); Tcl_IncrRefCount(directory); Tcl_IncrRefCount(matchFileList); @@ -903,10 +904,11 @@ Tcl_GetEncodingNames( Tcl_HashTable table; Tcl_HashSearch search; Tcl_HashEntry *hPtr; - Tcl_Obj *map, *name, *result = Tcl_NewObj(); + Tcl_Obj *map, *name, *result; Tcl_DictSearch mapSearch; int dummy, done = 0; + TclNewObj(result); Tcl_InitObjHashTable(&table); /* diff --git a/generic/tclEnsemble.c b/generic/tclEnsemble.c index 7f47510..bdf4d84 100644 --- a/generic/tclEnsemble.c +++ b/generic/tclEnsemble.c @@ -2913,7 +2913,7 @@ TclCompileEnsemble( DefineLineInformation; Tcl_Token *tokenPtr = TokenAfter(parsePtr->tokenPtr); Tcl_Obj *mapObj, *subcmdObj, *targetCmdObj, *listObj, **elems; - Tcl_Obj *replaced = Tcl_NewObj(), *replacement; + Tcl_Obj *replaced, *replacement; Tcl_Command ensemble = (Tcl_Command) cmdPtr; Command *oldCmdPtr = cmdPtr, *newCmdPtr; int len, result, flags = 0, i, depth = 1, invokeAnyway = 0; @@ -2921,6 +2921,7 @@ TclCompileEnsemble( unsigned numBytes; const char *word; + TclNewObj(replaced); Tcl_IncrRefCount(replaced); if (parsePtr->numWords < depth + 1) { goto failed; @@ -3424,7 +3425,7 @@ CompileToInvokedCommand( * the implementation. */ - objPtr = Tcl_NewObj(); + TclNewObj(objPtr); Tcl_GetCommandFullName(interp, (Tcl_Command) cmdPtr, objPtr); bytes = Tcl_GetStringFromObj(objPtr, &length); if ((cmdPtr != NULL) && (cmdPtr->flags & CMD_VIA_RESOLVER)) { @@ -3463,8 +3464,9 @@ CompileBasicNArgCommand( * compiled. */ CompileEnv *envPtr) /* Holds resulting instructions. */ { - Tcl_Obj *objPtr = Tcl_NewObj(); + Tcl_Obj *objPtr; + TclNewObj(objPtr); Tcl_IncrRefCount(objPtr); Tcl_GetCommandFullName(interp, (Tcl_Command) cmdPtr, objPtr); TclCompileInvocation(interp, parsePtr->tokenPtr, objPtr, diff --git a/generic/tclIOCmd.c b/generic/tclIOCmd.c index af1295f..f11a4ab 100644 --- a/generic/tclIOCmd.c +++ b/generic/tclIOCmd.c @@ -323,7 +323,7 @@ Tcl_GetsObjCmd( } TclChannelPreserve(chan); - linePtr = Tcl_NewObj(); + TclNewObj(linePtr); lineLen = Tcl_GetsObj(chan, linePtr); if (lineLen < 0) { if (!Tcl_Eof(chan) && !Tcl_InputBlocked(chan)) { @@ -463,7 +463,7 @@ Tcl_ReadObjCmd( } } - resultPtr = Tcl_NewObj(); + TclNewObj(resultPtr); Tcl_IncrRefCount(resultPtr); TclChannelPreserve(chan); charactersRead = Tcl_ReadChars(chan, resultPtr, toRead, 0); @@ -991,7 +991,7 @@ Tcl_ExecObjCmd( return TCL_OK; } - resultPtr = Tcl_NewObj(); + TclNewObj(resultPtr); if (Tcl_GetChannelHandle(chan, TCL_READABLE, NULL) == TCL_OK) { if (Tcl_ReadChars(chan, resultPtr, -1, 0) < 0) { /* @@ -1903,7 +1903,7 @@ ChanPipeObjCmd( channelNames[0] = Tcl_GetChannelName(rchan); channelNames[1] = Tcl_GetChannelName(wchan); - resultPtr = Tcl_NewObj(); + TclNewObj(resultPtr); Tcl_ListObjAppendElement(NULL, resultPtr, Tcl_NewStringObj(channelNames[0], -1)); Tcl_ListObjAppendElement(NULL, resultPtr, diff --git a/generic/tclIORTrans.c b/generic/tclIORTrans.c index eecd412..97540a6 100644 --- a/generic/tclIORTrans.c +++ b/generic/tclIORTrans.c @@ -1224,7 +1224,7 @@ ReflectInput( } if (Tcl_IsShared(bufObj)) { Tcl_DecrRefCount(bufObj); - bufObj = Tcl_NewObj(); + TclNewObj(bufObj); Tcl_IncrRefCount(bufObj); } Tcl_SetByteArrayLength(bufObj, 0); diff --git a/generic/tclIOUtil.c b/generic/tclIOUtil.c index 312fd08..1f8076a 100644 --- a/generic/tclIOUtil.c +++ b/generic/tclIOUtil.c @@ -1775,7 +1775,7 @@ Tcl_FSEvalFileEx( } } - objPtr = Tcl_NewObj(); + TclNewObj(objPtr); Tcl_IncrRefCount(objPtr); /* @@ -1909,7 +1909,7 @@ TclNREvalFile( } } - objPtr = Tcl_NewObj(); + TclNewObj(objPtr); Tcl_IncrRefCount(objPtr); /* @@ -3878,8 +3878,9 @@ Tcl_Obj * Tcl_FSListVolumes(void) { FilesystemRecord *fsRecPtr; - Tcl_Obj *resultPtr = Tcl_NewObj(); + Tcl_Obj *resultPtr; + TclNewObj(resultPtr); /* * Call each of the "listVolumes" function in succession. A non-NULL * return value indicates the particular function has succeeded. We call @@ -3945,7 +3946,7 @@ FsListMounts( if (fsRecPtr->fsPtr != &tclNativeFilesystem && fsRecPtr->fsPtr->matchInDirectoryProc != NULL) { if (resultPtr == NULL) { - resultPtr = Tcl_NewObj(); + TclNewObj(resultPtr); } fsRecPtr->fsPtr->matchInDirectoryProc(NULL, resultPtr, pathPtr, pattern, &mountsOnly); @@ -4021,7 +4022,7 @@ Tcl_FSSplitPath( * slashes (for example 'ftp://' is a valid vfs drive name) */ - result = Tcl_NewObj(); + TclNewObj(result); p = Tcl_GetString(pathPtr); Tcl_ListObjAppendElement(NULL, result, Tcl_NewStringObj(p, driveNameLength)); diff --git a/generic/tclInterp.c b/generic/tclInterp.c index 4f5b300..271bbf2 100644 --- a/generic/tclInterp.c +++ b/generic/tclInterp.c @@ -1021,7 +1021,7 @@ NRInterpCmd( return TCL_ERROR; } iiPtr = (InterpInfo *) ((Interp *) childInterp)->interpInfo; - resultPtr = Tcl_NewObj(); + TclNewObj(resultPtr); hPtr = Tcl_FirstHashEntry(&iiPtr->parent.childTable, &hashSearch); for ( ; hPtr != NULL; hPtr = Tcl_NextHashEntry(&hashSearch)) { string = Tcl_GetHashKey(&iiPtr->parent.childTable, hPtr); @@ -1748,10 +1748,11 @@ AliasList( { Tcl_HashEntry *entryPtr; Tcl_HashSearch hashSearch; - Tcl_Obj *resultPtr = Tcl_NewObj(); + Tcl_Obj *resultPtr; Alias *aliasPtr; Child *childPtr; + TclNewObj(resultPtr); childPtr = &((InterpInfo *) ((Interp *) childInterp)->interpInfo)->child; entryPtr = Tcl_FirstHashEntry(&childPtr->aliasTable, &hashSearch); @@ -2725,7 +2726,7 @@ ChildDebugCmd( iPtr = (Interp *) childInterp; if (objc == 0) { - resultPtr = Tcl_NewObj(); + TclNewObj(resultPtr); Tcl_ListObjAppendElement(NULL, resultPtr, Tcl_NewStringObj("-frame", -1)); Tcl_ListObjAppendElement(NULL, resultPtr, @@ -2994,11 +2995,12 @@ ChildHidden( Tcl_Interp *interp, /* Interp for data return. */ Tcl_Interp *childInterp) /* Interp whose hidden commands to query. */ { - Tcl_Obj *listObjPtr = Tcl_NewObj(); /* Local object pointer. */ + Tcl_Obj *listObjPtr; /* Local object pointer. */ Tcl_HashTable *hTblPtr; /* For local searches. */ Tcl_HashEntry *hPtr; /* For local searches. */ Tcl_HashSearch hSearch; /* For local searches. */ + TclNewObj(listObjPtr); hTblPtr = ((Interp *) childInterp)->hiddenCmdTablePtr; if (hTblPtr != NULL) { for (hPtr = Tcl_FirstHashEntry(hTblPtr, &hSearch); diff --git a/generic/tclOO.c b/generic/tclOO.c index 053abfe..9a32543 100644 --- a/generic/tclOO.c +++ b/generic/tclOO.c @@ -2925,7 +2925,7 @@ TclOOObjectName( if (oPtr->cachedNameObj) { return oPtr->cachedNameObj; } - namePtr = Tcl_NewObj(); + TclNewObj(namePtr); Tcl_GetCommandFullName(interp, oPtr->command, namePtr); Tcl_IncrRefCount(namePtr); oPtr->cachedNameObj = namePtr; diff --git a/generic/tclOOBasic.c b/generic/tclOOBasic.c index b7f70e7..e746b64 100644 --- a/generic/tclOOBasic.c +++ b/generic/tclOOBasic.c @@ -727,7 +727,7 @@ TclOO_Object_VarName( * (including traversing variable links), convert back to a name. */ - varNamePtr = Tcl_NewObj(); + TclNewObj(varNamePtr); if (aryVar != NULL) { Tcl_HashEntry *hPtr; Tcl_HashSearch search; diff --git a/generic/tclOODefineCmds.c b/generic/tclOODefineCmds.c index aeee165..c1115be 100644 --- a/generic/tclOODefineCmds.c +++ b/generic/tclOODefineCmds.c @@ -850,8 +850,8 @@ MagicDefinitionInvoke( * comments above for why these contortions are necessary. */ - objPtr = Tcl_NewObj(); - obj2Ptr = Tcl_NewObj(); + TclNewObj(objPtr); + TclNewObj(obj2Ptr); cmd = FindCommand(interp, objv[cmdIndex], nsPtr); if (cmd == NULL) { /* @@ -1874,7 +1874,7 @@ ClassFilterGet( return TCL_ERROR; } - resultObj = Tcl_NewObj(); + TclNewObj(resultObj); FOREACH(filterObj, oPtr->classPtr->filters) { Tcl_ListObjAppendElement(NULL, resultObj, filterObj); } @@ -1954,7 +1954,7 @@ ClassMixinGet( return TCL_ERROR; } - resultObj = Tcl_NewObj(); + TclNewObj(resultObj); FOREACH(mixinPtr, oPtr->classPtr->mixins) { Tcl_ListObjAppendElement(NULL, resultObj, TclOOObjectName(interp, mixinPtr->thisPtr)); @@ -2059,7 +2059,7 @@ ClassSuperGet( return TCL_ERROR; } - resultObj = Tcl_NewObj(); + TclNewObj(resultObj); FOREACH(superPtr, oPtr->classPtr->superclasses) { Tcl_ListObjAppendElement(NULL, resultObj, TclOOObjectName(interp, superPtr->thisPtr)); @@ -2224,7 +2224,7 @@ ClassVarsGet( return TCL_ERROR; } - resultObj = Tcl_NewObj(); + TclNewObj(resultObj); FOREACH(variableObj, oPtr->classPtr->variables) { Tcl_ListObjAppendElement(NULL, resultObj, variableObj); } @@ -2360,7 +2360,7 @@ ObjFilterGet( return TCL_ERROR; } - resultObj = Tcl_NewObj(); + TclNewObj(resultObj); FOREACH(filterObj, oPtr->filters) { Tcl_ListObjAppendElement(NULL, resultObj, filterObj); } @@ -2428,7 +2428,7 @@ ObjMixinGet( return TCL_ERROR; } - resultObj = Tcl_NewObj(); + TclNewObj(resultObj); FOREACH(mixinPtr, oPtr->mixins) { if (mixinPtr) { Tcl_ListObjAppendElement(NULL, resultObj, @@ -2512,7 +2512,7 @@ ObjVarsGet( return TCL_ERROR; } - resultObj = Tcl_NewObj(); + TclNewObj(resultObj); FOREACH(variableObj, oPtr->variables) { Tcl_ListObjAppendElement(NULL, resultObj, variableObj); } diff --git a/generic/tclOOInfo.c b/generic/tclOOInfo.c index 4b25c1a..9f1233c 100644 --- a/generic/tclOOInfo.c +++ b/generic/tclOOInfo.c @@ -266,13 +266,13 @@ InfoObjectDefnCmd( return TCL_ERROR; } - resultObjs[0] = Tcl_NewObj(); + TclNewObj(resultObjs[0]); for (localPtr=procPtr->firstLocalPtr; localPtr!=NULL; localPtr=localPtr->nextPtr) { if (TclIsVarArgument(localPtr)) { Tcl_Obj *argObj; - argObj = Tcl_NewObj(); + TclNewObj(argObj); Tcl_ListObjAppendElement(NULL, argObj, Tcl_NewStringObj(localPtr->name, -1)); if (localPtr->defValuePtr != NULL) { @@ -316,7 +316,7 @@ InfoObjectFiltersCmd( if (oPtr == NULL) { return TCL_ERROR; } - resultObj = Tcl_NewObj(); + TclNewObj(resultObj); FOREACH(filterObj, oPtr->filters) { Tcl_ListObjAppendElement(NULL, resultObj, filterObj); @@ -560,7 +560,7 @@ InfoObjectMethodsCmd( } } - resultObj = Tcl_NewObj(); + TclNewObj(resultObj); if (recurse) { const char **names; int i, numNames = TclOOGetSortedMethodList(oPtr, flag, &names); @@ -671,7 +671,7 @@ InfoObjectMixinsCmd( return TCL_ERROR; } - resultObj = Tcl_NewObj(); + TclNewObj(resultObj); FOREACH(mixinPtr, oPtr->mixins) { if (!mixinPtr) { continue; @@ -746,7 +746,7 @@ InfoObjectVariablesCmd( return TCL_ERROR; } - resultObj = Tcl_NewObj(); + TclNewObj(resultObj); FOREACH(variableObj, oPtr->variables) { Tcl_ListObjAppendElement(NULL, resultObj, variableObj); } @@ -788,7 +788,7 @@ InfoObjectVarsCmd( if (objc == 3) { pattern = TclGetString(objv[2]); } - resultObj = Tcl_NewObj(); + TclNewObj(resultObj); /* * Extract the information we need from the object's namespace's table of @@ -856,13 +856,13 @@ InfoClassConstrCmd( return TCL_ERROR; } - resultObjs[0] = Tcl_NewObj(); + TclNewObj(resultObjs[0]); for (localPtr=procPtr->firstLocalPtr; localPtr!=NULL; localPtr=localPtr->nextPtr) { if (TclIsVarArgument(localPtr)) { Tcl_Obj *argObj; - argObj = Tcl_NewObj(); + TclNewObj(argObj); Tcl_ListObjAppendElement(NULL, argObj, Tcl_NewStringObj(localPtr->name, -1)); if (localPtr->defValuePtr != NULL) { @@ -924,13 +924,13 @@ InfoClassDefnCmd( return TCL_ERROR; } - resultObjs[0] = Tcl_NewObj(); + TclNewObj(resultObjs[0]); for (localPtr=procPtr->firstLocalPtr; localPtr!=NULL; localPtr=localPtr->nextPtr) { if (TclIsVarArgument(localPtr)) { Tcl_Obj *argObj; - argObj = Tcl_NewObj(); + TclNewObj(argObj); Tcl_ListObjAppendElement(NULL, argObj, Tcl_NewStringObj(localPtr->name, -1)); if (localPtr->defValuePtr != NULL) { @@ -1018,7 +1018,7 @@ InfoClassFiltersCmd( return TCL_ERROR; } - resultObj = Tcl_NewObj(); + TclNewObj(resultObj); FOREACH(filterObj, clsPtr->filters) { Tcl_ListObjAppendElement(NULL, resultObj, filterObj); } @@ -1112,7 +1112,7 @@ InfoClassInstancesCmd( pattern = TclGetString(objv[2]); } - resultObj = Tcl_NewObj(); + TclNewObj(resultObj); FOREACH(oPtr, clsPtr->instances) { Tcl_Obj *tmpObj = TclOOObjectName(interp, oPtr); @@ -1183,7 +1183,7 @@ InfoClassMethodsCmd( } } - resultObj = Tcl_NewObj(); + TclNewObj(resultObj); if (recurse) { const char **names; int i, numNames = TclOOGetSortedClassMethodList(clsPtr, flag, &names); @@ -1290,7 +1290,7 @@ InfoClassMixinsCmd( return TCL_ERROR; } - resultObj = Tcl_NewObj(); + TclNewObj(resultObj); FOREACH(mixinPtr, clsPtr->mixins) { if (!mixinPtr) { continue; @@ -1336,7 +1336,7 @@ InfoClassSubsCmd( pattern = TclGetString(objv[2]); } - resultObj = Tcl_NewObj(); + TclNewObj(resultObj); FOREACH(subclassPtr, clsPtr->subclasses) { Tcl_Obj *tmpObj = TclOOObjectName(interp, subclassPtr->thisPtr); @@ -1387,7 +1387,7 @@ InfoClassSupersCmd( return TCL_ERROR; } - resultObj = Tcl_NewObj(); + TclNewObj(resultObj); FOREACH(superPtr, clsPtr->superclasses) { Tcl_ListObjAppendElement(NULL, resultObj, TclOOObjectName(interp, superPtr->thisPtr)); @@ -1426,7 +1426,7 @@ InfoClassVariablesCmd( return TCL_ERROR; } - resultObj = Tcl_NewObj(); + TclNewObj(resultObj); FOREACH(variableObj, clsPtr->variables) { Tcl_ListObjAppendElement(NULL, resultObj, variableObj); } diff --git a/generic/tclOOMethod.c b/generic/tclOOMethod.c index cd3c2c2..80e8478 100644 --- a/generic/tclOOMethod.c +++ b/generic/tclOOMethod.c @@ -394,7 +394,7 @@ TclOONewProcMethod( if (argsObj == NULL) { argsLen = -1; - argsObj = Tcl_NewObj(); + TclNewObj(argsObj); Tcl_IncrRefCount(argsObj); procName = ""; } else if (Tcl_ListObjLength(interp, argsObj, &argsLen) != TCL_OK) { @@ -1293,12 +1293,13 @@ CloneProcedureMethod( * Copy the argument list. */ - argsObj = Tcl_NewObj(); + TclNewObj(argsObj); for (localPtr=pmPtr->procPtr->firstLocalPtr; localPtr!=NULL; localPtr=localPtr->nextPtr) { if (TclIsVarArgument(localPtr)) { - Tcl_Obj *argObj = Tcl_NewObj(); + Tcl_Obj *argObj; + TclNewObj(argObj); Tcl_ListObjAppendElement(NULL, argObj, Tcl_NewStringObj(localPtr->name, -1)); if (localPtr->defValuePtr != NULL) { diff --git a/generic/tclPathObj.c b/generic/tclPathObj.c index d919c40..b69607a 100644 --- a/generic/tclPathObj.c +++ b/generic/tclPathObj.c @@ -743,7 +743,7 @@ TclPathPart( (Tcl_FSGetPathType(pathPtr) == TCL_PATH_RELATIVE))) { Tcl_ListObjIndex(NULL, splitPtr, splitElements-1, &resultPtr); } else { - resultPtr = Tcl_NewObj(); + TclNewObj(resultPtr); } } else { /* @@ -781,7 +781,7 @@ GetExtension( tail = TclGetString(pathPtr); extension = TclGetExtension(tail); if (extension == NULL) { - ret = Tcl_NewObj(); + TclNewObj(ret); } else { ret = Tcl_NewStringObj(extension, -1); } @@ -857,7 +857,8 @@ TclJoinPath( assert ( elements >= 0 ); if (elements == 0) { - return Tcl_NewObj(); + TclNewObj(res); + return res; } assert ( elements > 0 ); @@ -1056,7 +1057,7 @@ TclJoinPath( noQuickReturn: if (res == NULL) { - res = Tcl_NewObj(); + TclNewObj(res); ptr = Tcl_GetStringFromObj(res, &length); } else { ptr = Tcl_GetStringFromObj(res, &length); @@ -1317,7 +1318,7 @@ TclNewFSPathObj( return pathPtr; } - pathPtr = Tcl_NewObj(); + TclNewObj(pathPtr); fsPathPtr = ckalloc(sizeof(FsPath)); /* diff --git a/generic/tclPipe.c b/generic/tclPipe.c index 7d5fab0..f5c82f1 100644 --- a/generic/tclPipe.c +++ b/generic/tclPipe.c @@ -371,7 +371,7 @@ TclCleanupChildren( Tcl_Obj *objPtr; Tcl_Seek(errorChan, (Tcl_WideInt)0, SEEK_SET); - objPtr = Tcl_NewObj(); + TclNewObj(objPtr); count = Tcl_ReadChars(errorChan, objPtr, -1, 0); if (count < 0) { result = TCL_ERROR; diff --git a/generic/tclPkg.c b/generic/tclPkg.c index 2150c31..67c91c4 100644 --- a/generic/tclPkg.c +++ b/generic/tclPkg.c @@ -1014,7 +1014,7 @@ TclNRPackageObjCmd( } else { Tcl_Obj *resultObj; - resultObj = Tcl_NewObj(); + TclNewObj(resultObj); tablePtr = &iPtr->packageTable; for (hPtr = Tcl_FirstHashEntry(tablePtr, &search); hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) { @@ -1257,8 +1257,9 @@ TclNRPackageObjCmd( Tcl_WrongNumArgs(interp, 2, objv, "package"); return TCL_ERROR; } else { - Tcl_Obj *resultObj = Tcl_NewObj(); + Tcl_Obj *resultObj; + TclNewObj(resultObj); argv2 = TclGetString(objv[2]); hPtr = Tcl_FindHashEntry(&iPtr->packageTable, argv2); if (hPtr != NULL) { diff --git a/generic/tclRegexp.c b/generic/tclRegexp.c index 2070956..bd923ba 100644 --- a/generic/tclRegexp.c +++ b/generic/tclRegexp.c @@ -677,7 +677,7 @@ TclRegAbout( * well and Tcl has other limits that constrain things as well... */ - resultObj = Tcl_NewObj(); + TclNewObj(resultObj); Tcl_ListObjAppendElement(NULL, resultObj, Tcl_NewIntObj((int) regexpPtr->re.re_nsub)); diff --git a/generic/tclResult.c b/generic/tclResult.c index b1cf9ee..be84a61 100644 --- a/generic/tclResult.c +++ b/generic/tclResult.c @@ -245,7 +245,7 @@ Tcl_SaveResult( */ statePtr->objResultPtr = iPtr->objResultPtr; - iPtr->objResultPtr = Tcl_NewObj(); + TclNewObj(iPtr->objResultPtr); Tcl_IncrRefCount(iPtr->objResultPtr); /* @@ -1026,13 +1026,14 @@ Tcl_SetErrorCodeVA( Tcl_Interp *interp, /* Interpreter in which to set errorCode */ va_list argList) /* Variable argument list. */ { - Tcl_Obj *errorObj = Tcl_NewObj(); + Tcl_Obj *errorObj; /* * Scan through the arguments one at a time, appending them to the * errorCode field as list elements. */ + TclNewObj(errorObj); while (1) { char *elem = va_arg(argList, char *); @@ -1387,9 +1388,10 @@ TclMergeReturnOptions( int code = TCL_OK; int level = 1; Tcl_Obj *valuePtr; - Tcl_Obj *returnOpts = Tcl_NewObj(); + Tcl_Obj *returnOpts; Tcl_Obj **keys = GetKeys(); + TclNewObj(returnOpts); for (; objc > 1; objv += 2, objc -= 2) { int optLen; const char *opt = TclGetStringFromObj(objv[0], &optLen); @@ -1585,7 +1587,7 @@ Tcl_GetReturnOptions( if (iPtr->returnOpts) { options = Tcl_DuplicateObj(iPtr->returnOpts); } else { - options = Tcl_NewObj(); + TclNewObj(options); } if (result == TCL_RETURN) { diff --git a/generic/tclStringObj.c b/generic/tclStringObj.c index fc675cf..756b948 100644 --- a/generic/tclStringObj.c +++ b/generic/tclStringObj.c @@ -776,7 +776,8 @@ Tcl_GetRange( last = length - 1; } if (last < first) { - return Tcl_NewObj(); + TclNewObj(newObjPtr); + return newObjPtr; } return Tcl_NewByteArrayObj(bytes + first, last - first + 1); } @@ -801,9 +802,10 @@ Tcl_GetRange( last = stringPtr->numChars - 1; } if (last < first) { - return Tcl_NewObj(); + TclNewObj(newObjPtr); + return newObjPtr; } - newObjPtr = Tcl_NewStringObj(objPtr->bytes + first, last-first+1); + newObjPtr = Tcl_NewStringObj(objPtr->bytes + first, last - first + 1); /* * Since we know the char length of the result, store it. @@ -821,7 +823,8 @@ Tcl_GetRange( last = stringPtr->numChars - 1; } if (last < first) { - return Tcl_NewObj(); + TclNewObj(newObjPtr); + return newObjPtr; } #if TCL_UTF_MAX == 4 /* See: bug [11ae2be95dac9417] */ diff --git a/generic/tclTimer.c b/generic/tclTimer.c index d30879f..500a75e 100644 --- a/generic/tclTimer.c +++ b/generic/tclTimer.c @@ -949,13 +949,14 @@ Tcl_AfterObjCmd( break; case AFTER_INFO: if (objc == 2) { - Tcl_Obj *resultObj = Tcl_NewObj(); + Tcl_Obj *resultObj; + TclNewObj(resultObj); for (afterPtr = assocPtr->firstAfterPtr; afterPtr != NULL; afterPtr = afterPtr->nextPtr) { if (assocPtr->interp == interp) { - Tcl_ListObjAppendElement(NULL, resultObj, Tcl_ObjPrintf( - "after#%d", afterPtr->id)); + Tcl_ListObjAppendElement(NULL, resultObj, Tcl_ObjPrintf( + "after#%d", afterPtr->id)); } } Tcl_SetObjResult(interp, resultObj); @@ -974,14 +975,15 @@ Tcl_AfterObjCmd( Tcl_SetErrorCode(interp, "TCL","LOOKUP","EVENT", eventStr, NULL); return TCL_ERROR; } else { - Tcl_Obj *resultListPtr = Tcl_NewObj(); + Tcl_Obj *resultListPtr; - Tcl_ListObjAppendElement(interp, resultListPtr, - afterPtr->commandPtr); - Tcl_ListObjAppendElement(interp, resultListPtr, Tcl_NewStringObj( + TclNewObj(resultListPtr); + Tcl_ListObjAppendElement(interp, resultListPtr, + afterPtr->commandPtr); + Tcl_ListObjAppendElement(interp, resultListPtr, Tcl_NewStringObj( (afterPtr->token == NULL) ? "idle" : "timer", -1)); Tcl_SetObjResult(interp, resultListPtr); - } + } break; default: Tcl_Panic("Tcl_AfterObjCmd: bad subcommand index to afterSubCmds"); -- cgit v0.12 From b563c159d7f63f0a4ca1e9190ec4111d5d4908d9 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 17 Jan 2022 17:07:14 +0000 Subject: Fix merge conflict previous commit --- generic/tclBasic.c | 3 +-- generic/tclCompExpr.c | 2 -- generic/tclCompile.c | 1 - generic/tclIOUtil.c | 1 - 4 files changed, 1 insertion(+), 6 deletions(-) diff --git a/generic/tclBasic.c b/generic/tclBasic.c index 35fd5a9..45a430f 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -901,8 +901,7 @@ Tcl_CreateInterp(void) iPtr->activeInterpTracePtr = NULL; iPtr->assocData = NULL; iPtr->execEnvPtr = NULL; /* Set after namespaces initialized. */ - TclNewObj(iPtr->emptyObjPtr); - /* Another empty object. */ + TclNewObj(iPtr->emptyObjPtr); /* Another empty object. */ Tcl_IncrRefCount(iPtr->emptyObjPtr); #ifndef TCL_NO_DEPRECATED iPtr->resultSpace[0] = 0; diff --git a/generic/tclCompExpr.c b/generic/tclCompExpr.c index 8248770..23d8711 100644 --- a/generic/tclCompExpr.c +++ b/generic/tclCompExpr.c @@ -1880,8 +1880,6 @@ Tcl_ParseExpr( numBytes = (start ? strlen(start) : 0); } - TclNewObj(litList); - TclNewObj(funcList); code = ParseExpr(interp, start, numBytes, &opTree, litList, funcList, exprParsePtr, 1 /* parseOnly */); Tcl_DecrRefCount(funcList); diff --git a/generic/tclCompile.c b/generic/tclCompile.c index 650a6d4..f7479f0 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -2044,7 +2044,6 @@ CompileCommandTokens( int startCodeOffset = envPtr->codeNext - envPtr->codeStart; int depth = TclGetStackDepth(envPtr); - TclNewObj(cmdObj); assert (parsePtr->numWords > 0); /* Pre-Compile */ diff --git a/generic/tclIOUtil.c b/generic/tclIOUtil.c index 6b1dc3c..87e60c3 100644 --- a/generic/tclIOUtil.c +++ b/generic/tclIOUtil.c @@ -3775,7 +3775,6 @@ Tcl_FSListVolumes(void) FilesystemRecord *fsRecPtr; Tcl_Obj *resultPtr; - TclNewObj(resultPtr); /* * Call each "listVolumes" function of each registered filesystem in * succession. A non-NULL return value indicates the particular function -- cgit v0.12 From c3bcd951b8dd8bf57202915b9d914bcddc73b9bb Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 17 Jan 2022 17:26:37 +0000 Subject: Possible fix for [e9a2715d91]: Tcl 8.6.11: Incompatible Tcl_GetRange() --- generic/tclCmdMZ.c | 14 ++++++++++---- generic/tclExecute.c | 15 +++++++++++---- generic/tclStringObj.c | 12 ++++++++---- generic/tclTest.c | 2 +- 4 files changed, 30 insertions(+), 13 deletions(-) diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c index 5422b7f..bf75d44 100644 --- a/generic/tclCmdMZ.c +++ b/generic/tclCmdMZ.c @@ -395,9 +395,13 @@ Tcl_RegexpObjCmd( newPtr = Tcl_NewListObj(2, objs); } else { if (i <= info.nsubs) { - newPtr = Tcl_GetRange(objPtr, - offset + info.matches[i].start, - offset + info.matches[i].end - 1); + if (info.matches[i].end <= 0) { + TclNewObj(newPtr); + } else { + newPtr = Tcl_GetRange(objPtr, + offset + info.matches[i].start, + offset + info.matches[i].end - 1); + } } else { TclNewObj(newPtr); } @@ -2183,7 +2187,9 @@ StringRangeCmd( return TCL_ERROR; } - Tcl_SetObjResult(interp, Tcl_GetRange(objv[1], first, last)); + if (last >= 0) { + Tcl_SetObjResult(interp, Tcl_GetRange(objv[1], first, last)); + } return TCL_OK; } diff --git a/generic/tclExecute.c b/generic/tclExecute.c index c39bc21..a3b0401 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -5609,7 +5609,11 @@ TEBCresume( goto gotError; } - objResultPtr = Tcl_GetRange(OBJ_AT_DEPTH(2), fromIdx, toIdx); + if (toIdx < 0) { + TclNewObj(objResultPtr); + } else { + objResultPtr = Tcl_GetRange(OBJ_AT_DEPTH(2), fromIdx, toIdx); + } TRACE_APPEND(("\"%.30s\"\n", O2S(objResultPtr))); NEXT_INST_V(1, 3, 1); @@ -5653,11 +5657,14 @@ TEBCresume( fromIdx = TCL_INDEX_START; } if (fromIdx == TCL_INDEX_AFTER) { + goto emptyRange; + } + fromIdx = TclIndexDecode(fromIdx, length - 1); + if (toIdx >= 0) { + objResultPtr = Tcl_GetRange(valuePtr, fromIdx, toIdx); + } else { emptyRange: TclNewObj(objResultPtr); - } else { - fromIdx = TclIndexDecode(fromIdx, length - 1); - objResultPtr = Tcl_GetRange(valuePtr, fromIdx, toIdx); } TRACE_APPEND(("%.30s\n", O2S(objResultPtr))); NEXT_INST_F(9, 1, 1); diff --git a/generic/tclStringObj.c b/generic/tclStringObj.c index 756b948..b4f05dd 100644 --- a/generic/tclStringObj.c +++ b/generic/tclStringObj.c @@ -772,7 +772,7 @@ Tcl_GetRange( if (TclIsPureByteArray(objPtr)) { unsigned char *bytes = Tcl_GetByteArrayFromObj(objPtr, &length); - if (last >= length) { + if (last < 0 || last >= length) { last = length - 1; } if (last < first) { @@ -798,7 +798,7 @@ Tcl_GetRange( TclNumUtfChars(stringPtr->numChars, objPtr->bytes, objPtr->length); } if (stringPtr->numChars == objPtr->length) { - if (last >= stringPtr->numChars) { + if (last < 0 || last >= stringPtr->numChars) { last = stringPtr->numChars - 1; } if (last < first) { @@ -819,7 +819,7 @@ Tcl_GetRange( FillUnicodeRep(objPtr); stringPtr = GET_STRING(objPtr); } - if (last >= stringPtr->numChars) { + if (last < 0 || last >= stringPtr->numChars) { last = stringPtr->numChars - 1; } if (last < first) { @@ -2116,7 +2116,11 @@ Tcl_AppendFormatToObj( if (gotPrecision) { numChars = Tcl_GetCharLength(segment); if (precision < numChars) { - segment = Tcl_GetRange(segment, 0, precision - 1); + if (precision < 1) { + TclNewObj(segment); + } else { + segment = Tcl_GetRange(segment, 0, precision - 1); + } numChars = precision; Tcl_IncrRefCount(segment); allocSegment = 1; diff --git a/generic/tclTest.c b/generic/tclTest.c index ed016fe..8d22edf 100644 --- a/generic/tclTest.c +++ b/generic/tclTest.c @@ -3918,7 +3918,7 @@ TestregexpObjCmd( if (ii == -1) { TclRegExpRangeUniChar(regExpr, ii, &start, &end); newPtr = Tcl_GetRange(objPtr, start, end); - } else if (ii > info.nsubs) { + } else if (ii > info.nsubs || info.matches[ii].end <= 0) { newPtr = Tcl_NewObj(); } else { newPtr = Tcl_GetRange(objPtr, info.matches[ii].start, -- cgit v0.12 From d0b286927306af8bde7031529ad180eaa07dcc73 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 18 Jan 2022 23:26:20 +0000 Subject: Update documentation for Tcl_GetRange() --- doc/StringObj.3 | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/doc/StringObj.3 b/doc/StringObj.3 index 772073e..90b53f2 100644 --- a/doc/StringObj.3 +++ b/doc/StringObj.3 @@ -111,10 +111,12 @@ If negative, all characters up to the first null character are used. The index of the Unicode character to return. .AP int first in The index of the first Unicode character in the Unicode range to be -returned as a new value. +returned as a new value. If negative, behave the same as if the +value was 0. .AP int last in The index of the last Unicode character in the Unicode range to be -returned as a new value. +returned as a new value. If negative, take all characters up to +the last one available. .AP Tcl_Obj *objPtr in/out Points to a value to manipulate. .AP Tcl_Obj *appendObjPtr in -- cgit v0.12 From b97786c85dbd70fd4445f8161b205d5dbc56e844 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 19 Jan 2022 14:21:38 +0000 Subject: (partial) fix for [https://core.tcl-lang.org/tk/tktview?name=a9929f112a|a9929f112a]. WIP --- generic/tclUtil.c | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/generic/tclUtil.c b/generic/tclUtil.c index 32721f6..86b6369 100644 --- a/generic/tclUtil.c +++ b/generic/tclUtil.c @@ -3647,12 +3647,15 @@ GetWideForIndex( if (numType == TCL_NUMBER_INT) { /* objPtr holds an integer in the signed wide range */ *widePtr = *(Tcl_WideInt *)cd; + if (*widePtr < -1) { + *widePtr = -1; + } return TCL_OK; } if (numType == TCL_NUMBER_BIG) { /* objPtr holds an integer outside the signed wide range */ /* Truncate to the signed wide range. */ - *widePtr = ((mp_isneg((mp_int *)cd)) ? WIDE_MIN : WIDE_MAX); + *widePtr = ((mp_isneg((mp_int *)cd)) ? -1 : WIDE_MAX); return TCL_OK; } } -- cgit v0.12 From e433c571581eae56161e5c4dc8dcae36e31d8039 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 21 Jan 2022 08:43:13 +0000 Subject: Add test-cases for Tcl_GetIntForIndex(). This reveals a minor bug --- generic/tclTest.c | 29 +++++++++++++++++++++++++++++ generic/tclUtil.c | 7 ++----- tests/indexObj.test | 47 +++++++++++++++++++++++++++++++++++++++++++++++ 3 files changed, 78 insertions(+), 5 deletions(-) diff --git a/generic/tclTest.c b/generic/tclTest.c index 7ec3c41..95ef5b7 100644 --- a/generic/tclTest.c +++ b/generic/tclTest.c @@ -327,6 +327,7 @@ static Tcl_ObjCmdProc TestNumUtfCharsCmd; static Tcl_ObjCmdProc TestFindFirstCmd; static Tcl_ObjCmdProc TestFindLastCmd; static Tcl_ObjCmdProc TestHashSystemHashCmd; +static Tcl_ObjCmdProc TestGetIntForIndexCmd; static Tcl_NRPostProc NREUnwind_callback; static Tcl_ObjCmdProc TestNREUnwind; @@ -598,6 +599,8 @@ Tcltest_Init( TestFindFirstCmd, NULL, NULL); Tcl_CreateObjCommand(interp, "testfindlast", TestFindLastCmd, NULL, NULL); + Tcl_CreateObjCommand(interp, "testgetintforindex", + TestGetIntForIndexCmd, NULL, NULL); Tcl_CreateCommand(interp, "testsetplatform", TestsetplatformCmd, NULL, NULL); Tcl_CreateCommand(interp, "testsocket", TestSocketCmd, @@ -7036,6 +7039,32 @@ TestFindLastCmd( return TCL_OK; } +static int +TestGetIntForIndexCmd( + TCL_UNUSED(void *), + Tcl_Interp *interp, + int objc, + Tcl_Obj *const objv[]) +{ + int result, endvalue; + + if (objc != 3) { + Tcl_WrongNumArgs(interp, 1, objv, "index endvalue"); + return TCL_ERROR; + } + + if (Tcl_GetIntFromObj(interp, objv[2], &endvalue) != TCL_OK) { + return TCL_ERROR; + } + if (Tcl_GetIntForIndex(interp, objv[1], endvalue, &result) != TCL_OK) { + return TCL_ERROR; + } + Tcl_SetObjResult(interp, Tcl_NewIntObj(result)); + return TCL_OK; +} + + + #if defined(HAVE_CPUID) || defined(_WIN32) /* *---------------------------------------------------------------------- diff --git a/generic/tclUtil.c b/generic/tclUtil.c index 86b6369..10153fb 100644 --- a/generic/tclUtil.c +++ b/generic/tclUtil.c @@ -3647,15 +3647,12 @@ GetWideForIndex( if (numType == TCL_NUMBER_INT) { /* objPtr holds an integer in the signed wide range */ *widePtr = *(Tcl_WideInt *)cd; - if (*widePtr < -1) { - *widePtr = -1; - } return TCL_OK; } if (numType == TCL_NUMBER_BIG) { /* objPtr holds an integer outside the signed wide range */ /* Truncate to the signed wide range. */ - *widePtr = ((mp_isneg((mp_int *)cd)) ? -1 : WIDE_MAX); + *widePtr = ((mp_isneg((mp_int *)cd)) ? WIDE_MIN : WIDE_MAX); return TCL_OK; } } @@ -3706,7 +3703,7 @@ Tcl_GetIntForIndex( return TCL_ERROR; } if (indexPtr != NULL) { - if ((wide < 0) && (endValue > TCL_INDEX_END)) { + if ((wide < 0) && (endValue >= 0)) { *indexPtr = -1; } else if (wide > INT_MAX) { *indexPtr = INT_MAX; diff --git a/tests/indexObj.test b/tests/indexObj.test index 40418b3..9fd31b4 100644 --- a/tests/indexObj.test +++ b/tests/indexObj.test @@ -17,6 +17,7 @@ if {"::tcltest" ni [namespace children]} { catch [list package require -exact tcl::test [info patchlevel]] testConstraint testindexobj [llength [info commands testindexobj]] +testConstraint testgetintforindex [llength [info commands testgetintforindex]] testConstraint testparseargs [llength [info commands testparseargs]] test indexObj-1.1 {exact match} testindexobj { @@ -165,6 +166,52 @@ test indexObj-7.7 {Tcl_ParseArgsObjv memory management} testparseargs { testparseargs 1 2 3 4 5 6 7 8 9 0 -bool 1 2 3 4 5 6 7 8 9 0 } {1 21 {testparseargs 1 2 3 4 5 6 7 8 9 0 1 2 3 4 5 6 7 8 9 0}} +test indexObj-8.1 {Tcl_GetIntForIndex integer} testgetintforindex { + testgetintforindex 0 0 +} 0 +test indexObj-8.2 {Tcl_GetIntForIndex integer} testgetintforindex { + testgetintforindex -1 0 +} -1 +test indexObj-8.3 {Tcl_GetIntForIndex integer} testgetintforindex { + testgetintforindex -2 0 +} -1 +test indexObj-8.4 {Tcl_GetIntForIndex INT_MAX} testgetintforindex { + testgetintforindex 2147483647 0 +} 2147483647 +test indexObj-8.5 {Tcl_GetIntForIndex INT_MAX+1} testgetintforindex { + testgetintforindex 2147483648 0 +} 2147483647 +test indexObj-8.6 {Tcl_GetIntForIndex end-1} testgetintforindex { + testgetintforindex end-1 2147483646 +} 2147483645 +test indexObj-8.7 {Tcl_GetIntForIndex end-1} testgetintforindex { + testgetintforindex end-1 2147483647 +} 2147483646 +test indexObj-8.8 {Tcl_GetIntForIndex end} testgetintforindex { + testgetintforindex end 2147483646 +} 2147483646 +test indexObj-8.9 {Tcl_GetIntForIndex end} testgetintforindex { + testgetintforindex end 2147483647 +} 2147483647 +test indexObj-8.10 {Tcl_GetIntForIndex end-1} testgetintforindex { + testgetintforindex end-1 -1 +} -2 +test indexObj-8.11 {Tcl_GetIntForIndex end-1} testgetintforindex { + testgetintforindex end-1 -2 +} -3 +test indexObj-8.12 {Tcl_GetIntForIndex end} testgetintforindex { + testgetintforindex end -1 +} -1 +test indexObj-8.13 {Tcl_GetIntForIndex end} testgetintforindex { + testgetintforindex end -2 +} -2 +test indexObj-8.14 {Tcl_GetIntForIndex end+1} testgetintforindex { + testgetintforindex end+1 -1 +} 0 +test indexObj-8.15 {Tcl_GetIntForIndex end+1} testgetintforindex { + testgetintforindex end+1 -2 +} -1 + # cleanup ::tcltest::cleanupTests return -- cgit v0.12 From d4e2ae119e3f6d6e5d430cf810ea4dc396ecd9b7 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 21 Jan 2022 14:44:58 +0000 Subject: Undo part of [26539e78a7]. Although Tcl_GetRange() does it's own parameter check, it's caller doesn't have to do it any more. However, put back these check, better not depend on the improved behavior of Tcl_GetRange (yet). This gives the freedom to bring back Tcl_GetRange() to how it was in Tcl 8.6.10, if desired --- generic/tclCmdMZ.c | 20 +++++++++++--------- generic/tclExecute.c | 26 ++++++++++++++++++++++---- generic/tclStringObj.c | 7 ++++--- 3 files changed, 37 insertions(+), 16 deletions(-) diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c index bf75d44..34fd6bf 100644 --- a/generic/tclCmdMZ.c +++ b/generic/tclCmdMZ.c @@ -394,14 +394,10 @@ Tcl_RegexpObjCmd( newPtr = Tcl_NewListObj(2, objs); } else { - if (i <= info.nsubs) { - if (info.matches[i].end <= 0) { - TclNewObj(newPtr); - } else { - newPtr = Tcl_GetRange(objPtr, - offset + info.matches[i].start, - offset + info.matches[i].end - 1); - } + if ((i <= info.nsubs) && (info.matches[i].end > 0)) { + newPtr = Tcl_GetRange(objPtr, + offset + info.matches[i].start, + offset + info.matches[i].end - 1); } else { TclNewObj(newPtr); } @@ -2187,7 +2183,13 @@ StringRangeCmd( return TCL_ERROR; } - if (last >= 0) { + if (first < 0) { + first = 0; + } + if (last >= length) { + last = length; + } + if (last >= first) { Tcl_SetObjResult(interp, Tcl_GetRange(objv[1], first, last)); } return TCL_OK; diff --git a/generic/tclExecute.c b/generic/tclExecute.c index a3b0401..e5a6b71 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -5609,10 +5609,16 @@ TEBCresume( goto gotError; } - if (toIdx < 0) { - TclNewObj(objResultPtr); - } else { + if (fromIdx < 0) { + fromIdx = 0; + } + if (toIdx >= length) { + toIdx = length; + } + if (toIdx >= fromIdx) { objResultPtr = Tcl_GetRange(OBJ_AT_DEPTH(2), fromIdx, toIdx); + } else { + TclNewObj(objResultPtr); } TRACE_APPEND(("\"%.30s\"\n", O2S(objResultPtr))); NEXT_INST_V(1, 3, 1); @@ -5646,6 +5652,13 @@ TEBCresume( } toIdx = TclIndexDecode(toIdx, length - 1); + if (toIdx < 0) { + goto emptyRange; + } else if (toIdx >= length) { + toIdx = length - 1; + } + + assert ( toIdx >= 0 && toIdx < length ); /* assert ( fromIdx != TCL_INDEX_BEFORE ); @@ -5659,8 +5672,13 @@ TEBCresume( if (fromIdx == TCL_INDEX_AFTER) { goto emptyRange; } + fromIdx = TclIndexDecode(fromIdx, length - 1); - if (toIdx >= 0) { + if (fromIdx < 0) { + fromIdx = 0; + } + + if (fromIdx <= toIdx) { objResultPtr = Tcl_GetRange(valuePtr, fromIdx, toIdx); } else { emptyRange: diff --git a/generic/tclStringObj.c b/generic/tclStringObj.c index b4f05dd..9e0e4af 100644 --- a/generic/tclStringObj.c +++ b/generic/tclStringObj.c @@ -819,6 +819,7 @@ Tcl_GetRange( FillUnicodeRep(objPtr); stringPtr = GET_STRING(objPtr); } + if (last < 0 || last >= stringPtr->numChars) { last = stringPtr->numChars - 1; } @@ -829,12 +830,12 @@ Tcl_GetRange( #if TCL_UTF_MAX == 4 /* See: bug [11ae2be95dac9417] */ if ((first > 0) && ((stringPtr->unicode[first] & 0xFC00) == 0xDC00) - && ((stringPtr->unicode[first-1] & 0xFC00) == 0xD800)) { + && ((stringPtr->unicode[first-1] & 0xFC00) == 0xD800)) { ++first; } if ((last + 1 < stringPtr->numChars) - && ((stringPtr->unicode[last+1] & 0xFC00) == 0xDC00) - && ((stringPtr->unicode[last] & 0xFC00) == 0xD800)) { + && ((stringPtr->unicode[last+1] & 0xFC00) == 0xDC00) + && ((stringPtr->unicode[last] & 0xFC00) == 0xD800)) { ++last; } #endif -- cgit v0.12 From 641cba82ec80d575338440d9d8bbf84f711eb12c Mon Sep 17 00:00:00 2001 From: pooryorick Date: Sat, 22 Jan 2022 14:47:29 +0000 Subject: Rewrite of documentation for [chan] --- doc/chan.n | 1106 +++++++++++++++++++++++++----------------------------------- 1 file changed, 466 insertions(+), 640 deletions(-) diff --git a/doc/chan.n b/doc/chan.n index f788bbf..aa8bbca 100644 --- a/doc/chan.n +++ b/doc/chan.n @@ -1,5 +1,6 @@ '\" '\" Copyright (c) 2005-2006 Donal K. Fellows +'\" Copyright (c) 2021 Nathan Coulter '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. @@ -8,761 +9,586 @@ .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME -chan \- Read, write and manipulate channels +chan \- Reads, writes and manipulates channels. .SH SYNOPSIS -\fBchan \fIoption\fR ?\fIarg arg ...\fR? +\fBchan \fIoperation\fR ?\fIarg arg ...\fR? .BE .SH DESCRIPTION .PP -This command provides several operations for reading from, writing to -and otherwise manipulating open channels (such as have been created -with the \fBopen\fR and \fBsocket\fR commands, or the default named -channels \fBstdin\fR, \fBstdout\fR or \fBstderr\fR which correspond to -the process's standard input, output and error streams respectively). -\fIOption\fR indicates what to do with the channel; any unique -abbreviation for \fIoption\fR is acceptable. Valid options are: -.TP -\fBchan blocked \fIchannelId\fR -. -This tests whether the last input operation on the channel called -\fIchannelId\fR failed because it would have otherwise caused the -process to block, and returns 1 if that was the case. It returns 0 -otherwise. Note that this only ever returns 1 when the channel has -been configured to be non-blocking; all Tcl channels have blocking -turned on by default. -.TP -\fBchan close \fIchannelId\fR ?\fIdirection\fR? -. -Close and destroy the channel called \fIchannelId\fR. Note that this -deletes all existing file-events registered on the channel. -If the \fIdirection\fR argument (which must be \fBread\fR or \fBwrite\fR or -any unique abbreviation of them) is present, the channel will only be -half-closed, so that it can go from being read-write to write-only or -read-only respectively. If a read-only channel is closed for reading, it is -the same as if the channel is fully closed, and respectively similar for -write-only channels. Without the \fIdirection\fR argument, the channel is -closed for both reading and writing (but only if those directions are -currently open). It is an error to close a read-only channel for writing, or a -write-only channel for reading. +\fBchan\fR provides several operations for reading from, writing to, and +otherwise manipulating channels, e.g. those created by \fBopen\fR and +\fBsocket\fR, or the default channels \fBstdin\fR, \fBstdout\fR or \fBstderr\fR +which correspond respectively to the standard input, output, and error streams +of the process. Any unique abbreviation for \fIoperation\fR is acceptable. +Available operations are: +.TP +\fBchan blocked \fIchannelName\fR +. +Returns 1 when the channel is in non-blocking mode and the last input operation +on the channel failed because it would have otherwise caused the process to +block, and 0 otherwise. Each Tcl channel is in blocking mode unless configured +otherwise. +.TP +\fBchan close \fIchannelName\fR ?\fIdirection\fR? +. +Closes and destroys the named channel, deleting any existing event handlers +established for the channel, and returns the empty string. If \fIdirection\fR is +given, it is +.QW\fBread\fR +or +.QW\fBwrite\fR +or any unique abbreviation of those words, and only that side of the channel is +closed. I.e. a read-write channel may become read-only or write-only. +Closing a read-only channel for reading, or closing a write-only channel for +writing is the same as simply closing the channel. It is an error to close a +read-only channel for writing or to close a write-only channel for reading. .RS .PP -As part of closing the channel, all buffered output is flushed to the -channel's output device (only if the channel is ceasing to be writable), any -buffered input is discarded (only if the channel is ceasing to be readable), -the underlying operating system resource is closed and \fIchannelId\fR becomes -unavailable for future use (both only if the channel is being completely -closed). -.PP -If the channel is blocking and the channel is ceasing to be writable, the -command does not return until all output is flushed. If the channel is -non-blocking and there is unflushed output, the channel remains open and the -command returns immediately; output will be flushed in the background and the -channel will be closed when all the flushing is complete. -.PP -If \fIchannelId\fR is a blocking channel for a command pipeline then -\fBchan close\fR waits for the child processes to complete. -.PP -If the channel is shared between interpreters, then \fBchan close\fR -makes \fIchannelId\fR unavailable in the invoking interpreter but has -no other effect until all of the sharing interpreters have closed the -channel. When the last interpreter in which the channel is registered -invokes \fBchan close\fR (or \fBclose\fR), the cleanup actions -described above occur. With half-closing, the half-close of the channel only -applies to the current interpreter's view of the channel until all channels -have closed it in that direction (or completely). -See the \fBinterp\fR command for a description of channel sharing. -.PP -Channels are automatically fully closed when an interpreter is destroyed and -when the process exits. Channels are switched to blocking mode, to -ensure that all output is correctly flushed before the process exits. -.PP -The command returns an empty string, and may generate an error if -an error occurs while flushing output. If a command in a command -pipeline created with \fBopen\fR returns an error, \fBchan close\fR -generates an error (similar to the \fBexec\fR command.) -.PP -Note that half-closes of sockets and command pipelines can have important side -effects because they result in a shutdown() or close() of the underlying -system resource, which can change how other processes or systems respond to -the Tcl program. +When a channel is closed for writing, any buffered output on the channel is +flushed. When a channel is closed for reading, any buffered input is discarded. +When a channel is destroyed the underlying resource is closed and the channel +is thereafter unavailable. +.PP +\fBchan close\fR fully flushes any output before closing the write side of a +channel unless it is non-blocking mode, where it returns immediately and the +channel is flushed in the background before finally being closed. +.PP +\fBchan close\fR may return an error if an error occurs while flushing +output. If a process in a command pipeline created by \fBopen\fR returns an +error, \fBchan close\fR generates an error in the same manner as \fBexec\fR. +.PP +Closing one side of a socket or command pipeline may lead to the shutdown() or +close() of the underlying system resource, leading to a reaction from whatever +is on the other side of the pipeline or socket. +.PP +If the channel for a command pipeline is in blocking mode, \fBchan close\fR +waits for the connected processes to complete. +.PP +\fBchan close\fR only affects the current interpreter. If the channel is open +in any other interpreter, its state is unchanged there. See \fBinterp\fR for a +description of channel sharing. +.PP +When the last interpreter sharing a channel is destroyed, the channel is +switched to blocking mode and fully flushed and then closed. .RE .TP -\fBchan configure \fIchannelId\fR ?\fIoptionName\fR? ?\fIvalue\fR? ?\fIoptionName value\fR?... +\fBchan configure \fIchannelName\fR ?\fIoptionName\fR? ?\fIvalue\fR? ?\fIoptionName value\fR?... . -Query or set the configuration options of the channel named -\fIchannelId\fR. +Configures or reports the configuration of \fIchannelName\fR. .RS .PP -If no \fIoptionName\fR or \fIvalue\fR arguments are supplied, the -command returns a list containing alternating option names and values -for the channel. If \fIoptionName\fR is supplied but no \fIvalue\fR -then the command returns the current value of the given option. If -one or more pairs of \fIoptionName\fR and \fIvalue\fR are supplied, -the command sets each of the named options to the corresponding -\fIvalue\fR; in this case the return value is an empty string. -.PP -The options described below are supported for all channels. In -addition, each channel type may add options that only it supports. See -the manual entry for the command that creates each type of channel -for the options supported by that specific type of channel. For -example, see the manual entry for the \fBsocket\fR command for additional -options for sockets, and the \fBopen\fR command for additional options for -serial devices. +If no \fIoptionName\fR or \fIvalue\fR arguments are given, +\fBchan configure\fR returns a dictionary of option names and +values for the channel. If \fIoptionName\fR is supplied without a \fIvalue\fR, +\fBchan configure\fR returns the current value of the named option. If one or +more pairs of \fIoptionName\fR and \fIvalue\fR are supplied, +\fBchan configure\fR sets each of the named options to the corresponding +\fIvalue\fR and returns the empty string. +.PP +The options described below are supported for all channels. Each type of +channel may provide additional options. Those options are described in the +relevant documentation. For example, additional options are documented for +\fBsocket\fR, and also for serial devices at \fBopen\fR. .TP \fB\-blocking\fR \fIboolean\fR . -The \fB\-blocking\fR option determines whether I/O operations on the -channel can cause the process to block indefinitely. The value of the -option must be a proper boolean value. Channels are normally in -blocking mode; if a channel is placed into non-blocking mode it will -affect the operation of the \fBchan gets\fR, \fBchan read\fR, \fBchan -puts\fR, \fBchan flush\fR, and \fBchan close\fR commands; see the -documentation for those commands for details. For non-blocking mode to -work correctly, the application must be using the Tcl event loop -(e.g. by calling \fBTcl_DoOneEvent\fR or invoking the \fBvwait\fR -command). +If \fB\-blocking\fR is set to \fBtrue\fR, which is the default, reading from or +writing to the channel may cause the process to block indefinitely. Otherwise, +operations such as \fBchan gets\fR, \fBchan read\fR, \fBchan puts\fR, \fBchan +flush\fR, and \fBchan close\fR take care not to block. Non-blocking mode in +generally requires that the event loop is entered, e.g. by calling +\fBTcl_DoOneEvent\fR or \fBvwait\fR or by using Tk, to give Tcl a chance to +process events on the channel. .TP \fB\-buffering\fR \fInewValue\fR . -If \fInewValue\fR is \fBfull\fR then the I/O system will buffer output -until its internal buffer is full or until the \fBchan flush\fR -command is invoked. If \fInewValue\fR is \fBline\fR, then the I/O -system will automatically flush output for the channel whenever a -newline character is output. If \fInewValue\fR is \fBnone\fR, the I/O -system will flush automatically after every output operation. The -default is for \fB\-buffering\fR to be set to \fBfull\fR except for -channels that connect to terminal-like devices; for these channels the -initial setting is \fBline\fR. Additionally, \fBstdin\fR and -\fBstdout\fR are initially set to \fBline\fR, and \fBstderr\fR is set -to \fBnone\fR. +If \fInewValue\fR is \fBfull\fR, which is the default, output is buffered +until the internal buffer is full or until \fBchan flush\fR is called. If +\fInewValue\fR is \fBline\fR, output is flushed each time a end-of-line +character is written. If \fInewValue\fR is \fBnone\fR, output is flushed after +every output operation. For \fBstdin\fR, \fBstdout\fR, and channels that +connect to terminal-like devices, the default value is \fBline\fR. For +\fBstderr\fR the default value is \fBnone\fR. .TP \fB\-buffersize\fR \fInewSize\fR . -\fINewvalue\fR must be an integer; its value is used to set the size -of buffers, in bytes, subsequently allocated for this channel to store -input or output. \fINewvalue\fR must be a number of no more than one -million, allowing buffers of up to one million bytes in size. -.TP -\fB\-encoding\fR \fIname\fR -. -This option is used to specify the encoding of the channel as one of -the named encodings returned by \fBencoding names\fR or the special -value \fBbinary\fR, so that the data can be converted to and from -Unicode for use in Tcl. For instance, in order for Tcl to read -characters from a Japanese file in \fBshiftjis\fR and properly process -and display the contents, the encoding would be set to \fBshiftjis\fR. -Thereafter, when reading from the channel, the bytes in the Japanese -file would be converted to Unicode as they are read. Writing is also -supported \- as Tcl strings are written to the channel they will -automatically be converted to the specified encoding on output. +\fInewSize\fR, an integer no greater than one million, is the size in bytes of +any input or output buffers subsequently allocated for this channel. +.TP +\fB\-encoding\fR ?\fIname\fR? +. +Sets the encoding of the channel. \fIname\fR is either one of the names +returned by \fBencoding names\fR, or +.QW \fBbinary\fR +\&. Input is converted from the encoding into Unicode, and output is converted +from Unicode to the encoding. .RS .PP -If a file contains pure binary data (for instance, a JPEG image), the -encoding for the channel should be configured to be \fBbinary\fR. Tcl -will then assign no interpretation to the data in the file and simply -read or write raw bytes. The Tcl \fBbinary\fR command can be used to -manipulate this byte-oriented data. It is usually better to set the -\fB\-translation\fR option to \fBbinary\fR when you want to transfer -binary data, as this turns off the other automatic interpretations of -the bytes in the stream as well. -.PP -The default encoding for newly opened channels is the same platform- -and locale-dependent system encoding used for interfacing with the -operating system, as returned by \fBencoding system\fR. +\fBbinary\fR is an alias for \fBiso8859-1\fR: Each byte read from the +channel becomes the Unicode character having the same value as that byte, and +each character written to the channel becomes a single byte in the output, +allowing Tcl to work seamlessly with binary data as long as each "character" in +the data remains in the range of 0 to 255 so that there is no distinction between +binary data and text. For example, A JPEG image can be read from a +\fBbinary\fR channel, manipulated, and then written back to a \fBbinary\fR +channel. + +For working with binary data \fB\-translation binary\fR is usually used +instead, as it sets the encoding to \fBbinary\fR and also disables other +translations on the channel. +.PP +The encoding of a new channel is the value of \fBencoding system\fR, +which returns the platform- and locale-dependent system encoding used to +interface with the operating system, .RE .TP \fB\-eofchar\fR \fIchar\fR .TP \fB\-eofchar\fR \fB{\fIinChar outChar\fB}\fR . -This option supports DOS file systems that use Control-z (\ex1A) as an -end of file marker. If \fIchar\fR is not an empty string, then this -character signals end-of-file when it is encountered during input. -For output, the end-of-file character is output when the channel is -closed. If \fIchar\fR is the empty string, then there is no special -end of file character marker. For read-write channels, a two-element -list specifies the end of file marker for input and output, -respectively. As a convenience, when setting the end-of-file -character for a read-write channel you can specify a single value that -will apply to both reading and writing. When querying the end-of-file -character of a read-write channel, a two-element list will always be -returned. The default value for \fB\-eofchar\fR is the empty string -in all cases except for files under Windows. In that case the -\fB\-eofchar\fR is Control-z (\ex1A) for reading and the empty string -for writing. -The acceptable range for \fB\-eofchar\fR values is \ex01 - \ex7f; -attempting to set \fB\-eofchar\fR to a value outside of this range will -generate an error. -.TP -\fB\-translation\fR \fImode\fR -.TP -\fB\-translation\fR \fB{\fIinMode outMode\fB}\fR -. -In Tcl scripts the end of a line is always represented using a single -newline character (\en). However, in actual files and devices the end -of a line may be represented differently on different platforms, or -even for different devices on the same platform. For example, under -UNIX newlines are used in files, whereas carriage-return-linefeed -sequences are normally used in network connections. On input (i.e., -with \fBchan gets\fR and \fBchan read\fR) the Tcl I/O system -automatically translates the external end-of-line representation into -newline characters. Upon output (i.e., with \fBchan puts\fR), the I/O -system translates newlines to the external end-of-line representation. -The default translation mode, \fBauto\fR, handles all the common cases -automatically, but the \fB\-translation\fR option provides explicit -control over the end of line translations. +\fIchar\fR signals the end of the data when it is encountered in the input. +For output, the character is added when the channel is closed. If \fIchar\fR +is the empty string, there is no special character that marks the end of the +data. For read-write channels, one end-of-file character for input and another +for output may be given. When only one end-of-file character is given it is +applied to both input and output. For a read-write channel two values are +returned even if they are are identical. + +The default value is the empty string, except that under Windows the default +value for reading is Control-z (\ex1A). The acceptable range is \ex01 - +\ex7f. A value outside this range results in an error. +.TP +\fB\-translation\fR \fItranslation\fR +.TP +\fB\-translation\fR \fB{\fIinTranslation outTranslation\fB}\fR +. +In Tcl a single line feed (\en) represents the end of a line. However, +at the destination the end of a line may be represented differently on +different platforms, or even for different devices on the same platform. For +example, under UNIX line feed is used in files and a +carriage-return-linefeed sequence is normally used in network connections. +Therefore, on input, e.g. with \fBchan gets\fR and \fBchan read\fR, each +external end-of-line character is translated into a line feed. On +output, e.g. with \fBchan puts\fR, each line feed is translated to the external +end-of-line character. The default translation, \fBauto\fR, handles all the common +cases, and \fB\-translation\fR provides explicit control over the end-of-line +character. .RS .PP -The value associated with \fB\-translation\fR is a single item for -read-only and write-only channels. The value is a two-element list for -read-write channels; the read translation mode is the first element of -the list, and the write translation mode is the second element. As a -convenience, when setting the translation mode for a read-write channel -you can specify a single value that will apply to both reading and -writing. When querying the translation mode of a read-write channel, a -two-element list will always be returned. The following values are -currently supported: +Returns the input translation for a read-only channel, the output translation +for a write-only channel, and both the input translation and the the output +translation for a read-write channel. When two translations are given, they +are the input and output translation, respectively. When only one translation +is given for a read-write channel, it is the translation for both input and +output. The following values are currently supported: .TP \fBauto\fR . -As the input translation mode, \fBauto\fR treats any of newline -(\fBlf\fR), carriage return (\fBcr\fR), or carriage return followed by -a newline (\fBcrlf\fR) as the end of line representation. The end of -line representation can even change from line-to-line, and all cases -are translated to a newline. As the output translation mode, -\fBauto\fR chooses a platform specific representation; for sockets on -all platforms Tcl chooses \fBcrlf\fR, for all Unix flavors, it chooses -\fBlf\fR, and for the various flavors of Windows it chooses -\fBcrlf\fR. The default setting for \fB\-translation\fR is \fBauto\fR -for both input and output. +The default. For input each occurrence of a line feed (\fBlf\fR), carriage +return (\fBcr\fR), or carriage return followed by a line feed (\fBcrlf\fR) is +translated into a line feed. For output, each line feed is translated into a +platform-specific representation: For all Unix variants it is \fBlf\fR, and +for all Windows variants it is \fBcrlf\fR, except that for sockets on all +platforms it is \fBcrlf\fR for both input and output. .TP \fBbinary\fR . -No end-of-line translations are performed. This is nearly identical -to \fBlf\fR mode, except that in addition \fBbinary\fR mode also sets -the end-of-file character to the empty string (which disables it) and -sets the encoding to \fBbinary\fR (which disables encoding filtering). -See the description of \fB\-eofchar\fR and \fB\-encoding\fR for more -information. +Like \fBlf\fR, no end-of-line translation is performed, but in addition, +\fB\-eofchar\fR is set to the empty string to disable it, and \fB\-encoding\fR +is set to \fBbinary\fR. With this one setting, a channel is fully configured +for binary input and output. .TP \fBcr\fR . -The end of a line in the underlying file or device is represented by a -single carriage return character. As the input translation mode, -\fBcr\fR mode converts carriage returns to newline characters. As the -output translation mode, \fBcr\fR mode translates newline characters -to carriage returns. +The end of a line is represented in the external data by a single carriage +return character. For input, each carriage return is translated to a line +feed, and for output each line feed character is translated to a carriage +return. .TP \fBcrlf\fR . -The end of a line in the underlying file or device is represented by a -carriage return character followed by a linefeed character. As the -input translation mode, \fBcrlf\fR mode converts -carriage-return-linefeed sequences to newline characters. As the -output translation mode, \fBcrlf\fR mode translates newline characters -to carriage-return-linefeed sequences. This mode is typically used on -Windows platforms and for network connections. +The end of a line is represented in the external data by a carriage return +character followed by a line feed. For input, each carriage-return-linefeed +sequence is translated to a line feed. For output, each line feed is +translated to a carriage-return-linefeed sequence. This translation is +typically used for network connections, and also on Windows systems. .TP \fBlf\fR . -The end of a line in the underlying file or device is represented by a -single newline (linefeed) character. In this mode no translations -occur during either input or output. This mode is typically used on -UNIX platforms. +The end of a line in the external data is represented by a line feed so no +translations occur during either input or output. This translation is +typically used on UNIX platforms, .RE .RE .TP \fBchan copy \fIinputChan outputChan\fR ?\fB\-size \fIsize\fR? ?\fB\-command \fIcallback\fR? . -Copy data from the channel \fIinputChan\fR, which must have been -opened for reading, to the channel \fIoutputChan\fR, which must have -been opened for writing. The \fBchan copy\fR command leverages the -buffering in the Tcl I/O system to avoid extra copies and to avoid -buffering too much data in main memory when copying large files to -slow destinations like network sockets. +Copies data from \fIinputChan\fR to \fIoutputChan\fR, leveraging internal +buffers to avoid extra copies and to avoid buffering too much data in main +memory when copying large files to slow destinations like network sockets. .RS .PP -The \fBchan copy\fR command transfers data from \fIinputChan\fR until -end of file or \fIsize\fR bytes or characters have been transferred; -\fIsize\fR is in bytes if the two channels are using the same encoding, -and is in characters otherwise. If no \fB\-size\fR argument is given, -then the copy goes until end of file. All the data read from -\fIinputChan\fR is copied to \fIoutputChan\fR. Without the -\fB\-command\fR option, \fBchan copy\fR blocks until the copy is -complete and returns the number of bytes or characters (using the same -rules as for the \fB\-size\fR option) written to \fIoutputChan\fR. -.PP -The \fB\-command\fR argument makes \fBchan copy\fR work in the -background. In this case it returns immediately and the -\fIcallback\fR is invoked later when the copy completes. The -\fIcallback\fR is called with one or two additional arguments that -indicates how many bytes were written to \fIoutputChan\fR. If an -error occurred during the background copy, the second argument is the -error string associated with the error. With a background copy, it is -not necessary to put \fIinputChan\fR or \fIoutputChan\fR into -non-blocking mode; the \fBchan copy\fR command takes care of that -automatically. However, it is necessary to enter the event loop by -using the \fBvwait\fR command or by using Tk. -.PP -You are not allowed to do other I/O operations with \fIinputChan\fR or -\fIoutputChan\fR during a background \fBchan copy\fR. If either -\fIinputChan\fR or \fIoutputChan\fR get closed while the copy is in -progress, the current copy is stopped and the command callback is -\fInot\fR made. If \fIinputChan\fR is closed, then all data already -queued for \fIoutputChan\fR is written out. -.PP -Note that \fIinputChan\fR can become readable during a background -copy. You should turn off any \fBchan event\fR or \fBfileevent\fR -handlers during a background copy so those handlers do not interfere -with the copy. Any I/O attempted by a \fBchan event\fR or -\fBfileevent\fR handler will get a -.QW "channel busy" -error. -.PP -\fBChan copy\fR translates end-of-line sequences in \fIinputChan\fR -and \fIoutputChan\fR according to the \fB\-translation\fR option for -these channels (see \fBchan configure\fR above). The translations -mean that the number of bytes read from \fIinputChan\fR can be -different than the number of bytes written to \fIoutputChan\fR. Only -the number of bytes written to \fIoutputChan\fR is reported, either as -the return value of a synchronous \fBchan copy\fR or as the argument -to the callback for an asynchronous \fBchan copy\fR. -.PP -\fBChan copy\fR obeys the encodings and character translations -configured for the channels. This means that the incoming characters -are converted internally first UTF-8 and then into the encoding of the -channel \fBchan copy\fR writes to (see \fBchan configure\fR above for -details on the \fB\-encoding\fR and \fB\-translation\fR options). No -conversion is done if both channels are set to encoding \fBbinary\fR -and have matching translations. If only the output channel is set to -encoding \fBbinary\fR the system will write the internal UTF-8 -representation of the incoming characters. If only the input channel -is set to encoding \fBbinary\fR the system will assume that the -incoming bytes are valid UTF-8 characters and convert them according -to the output encoding. The behaviour of the system for bytes which -are not valid UTF-8 characters is undefined in this case. +If \fB\-size\fR is given, the size is in bytes if the two channels have the +same encoding and in characters otherwise, and only that amount is copied. +Otherwise, all data until the end of the file is copied. + +\fBchan copy\fR blocks until the copy is complete and returns the number of +bytes or characters written to \fIoutputChan\fR. +.PP +If \fB\-command\fR is given, \fBchan copy\fR returns immediately, the copy is +carried out in the background, and then \fIcallback\fR is called with the +number of bytes written to \fIoutputChan\fR as its first argument, and the +error message for any error that occurred as its second argument. +\fIinputChan\fR and \fIoutputChan\fR are automatically configured for +non-blocking mode if needed. Background copying only works correctly if the +event loop is active, e.g. via \fBvwait\fR or Tk. +.PP +During a background copy no other read or write operation may be performed on +\fIinputChan\fR or \fIoutputChan\fR. If either \fIinputChan\fR or +\fIoutputChan\fR is closed while the copy is in progress copying ceases and +\fBno\fR callback is made. If \fIinputChan\fR is closed all data already queued +is written to \fIoutputChan\fR. +.PP +The should be no event handler established for \fIinputChan\fR because it may +become readable during a background copy. An attempt to read or write +from within an event handler results result in the error, "channel busy". +.PP +Due to end-of-line translation the number of bytes read from \fIinputChan\fR +may be different than the number of bytes written to \fIoutputChan\fR. Only +the number of bytes written to \fIoutputChan\fR is reported. +.PP +\fBChan copy\fR reads the data according to the \fB\-encoding\fR, +\fB\-translation\fR, and \fB\-eofchar\fR of the source and writes to the +destination according to the configuration for that channel. If the encoding +and translation of both channels is \fBbinary\fR and the \fB\-eofchar\fR of +both channels is the empty string, an identical copy is made. If only the +encoding of the destination is \fBbinary\fR, Tcl's internal modified UTF-8 +representation of the characters read from the source is written to the +destination. If only the encoding of the source is \fBbinary\fR, each byte read +becomes one Unicode character in the range of 0 to 255, and that character is +subject to the encoding and translation of the destination as it is written. .RE .TP \fBchan create \fImode cmdPrefix\fR . -This subcommand creates a new script level channel using the command -prefix \fIcmdPrefix\fR as its handler. Any such channel is called a -\fBreflected\fR channel. The specified command prefix, \fBcmdPrefix\fR, -must be a non-empty list, and should provide the API described in the -\fBrefchan\fR manual page. The handle of the new channel is -returned as the result of the \fBchan create\fR command, and the -channel is open. Use either \fBclose\fR or \fBchan close\fR to remove -the channel. +Creates a new channel, called a \fBreflected\fR channel, with \fIcmdPrefix\fR +as its handler, and returns the name of the channel. \fBcmdPrefix\fR is the +first words of a command that provides the interface for a \fBrefchan\fR. .RS .PP -The argument \fImode\fR specifies if the new channel is opened for -reading, writing, or both. It has to be a list containing any of the -strings +\fBImode\fR is a list of one or more of the strings .QW \fBread\fR or -.QW \fBwrite\fR . -The list must have at least one -element, as a channel you can neither write to nor read from makes no -sense. The handler command for the new channel must support the chosen -mode, or an error is thrown. -.PP -The command prefix is executed in the global namespace, at the top of -call stack, following the appending of arguments as described in the -\fBrefchan\fR manual page. Command resolution happens at the -time of the call. Renaming the command, or destroying it means that -the next call of a handler method may fail, causing the channel -command invoking the handler to fail as well. Depending on the -subcommand being invoked, the error message may not be able to explain -the reason for that failure. -.PP -Every channel created with this subcommand knows which interpreter it -was created in, and only ever executes its handler command in that -interpreter, even if the channel was shared with and/or was moved into -a different interpreter. Each reflected channel also knows the thread -it was created in, and executes its handler command only in that -thread, even if the channel was moved into a different thread. To this -end all invocations of the handler are forwarded to the original -thread by posting special events to it. This means that the original -thread (i.e. the thread that executed the \fBchan create\fR command) -must have an active event loop, i.e. it must be able to process such -events. Otherwise the thread sending them will \fIblock -indefinitely\fR. Deadlock may occur. -.PP -Note that this permits the creation of a channel whose two endpoints -live in two different threads, providing a stream-oriented bridge -between these threads. In other words, we can provide a way for -regular stream communication between threads instead of having to send -commands. -.PP -When a thread or interpreter is deleted, all channels created with -this subcommand and using this thread/interpreter as their computing -base are deleted as well, in all interpreters they have been shared -with or moved into, and in whatever thread they have been transferred -to. While this pulls the rug out under the other thread(s) and/or -interpreter(s), this cannot be avoided. Trying to use such a channel -will cause the generation of a regular error about unknown channel -handles. -.PP -This subcommand is \fBsafe\fR and made accessible to safe -interpreters. While it arranges for the execution of arbitrary Tcl -code the system also makes sure that the code is always executed -within the safe interpreter. +.QW \fBwrite\fR +, indicating whether the channel is a read channel, a write channel, or both. +It is an error if the handler does not support the chosen mode. +.PP +The handler is called as needed from the global namespace at the top level, and +command resolution happens there at the time of the call. If the handler is +renamed or deleted any subsequent attempt to call it is an error, which may +not be able to describe the failure. +.PP +The handler is always called in the interpreter and thread it was created in, +even if the channel was shared with or moved into a different interpreter in a +different thread. This is achieved through event dispatch, so if the event +loop is not entered, e.g. by calling \fBTcl_DoOneEvent\fR or \fBvwait\fR or +using Tk, the thread performing the channel operation \fIblocks +indefinitely\fR, resulting in deadlock. +.PP +One side of a channel may be in one thread while the other side is in a +different thread, providing a stream-oriented bridge between the threads. This +provides a method for regular stream communication between threads as an +alternative to sending commands. +.PP +When the interpreter the handler is in is deleted each channel associated with +the handler is deleted as well, regardless of which interpreter or thread it +is currently in or shared with. +.PP +\fBchan create\fR is \fBsafe\fR and is accessible to safe interpreters. The +handler is always called in the safe interpreter it was created in. .RE .TP -\fBchan eof \fIchannelId\fR -. -Test whether the last input operation on the channel called -\fIchannelId\fR failed because the end of the data stream was reached, -returning 1 if end-of-file was reached, and 0 otherwise. -.TP -\fBchan event \fIchannelId event\fR ?\fIscript\fR? -. -Arrange for the Tcl script \fIscript\fR to be installed as a \fIfile -event handler\fR to be called whenever the channel called -\fIchannelId\fR enters the state described by \fIevent\fR (which must -be either \fBreadable\fR or \fBwritable\fR); only one such handler may -be installed per event per channel at a time. If \fIscript\fR is the -empty string, the current handler is deleted (this also happens if the -channel is closed or the interpreter deleted). If \fIscript\fR is -omitted, the currently installed script is returned (or an empty -string if no such handler is installed). The callback is only -performed if the event loop is being serviced (e.g. via \fBvwait\fR or -\fBupdate\fR). -.RS -.PP -A file event handler is a binding between a channel and a script, such -that the script is evaluated whenever the channel becomes readable or -writable. File event handlers are most commonly used to allow data to -be received from another process on an event-driven basis, so that the -receiver can continue to interact with the user or with other channels -while waiting for the data to arrive. If an application invokes -\fBchan gets\fR or \fBchan read\fR on a blocking channel when there is -no input data available, the process will block; until the input data -arrives, it will not be able to service other events, so it will -appear to the user to -.QW "freeze up" . -With \fBchan event\fR, the -process can tell when data is present and only invoke \fBchan gets\fR -or \fBchan read\fR when they will not block. -.PP -A channel is considered to be readable if there is unread data -available on the underlying device. A channel is also considered to -be readable if there is unread data in an input buffer, except in the -special case where the most recent attempt to read from the channel -was a \fBchan gets\fR call that could not find a complete line in the -input buffer. This feature allows a file to be read a line at a time -in non-blocking mode using events. A channel is also considered to be -readable if an end of file or error condition is present on the -underlying file or device. It is important for \fIscript\fR to check -for these conditions and handle them appropriately; for example, if -there is no special check for end of file, an infinite loop may occur -where \fIscript\fR reads no data, returns, and is immediately invoked -again. -.PP -A channel is considered to be writable if at least one byte of data -can be written to the underlying file or device without blocking, or -if an error condition is present on the underlying file or device. -Note that client sockets opened in asynchronous mode become writable -when they become connected or if the connection fails. -.PP -Event-driven I/O works best for channels that have been placed into -non-blocking mode with the \fBchan configure\fR command. In blocking -mode, a \fBchan puts\fR command may block if you give it more data -than the underlying file or device can accept, and a \fBchan gets\fR -or \fBchan read\fR command will block if you attempt to read more data -than is ready; no events will be processed while the commands block. -In non-blocking mode \fBchan puts\fR, \fBchan read\fR, and \fBchan -gets\fR never block. -.PP -The script for a file event is executed at global level (outside the -context of any Tcl procedure) in the interpreter in which the \fBchan -event\fR command was invoked. If an error occurs while executing the -script then the command registered with \fBinterp bgerror\fR is used -to report the error. In addition, the file event handler is deleted -if it ever returns an error; this is done in order to prevent infinite -loops due to buggy handlers. -.RE +\fBchan eof \fIchannelName\fR +. +Returns 1 if the last read on the channel failed because the end of the data +was already reached, and 0 otherwise. .TP -\fBchan flush \fIchannelId\fR +\fBchan event \fIchannelName event\fR ?\fIscript\fR? . -Ensures that all pending output for the channel called \fIchannelId\fR -is written. +Arranges for the given script, called a \fBchannel event hndler\fR, to be +called whenever the given event, one of +.QW \fBreadable\fR +or +.QW \fBwritable\fR +occurs on the given channel, replacing any script that was previously set. If +\fIscript\fR is the empty string the current handler is deleted. It is also +deleted when the channel is closed. If \fIscript\fR is omitted, either the +existing script or the empty string is returned. The event loop must be +entered, e.g. via \fBvwait\fR or \fBupdate\fR, or by using Tk, for handlers to +be evaluated. + .RS .PP -If the channel is in blocking mode the command does not return until -all the buffered output has been flushed to the channel. If the -channel is in non-blocking mode, the command may return before all -buffered output has been flushed; the remainder will be flushed in the -background as fast as the underlying file or device is able to absorb -it. +\fIscript\fR is evaluated at the global level in the interpreter it was +established in. Any resulting error is handled in the background, i.e. via +\fBinterp bgerror\fR. In order to prevent an endless loop due to a buggy +handler, the handler is deleted if \fIscript\fR returns an error so that it is +not evaluated again. + +.PP +Without an event handler, \fBchan gets\fR or \fBchan read\fR on a channel in +blocking mode may block until data becomes available, become during which the +thread is unable to perform other work or respond to events on other channels. +This could cause the application to appear to +.QW "freeze up" +\&. +Channel event handlers allow events on the channel to direct channel handling +so that the reader or writer can continue to perform other processing while +waiting for a channel to become available and then handle channel operations +when the channel is ready for the operation. +.PP +A +.QW readable +event occurs when there is data that can be read from the channel and also when +there is an error on the channel. The handler must check for these conditions +and handle them appropriately. For example, a handler that does not check +whether the end of the data has been reached may be repeatedly evaluated in a +busy loop until the channel is closed. +.PP +A +.QW writable +event occurs when at least one byte of data can be written, or if there is an +error on the channel. A client socket opened in non-blocking mode becomes +writable when it becomes connected or if the connection fails. +.PP +Event-driven channel handling works best for channels in non-blocking mode. A +channel in blocking mode blocks when \fBchan puts\fR writes more data than the +channel can accept at the moment, and when \fBchan gets\fR or \fBchan read\fR +requests more data than is currently available. When a channel blocks, the +thread can not do any other processing or service any other events. A channel +in non-blocking mode allows a thread to carry on with other work and get back +to the channel at the right time. .RE .TP -\fBchan gets \fIchannelId\fR ?\fIvarName\fR? -. -Reads the next line from the channel called \fIchannelId\fR. If -\fIvarName\fR is not specified, the result of the command will be the -line that has been read (without a trailing newline character) or an -empty string upon end-of-file or, in non-blocking mode, if the data -available is exhausted. If \fIvarName\fR is specified, the line that -has been read will be written to the variable called \fIvarName\fR and -result will be the number of characters that have been read or -1 if -end-of-file was reached or, in non-blocking mode, if the data -available is exhausted. +\fBchan flush \fIchannelName\fR +. +For a channel in blocking mode, flushes all buffered output to the destination, +and then returns. For a channel in non-blocking mode, returns immediately +while all buffered output is flushed in the background as soon as possible. +.TP +\fBchan gets \fIchannelName\fR ?\fIvarName\fR? +. +Returns the next line from the channel, removing the trailing line feed, or if +\fIvarName\fR is given, assigns the line to that variable and returns the +number of characters read. +the line that was read, removing the trailing line feed, or returns the +empty string if there is no data to return and the end of the file has been +reached, or in non-blocking mode, if no complete line is currently available. +If \fIvarName\fR is given, assigns the line that was read to variable named +\fIvarName\fR and returns the number of characters that were read, or -1 if +there no data available and the end of the channel was reached or the channel +is in non-blocking mode. .RS .PP -If an end-of-file occurs while part way through reading a line, the -partial line will be returned (or written into \fIvarName\fR). When -\fIvarName\fR is not specified, the end-of-file case can be -distinguished from an empty line using the \fBchan eof\fR command, and -the partial-line-but-non-blocking case can be distinguished with the -\fBchan blocked\fR command. +If the end of the channel is reached the data read so far is returned or +assigned to \fIvarName\fR. When \fIvarName\fR is not given, \fBchan eof\fR may +indicate that the empty string means that the end of the data has been reached, +and \fBchan blocked\fR may indicate that that the empty string means there +isn't currently enough data do return the next line. .RE .TP \fBchan names\fR ?\fIpattern\fR? . -Produces a list of all channel names. If \fIpattern\fR is specified, -only those channel names that match it (according to the rules of -\fBstring match\fR) will be returned. +Returns a list of all channel names, or if \fIpattern\fR is given, only those +names that match according to the rules of \fBstring match\fR. .TP -\fBchan pending \fImode channelId\fR +\fBchan pending \fImode channelName\fR . -Depending on whether \fImode\fR is \fBinput\fR or \fBoutput\fR, -returns the number of -bytes of input or output (respectively) currently buffered -internally for \fIchannelId\fR (especially useful in a readable event -callback to impose application-specific limits on input line lengths to avoid -a potential denial-of-service attack where a hostile user crafts -an extremely long line that exceeds the available memory to buffer it). -Returns -1 if the channel was not opened for the mode in question. +Returns the number of bytes of input +when \fImode\fR is +.QW\fBinput\fR +, or output when \fImode\fR is +.QW\fBoutput\fR +, that are currently internally buffered for the channel. Useful in a readable +event callback to impose limits on input line length to avoid a potential +denial-of-service attack where an extremely long line exceeds the available +memory to buffer it. Returns -1 if the channel was not opened for the mode in +question. .TP \fBchan pipe\fR -Creates a standalone pipe whose read- and write-side channels are -returned as a 2-element list, the first element being the read side and -the second the write side. Can be useful e.g. to redirect -separately \fBstderr\fR and \fBstdout\fR from a subprocess. To do -this, spawn with "2>@" or -">@" redirection operators onto the write side of a pipe, and then -immediately close it in the parent. This is necessary to get an EOF on -the read side once the child has exited or otherwise closed its output. +Creates a pipe, i.e. a readable channel and a writable channel, and returns the +names of the readable channel and the writable channel. Data written to the +writable channel can be read from the readable channel. Because the pipe is a +real system-level pipe, it can be connected to other processes using +redirection. For example, to redirect \fBstderr\fR from a subprocess into one +channel, and \fBstdout\fR into another, \fBexec\fR with "2>@" and ">@", each +onto the writable side of a pipe, closing the writable side immediately +thereafter so that EOF is signaled on the read side once the subprocess has +closed its output, typically on exit. .RS .PP -Note that the pipe buffering semantics can vary at the operating system level -substantially; it is not safe to assume that a write performed on the output -side of the pipe will appear instantly to the input side. This is a -fundamental difference and Tcl cannot conceal it. The overall stream semantics -\fIare\fR compatible, so blocking reads and writes will not see most of the -differences, but the details of what exactly gets written when are not. This -is most likely to show up when using pipelines for testing; care should be -taken to ensure that deadlocks do not occur and that potential short reads are -allowed for. +Due to buffering, data written to one side of a pipe might not immediately +become available on the other side. Tcl's own buffers can be configured via +\fBchan configure -buffering\fR, but overall behaviour still depends on +operating system buffers outside of Tcl's control. Once the write side of the +channel is closed, any data remaining in the buffers is flushed through to the +read side. It may be useful to arrange for the connected process to flush at +some point after writing to the channel or to have it use some system-provided +mechanism to configure buffering. When two pipes are connected to the same +process, one to send data to the process, and one to read data from the +process, a deadlock may occur if the channels are in blocking mode: If +reading, the channel may block waiting for data that can never come because +buffers are only flushed on subsequent writes, and if writing, the channel may +block while waiting for the buffers to become free, which can never happen +because the reader can not read while the writer is blocking. To avoid this +issue, either put the channels into non-blocking mode and use event handlers, +or place the read channel and the write channel in separate interpreters in +separate threads. .RE .TP -\fBchan pop \fIchannelId\fR -Removes the topmost transformation from the channel \fIchannelId\fR, if there -is any. If there are no transformations added to \fIchannelId\fR, this is -equivalent to \fBchan close\fR of that channel. The result is normally the -empty string, but can be an error in some situations (i.e. where the -underlying system stream is closed and that results in an error). -.TP -\fBchan postevent \fIchannelId eventSpec\fR -. -This subcommand is used by command handlers specified with \fBchan -create\fR. It notifies the channel represented by the handle -\fIchannelId\fR that the event(s) listed in the \fIeventSpec\fR have -occurred. The argument has to be a list containing any of the strings -\fBread\fR and \fBwrite\fR. The list must contain at least one -element as it does not make sense to invoke the command if there are -no events to post. +\fBchan pop \fIchannelName\fR +Removes the topmost transformation handler from the channel if there is one, +and closes the channel otherwise. The result is normally the empty string, but +may be an error in some situations, e.g. when closing the underlying resource +results in an error. +.TP +\fBchan postevent \fIchannelName eventSpec\fR +. +For use by handlers established with \fBchan create\fR. Notifies Tcl that +that one or more event(s) listed in \fIeventSpec\fR, each of which is either +.QW\fBread\fR +or +.QW\fBwrite\fR. +, have occurred. .RS .PP -Note that this subcommand can only be used with channel handles that -were created/opened by \fBchan create\fR. All other channels will -cause this subcommand to report an error. -.PP -As only the Tcl level of a channel, i.e. its command handler, should -post events to it we also restrict the usage of this command to the -interpreter that created the channel. In other words, posting events -to a reflected channel from an interpreter that does not contain it's -implementation is not allowed. Attempting to post an event from any -other interpreter will cause this subcommand to report an error. -.PP -Another restriction is that it is not possible to post events that the -I/O core has not registered an interest in. Trying to do so will cause -the method to throw an error. See the command handler method -\fBwatch\fR described in \fBrefchan\fR, the document specifying -the API of command handlers for reflected channels. -.PP -This command is \fBsafe\fR and made accessible to safe interpreters. -It can trigger the execution of \fBchan event\fR handlers, whether in the -current interpreter or in other interpreters or other threads, even -where the event is posted from a safe interpreter and listened for by -a trusted interpreter. \fBChan event\fR handlers are \fIalways\fR -executed in the interpreter that set them up. +For use only by handlers for a channel created by \fBchan create\fR. It is an +error to post an event for any other channel. +.PP +Since only the handler for a reflected channel channel should post events it is +an error to post an event from any interpreter other than the interpreter that +created the channel. +.PP +It is an error to post an event that the channel has no interest in. See +\fBwatch\fR in the \fBrefchan\fR documentation for more information +.PP +\fBchan postevent\fR is available in safe interpreters, as any handler for a +reflected channel would have been created, and will be evaluated in that +interpreter as well. .RE .TP -\fBchan push \fIchannelId cmdPrefix\fR -Adds a new transformation on top of the channel \fIchannelId\fR. The -\fIcmdPrefix\fR argument describes a list of one or more words which represent -a handler that will be used to implement the transformation. The command -prefix must provide the API described in the \fBtranschan\fR manual page. -The result of this subcommand is a handle to the transformation. Note that it -is important to make sure that the transformation is capable of supporting the -channel mode that it is used with or this can make the channel neither -readable nor writable. -.TP -\fBchan puts\fR ?\fB\-nonewline\fR? ?\fIchannelId\fR? \fIstring\fR -. -Writes \fIstring\fR to the channel named \fIchannelId\fR followed by a -newline character. A trailing newline character is written unless the -optional flag \fB\-nonewline\fR is given. If \fIchannelId\fR is -omitted, the string is written to the standard output channel, +\fBchan push \fIchannelName cmdPrefix\fR +Adds a new transformation handler on top of the channel and returns a handle +for the transformation. \fIcmdPrefix\fR is the first words of a command that +provides the interface documented for \fBtranschan\fR, and transforms data on +the channel, It is an error if handler does not support the mode(s) the channel +is in. +.TP +\fBchan puts\fR ?\fB\-nonewline\fR? ?\fIchannelName\fR? \fIstring\fR +. +Writes \fIstring\fR and a line feed to the channel. If \fB\-nonewline\fR is +given, the trailing line feed is not written. The default channel is \fBstdout\fR. .RS .PP -Newline characters in the output are translated by \fBchan puts\fR to -platform-specific end-of-line sequences according to the currently -configured value of the \fB\-translation\fR option for the channel -(for example, on PCs newlines are normally replaced with -carriage-return-linefeed sequences; see \fBchan configure\fR above for -details). -.PP -Tcl buffers output internally, so characters written with \fBchan -puts\fR may not appear immediately on the output file or device; Tcl -will normally delay output until the buffer is full or the channel is -closed. You can force output to appear immediately with the \fBchan -flush\fR command. -.PP -When the output buffer fills up, the \fBchan puts\fR command will -normally block until all the buffered data has been accepted for -output by the operating system. If \fIchannelId\fR is in non-blocking -mode then the \fBchan puts\fR command will not block even if the -operating system cannot accept the data. Instead, Tcl continues to -buffer the data and writes it in the background as fast as the -underlying file or device can accept it. The application must use the -Tcl event loop for non-blocking output to work; otherwise Tcl never -finds out that the file or device is ready for more output data. It -is possible for an arbitrarily large amount of data to be buffered for -a channel in non-blocking mode, which could consume a large amount of -memory. To avoid wasting memory, non-blocking I/O should normally be -used in an event-driven fashion with the \fBchan event\fR command -(do not invoke \fBchan puts\fR unless you have recently been notified -via a file event that the channel is ready for more output data). +Each line feed in the output is translated according to the configuration of +\fB\-translation\fR. +.PP +Because Tcl internally buffers output, characters written to a channel may not +immediately be available at the destination. Tcl normally delays output until +the buffer is full or the channel is closed. \fBchan flush\fR forces output in +the direction of the destination. +.PP +When the output for a channel in blocking mode fills up, \fBchan puts\fR blocks +until space in the buffer is available again, but for a channel in non-blocking +mode, it returns immediately and the data is written in the background as fast +possible, constrained by the speed at which as the destination accepts it. +Output to a channel in non-blocking mode only works properly when the +application enters the event loop, giving Tcl a chance to find out that the +destination is ready to accept more data. When a channel is in non-blocking +mode, Tcl's internal buffers can hold an arbitrary amount of data, possibly +consuming a large amount of memory. To avoid wasting memory, channels in +non-blocking mode should normally be handled using \fBchan event\fR, where the +application only invokes \fBchan puts\fR after being recently notified through +a file event handler that the channel is ready for more output data. .RE .TP -\fBchan read \fIchannelId\fR ?\fInumChars\fR? +\fBchan read \fIchannelName\fR ?\fInumChars\fR? .TP -\fBchan read \fR?\fB\-nonewline\fR? \fIchannelId\fR +\fBchan read \fR?\fB\-nonewline\fR? \fIchannelName\fR . -In the first form, the result will be the next \fInumChars\fR -characters read from the channel named \fIchannelId\fR; if -\fInumChars\fR is omitted, all characters up to the point when the -channel would signal a failure (whether an end-of-file, blocked or -other error condition) are read. In the second form (i.e. when -\fInumChars\fR has been omitted) the flag \fB\-nonewline\fR may be -given to indicate that any trailing newline in the string that has -been read should be trimmed. +Reads and returns the next \fInumChars\fR characters from the channel. If +\fInumChars\fR is omitted, all available characters up to the end of the file +are read, or if the channel is in non-blocking mode, all currently-available +characters are read. If there is an error on the channel, reading ceases and +an error is returned. If \fInumChars\fR is not given, \fB\-nonewline\fR +may be given, causing any any trailing line feed to be trimmed. .RS .PP -If \fIchannelId\fR is in non-blocking mode, \fBchan read\fR may not -read as many characters as requested: once all available input has -been read, the command will return the data that is available rather -than blocking for more input. If the channel is configured to use a -multi-byte encoding, then there may actually be some bytes remaining -in the internal buffers that do not form a complete character. These -bytes will not be returned until a complete character is available or -end-of-file is reached. The \fB\-nonewline\fR switch is ignored if -the command returns before reaching the end of the file. -.PP -\fBChan read\fR translates end-of-line sequences in the input into -newline characters according to the \fB\-translation\fR option for the -channel (see \fBchan configure\fR above for a discussion on the ways -in which \fBchan configure\fR will alter input). -.PP -When reading from a serial port, most applications should configure -the serial port channel to be non-blocking, like this: -.PP -.CS -\fBchan configure \fIchannelId \fB\-blocking \fI0\fR. -.CE -.PP -Then \fBchan read\fR behaves much like described above. Note that -most serial ports are comparatively slow; it is entirely possible to -get a \fBreadable\fR event for each character read from them. Care -must be taken when using \fBchan read\fR on blocking serial ports: -.TP -\fBchan read \fIchannelId numChars\fR -. -In this form \fBchan read\fR blocks until \fInumChars\fR have been -received from the serial port. -.TP -\fBchan read \fIchannelId\fR -. -In this form \fBchan read\fR blocks until the reception of the -end-of-file character, see \fBchan configure -eofchar\fR. If there no -end-of-file character has been configured for the channel, then -\fBchan read\fR will block forever. +If the channel is in non-blocking mode, fewer characters than requested may be +returned. If the channel is configured to use a multi-byte encoding, bytes +that do not form a complete character are retained in the buffers until enough +bytes to complete the character accumulate, or the end of the data is reached. +\fB\-nonewline\fR is ignored if characters are returned before reaching the end +of the file. +.PP +Each end-of-line sequence according to the value of \fB\-translation\fR is +translated into a line feed. +.PP +When reading from a serial port, most applications should configure the serial +port channel to be in non-blocking mode, but not necessarily use an event +handler since most serial ports are comparatively slow. It is entirely +possible to get a \fBreadable\fR event for each individual character. In +blocking mode, \fBchan read\fR blocks forever when reading to the end of the +data if there is no \fBchan configure -eofchar\fR configured for the channel. .RE .TP -\fBchan seek \fIchannelId offset\fR ?\fIorigin\fR? +\fBchan seek \fIchannelName offset\fR ?\fIorigin\fR? . -Sets the current access position within the underlying data stream for -the channel named \fIchannelId\fR to be \fIoffset\fR bytes relative to -\fIorigin\fR. \fIOffset\fR must be an integer (which may be negative) -and \fIorigin\fR must be one of the following: +Sets the current position for the data in the channel to integer \fIoffset\fR +bytes relative to \fIorigin\fR. A negative offset moves the current position +backwards from the origin. \fIorigin\fR is one of the +following: .RS +.PP .TP 10 \fBstart\fR . -The new access position will be \fIoffset\fR bytes from the start -of the underlying file or device. +The origin is the start of the data. This is the default. .TP 10 \fBcurrent\fR . -The new access position will be \fIoffset\fR bytes from the current -access position; a negative \fIoffset\fR moves the access position -backwards in the underlying file or device. +The origin is the current position. .TP 10 \fBend\fR . -The new access position will be \fIoffset\fR bytes from the end of the -file or device. A negative \fIoffset\fR places the access position -before the end of file, and a positive \fIoffset\fR places the access -position after the end of file. -.PP -The \fIorigin\fR argument defaults to \fBstart\fR. +The origin is the end of the data. .PP -\fBChan seek\fR flushes all buffered output for the channel before the -command returns, even if the channel is in non-blocking mode. It also -discards any buffered and unread input. This command returns an empty -string. An error occurs if this command is applied to channels whose -underlying file or device does not support seeking. +\fBChan seek\fR flushes all buffered output even if the channel is in +non-blocking mode, discards any buffered and unread input, and returns the +empty string or an error if the channel does not support seeking. .PP -Note that \fIoffset\fR values are byte offsets, not character offsets. -Both \fBchan seek\fR and \fBchan tell\fR operate in terms of bytes, -not characters, unlike \fBchan read\fR. +\fIoffset\fR values are byte offsets, not character offsets. Unlike \fBchan +read\fR, both \fBchan seek\fR and \fBchan tell\fR operate in terms of bytes, +not characters, .RE .TP -\fBchan tell \fIchannelId\fR +\fBchan tell \fIchannelName\fR . -Returns a number giving the current access position within the -underlying data stream for the channel named \fIchannelId\fR. This -value returned is a byte offset that can be passed to \fBchan seek\fR -in order to set the channel to a particular position. Note that this -value is in terms of bytes, not characters like \fBchan read\fR. The -value returned is -1 for channels that do not support seeking. +Returns the offset in bytes of the current position in the underlying data, or +-1 if the channel does not suport seeking. The value can be passed to \fBchan +seek\fR to set current position to that offset. .TP -\fBchan truncate \fIchannelId\fR ?\fIlength\fR? +\fBchan truncate \fIchannelName\fR ?\fIlength\fR? . -Sets the byte length of the underlying data stream for the channel -named \fIchannelId\fR to be \fIlength\fR (or to the current byte -offset within the underlying data stream if \fIlength\fR is -omitted). The channel is flushed before truncation. +Flushes the channel and truncates the data in the channel to \fIlength\fR +bytes, or to the current position in bytes if \fIlength\fR is omitted. . .SH EXAMPLES .PP -This opens a file using a known encoding (CP1252, a very common encoding -on Windows), searches for a string, rewrites that part, and truncates the -file after a further two lines. +In the following example a file is opened using the encoding CP1252, which is +common on Windows, searches for a string, rewrites that part, and truncates the +file two lines later. .PP .CS set f [open somefile.txt r+] @@ -793,12 +619,12 @@ while {[\fBchan gets\fR $f line] >= 0} { \fBchan close\fR $f .CE .PP -A network server that does echoing of its input line-by-line without -preventing servicing of other connections at the same time. +A network server that echoes its input line-by-line without +preventing servicing of other connections at the same time: .PP .CS # This is a very simple logger... -proc log {message} { +proc log message { \fBchan puts\fR stdout $message } -- cgit v0.12 From 511e85013ac111a96845721348abc019321ab15e Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Sun, 23 Jan 2022 16:21:42 +0000 Subject: eol-spacing from previous commit --- doc/chan.n | 14 +++++++------- 1 file changed, 7 insertions(+), 7 deletions(-) diff --git a/doc/chan.n b/doc/chan.n index aa8bbca..9589f98 100644 --- a/doc/chan.n +++ b/doc/chan.n @@ -113,7 +113,7 @@ connect to terminal-like devices, the default value is \fBline\fR. For \fB\-buffersize\fR \fInewSize\fR . \fInewSize\fR, an integer no greater than one million, is the size in bytes of -any input or output buffers subsequently allocated for this channel. +any input or output buffers subsequently allocated for this channel. .TP \fB\-encoding\fR ?\fIname\fR? . @@ -148,7 +148,7 @@ interface with the operating system, . \fIchar\fR signals the end of the data when it is encountered in the input. For output, the character is added when the channel is closed. If \fIchar\fR -is the empty string, there is no special character that marks the end of the +is the empty string, there is no special character that marks the end of the data. For read-write channels, one end-of-file character for input and another for output may be given. When only one end-of-file character is given it is applied to both input and output. For a read-write channel two values are @@ -279,14 +279,14 @@ first words of a command that provides the interface for a \fBrefchan\fR. \fBImode\fR is a list of one or more of the strings .QW \fBread\fR or -.QW \fBwrite\fR +.QW \fBwrite\fR , indicating whether the channel is a read channel, a write channel, or both. It is an error if the handler does not support the chosen mode. .PP The handler is called as needed from the global namespace at the top level, and command resolution happens there at the time of the call. If the handler is renamed or deleted any subsequent attempt to call it is an error, which may -not be able to describe the failure. +not be able to describe the failure. .PP The handler is always called in the interpreter and thread it was created in, even if the channel was shared with or moved into a different interpreter in a @@ -374,7 +374,7 @@ to the channel at the right time. . For a channel in blocking mode, flushes all buffered output to the destination, and then returns. For a channel in non-blocking mode, returns immediately -while all buffered output is flushed in the background as soon as possible. +while all buffered output is flushed in the background as soon as possible. .TP \fBchan gets \fIchannelName\fR ?\fIvarName\fR? . @@ -522,7 +522,7 @@ Reads and returns the next \fInumChars\fR characters from the channel. If are read, or if the channel is in non-blocking mode, all currently-available characters are read. If there is an error on the channel, reading ceases and an error is returned. If \fInumChars\fR is not given, \fB\-nonewline\fR -may be given, causing any any trailing line feed to be trimmed. +may be given, causing any any trailing line feed to be trimmed. .RS .PP If the channel is in non-blocking mode, fewer characters than requested may be @@ -562,7 +562,7 @@ The origin is the current position. .TP 10 \fBend\fR . -The origin is the end of the data. +The origin is the end of the data. .PP \fBChan seek\fR flushes all buffered output even if the channel is in non-blocking mode, discards any buffered and unread input, and returns the -- cgit v0.12 From ffb2eeb8d171ebccdb0ed6364f34a415afd2c98a Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Sun, 23 Jan 2022 21:56:09 +0000 Subject: Extend for Tcl lists > 2^31 elements (API only) --- generic/tcl.decls | 10 ++++++++++ generic/tclDecls.h | 23 +++++++++++++++++++++++ generic/tclStubInit.c | 23 +++++++++++++++++++++++ 3 files changed, 56 insertions(+) diff --git a/generic/tcl.decls b/generic/tcl.decls index bd9800a..249a361 100644 --- a/generic/tcl.decls +++ b/generic/tcl.decls @@ -2442,6 +2442,16 @@ declare 660 { int Tcl_AsyncMarkFromSignal(Tcl_AsyncHandler async, int sigNumber) } +# TIP #??? +declare 661 { + int TclListObjGetElements_(Tcl_Interp *interp, Tcl_Obj *listPtr, + size_t *objcPtr, Tcl_Obj ***objvPtr) +} +declare 662 { + int TclListObjLength_(Tcl_Interp *interp, Tcl_Obj *listPtr, + size_t *lengthPtr) +} + # ----- BASELINE -- FOR -- 8.7.0 ----- # ############################################################################## diff --git a/generic/tclDecls.h b/generic/tclDecls.h index 6ca7633..18f9ed7 100644 --- a/generic/tclDecls.h +++ b/generic/tclDecls.h @@ -1948,6 +1948,13 @@ EXTERN int Tcl_UniCharIsUnicode(int ch); /* 660 */ EXTERN int Tcl_AsyncMarkFromSignal(Tcl_AsyncHandler async, int sigNumber); +/* 661 */ +EXTERN int TclListObjGetElements_(Tcl_Interp *interp, + Tcl_Obj *listPtr, size_t *objcPtr, + Tcl_Obj ***objvPtr); +/* 662 */ +EXTERN int TclListObjLength_(Tcl_Interp *interp, + Tcl_Obj *listPtr, size_t *lengthPtr); typedef struct { const struct TclPlatStubs *tclPlatStubs; @@ -2644,6 +2651,8 @@ typedef struct TclStubs { void (*reserved658)(void); void (*reserved659)(void); int (*tcl_AsyncMarkFromSignal) (Tcl_AsyncHandler async, int sigNumber); /* 660 */ + int (*tclListObjGetElements_) (Tcl_Interp *interp, Tcl_Obj *listPtr, size_t *objcPtr, Tcl_Obj ***objvPtr); /* 661 */ + int (*tclListObjLength_) (Tcl_Interp *interp, Tcl_Obj *listPtr, size_t *lengthPtr); /* 662 */ } TclStubs; extern const TclStubs *tclStubsPtr; @@ -3994,6 +4003,10 @@ extern const TclStubs *tclStubsPtr; /* Slot 659 is reserved */ #define Tcl_AsyncMarkFromSignal \ (tclStubsPtr->tcl_AsyncMarkFromSignal) /* 660 */ +#define TclListObjGetElements_ \ + (tclStubsPtr->tclListObjGetElements_) /* 661 */ +#define TclListObjLength_ \ + (tclStubsPtr->tclListObjLength_) /* 662 */ #endif /* defined(USE_TCL_STUBS) */ @@ -4271,6 +4284,16 @@ extern const TclStubs *tclStubsPtr; # define Tcl_UtfToWChar (sizeof(wchar_t) != sizeof(short) \ ? (int (*)(const char *, wchar_t *))tclStubsPtr->tcl_UtfToChar16 \ : (int (*)(const char *, wchar_t *))Tcl_UtfToUniChar) +# undef Tcl_ListObjGetElements +#ifndef TCL_NO_DEPRECATED +# define Tcl_ListObjGetElements(interp, listPtr, objcPtr, objvPtr) (sizeof(*objcPtr) == sizeof(int) \ + ? tclStubsPtr->tcl_ListObjGetElements((interp), (listPtr), (int *)(void *)(objcPtr), (objvPtr)) \ + : tclStubsPtr->tclListObjGetElements_((interp), (listPtr), (size_t *)(void *)(objcPtr), (objvPtr))) +# undef Tcl_ListObjLength +# define Tcl_ListObjLength(interp, listPtr, lengthPtr) (sizeof(*lengthPtr) == sizeof(int) \ + ? tclStubsPtr->tcl_ListObjLength((interp), (listPtr), (int *)(void *)(lengthPtr)) \ + : tclStubsPtr->tclListObjLength_((interp), (listPtr), (size_t *)(void *)(lengthPtr))) +#endif /* TCL_NO_DEPRECATED */ #else # define Tcl_WCharToUtfDString (sizeof(wchar_t) != sizeof(short) \ ? (char *(*)(const wchar_t *, int, Tcl_DString *))Tcl_UniCharToUtfDString \ diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c index a1878c1..836eddc 100644 --- a/generic/tclStubInit.c +++ b/generic/tclStubInit.c @@ -123,6 +123,27 @@ static const char *TclUtfPrev(const char *src, const char *start) { return Tcl_UtfPrev(src, start); } +#define TclListObjGetElements_ LOGetElements +#define TclListObjLength_ LOLength +static int LOGetElements(Tcl_Interp *interp, Tcl_Obj *listPtr, + size_t *objcPtr, Tcl_Obj ***objvPtr) { + int n; + int result = Tcl_ListObjGetElements(interp, listPtr, &n, objvPtr); + if (objcPtr) { + *objcPtr = n; + } + return result; +} +static int LOLength(Tcl_Interp *interp, Tcl_Obj *listPtr, + size_t *lengthPtr) { + int n; + int result = Tcl_ListObjLength(interp, listPtr, &n); + if (lengthPtr) { + *lengthPtr = n; + } + return result; +} + #define TclBN_mp_add mp_add #define TclBN_mp_and mp_and #define TclBN_mp_clamp mp_clamp @@ -1944,6 +1965,8 @@ const TclStubs tclStubs = { 0, /* 658 */ 0, /* 659 */ Tcl_AsyncMarkFromSignal, /* 660 */ + TclListObjGetElements_, /* 661 */ + TclListObjLength_, /* 662 */ }; /* !END!: Do not edit above this line. */ -- cgit v0.12 From 53ba10085a9de8ab30a7372eba6bfc937ff07dc5 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 24 Jan 2022 08:18:17 +0000 Subject: TIP #616: Tcl lists > 2^31 elements. WIP --- doc/ListObj.3 | 12 +++--- generic/tcl.decls | 26 +++++++---- generic/tclAssembly.c | 2 +- generic/tclBasic.c | 14 +++--- generic/tclBinary.c | 4 +- generic/tclClock.c | 8 ++-- generic/tclCmdAH.c | 4 +- generic/tclCmdIL.c | 38 ++++++++-------- generic/tclCmdMZ.c | 26 +++++------ generic/tclCompCmds.c | 6 +-- generic/tclCompCmdsSZ.c | 12 +++--- generic/tclCompExpr.c | 4 +- generic/tclDecls.h | 61 ++++++++++++++++++-------- generic/tclDictObj.c | 18 ++++---- generic/tclDisassemble.c | 2 +- generic/tclEncoding.c | 12 +++--- generic/tclEnsemble.c | 38 ++++++++-------- generic/tclEvent.c | 2 +- generic/tclExecute.c | 38 ++++++++-------- generic/tclFCmd.c | 2 +- generic/tclFileName.c | 18 ++++---- generic/tclIO.c | 2 +- generic/tclIOGT.c | 2 +- generic/tclIORChan.c | 10 ++--- generic/tclIORTrans.c | 6 +-- generic/tclIOUtil.c | 12 +++--- generic/tclIndexObj.c | 10 ++--- generic/tclInt.h | 6 +-- generic/tclInterp.c | 6 +-- generic/tclLink.c | 2 +- generic/tclListObj.c | 107 ++++++++++++++++++---------------------------- generic/tclNamesp.c | 8 ++-- generic/tclOODefineCmds.c | 16 +++---- generic/tclOOMethod.c | 10 ++--- generic/tclObj.c | 2 +- generic/tclPathObj.c | 6 +-- generic/tclPkg.c | 4 +- generic/tclProc.c | 8 ++-- generic/tclProcess.c | 4 +- generic/tclResult.c | 10 ++--- generic/tclStrToD.c | 2 +- generic/tclStringObj.c | 4 +- generic/tclStubInit.c | 24 ++++++++++- generic/tclTest.c | 8 ++-- generic/tclTrace.c | 10 ++--- generic/tclUtil.c | 2 +- generic/tclVar.c | 12 +++--- generic/tclZipfs.c | 2 +- generic/tclZlib.c | 8 ++-- win/tclWinDde.c | 3 +- win/tclWinReg.c | 2 +- 51 files changed, 343 insertions(+), 312 deletions(-) diff --git a/doc/ListObj.3 b/doc/ListObj.3 index 67721c9..948be49 100644 --- a/doc/ListObj.3 +++ b/doc/ListObj.3 @@ -59,13 +59,13 @@ points to the Tcl value that will be appended to \fIlistPtr\fR. For \fBTcl_SetListObj\fR, this points to the Tcl value that will be converted to a list value containing the \fIobjc\fR elements of the array referenced by \fIobjv\fR. -.AP int *objcPtr in +.AP int|size_t *objcPtr in Points to location where \fBTcl_ListObjGetElements\fR stores the number of element values in \fIlistPtr\fR. .AP Tcl_Obj ***objvPtr out A location where \fBTcl_ListObjGetElements\fR stores a pointer to an array of pointers to the element values of \fIlistPtr\fR. -.AP int objc in +.AP size_t objc in The number of Tcl values that \fBTcl_NewListObj\fR will insert into a new list value, and \fBTcl_ListObjReplace\fR will insert into \fIlistPtr\fR. @@ -76,21 +76,21 @@ An array of pointers to values. \fBTcl_NewListObj\fR will insert these values into a new list value and \fBTcl_ListObjReplace\fR will insert them into an existing \fIlistPtr\fR. Each value will become a separate list element. -.AP int *intPtr out +.AP int|size_t *intPtr out Points to location where \fBTcl_ListObjLength\fR stores the length of the list. -.AP int index in +.AP size_t index in Index of the list element that \fBTcl_ListObjIndex\fR is to return. The first element has index 0. .AP Tcl_Obj **objPtrPtr out Points to place where \fBTcl_ListObjIndex\fR is to store a pointer to the resulting list element value. -.AP int first in +.AP size_t first in Index of the starting list element that \fBTcl_ListObjReplace\fR is to replace. The list's first element has index 0. -.AP int count in +.AP size_t count in The number of elements that \fBTcl_ListObjReplace\fR is to replace. .BE diff --git a/generic/tcl.decls b/generic/tcl.decls index 40598e9..033d506 100644 --- a/generic/tcl.decls +++ b/generic/tcl.decls @@ -117,7 +117,7 @@ declare 24 { int line) } declare 25 { - Tcl_Obj *Tcl_DbNewListObj(int objc, Tcl_Obj *const *objv, + Tcl_Obj *Tcl_DbNewListObj(size_t objc, Tcl_Obj *const *objv, const char *file, int line) } # Removed in 9.0 (changed to macro): @@ -186,20 +186,20 @@ declare 44 { Tcl_Obj *objPtr) } declare 45 { - int Tcl_ListObjGetElements(Tcl_Interp *interp, Tcl_Obj *listPtr, + int TclListObjGetElements_(Tcl_Interp *interp, Tcl_Obj *listPtr, int *objcPtr, Tcl_Obj ***objvPtr) } declare 46 { - int Tcl_ListObjIndex(Tcl_Interp *interp, Tcl_Obj *listPtr, int index, + int Tcl_ListObjIndex(Tcl_Interp *interp, Tcl_Obj *listPtr, size_t index, Tcl_Obj **objPtrPtr) } declare 47 { - int Tcl_ListObjLength(Tcl_Interp *interp, Tcl_Obj *listPtr, + int TclListObjLength_(Tcl_Interp *interp, Tcl_Obj *listPtr, int *lengthPtr) } declare 48 { - int Tcl_ListObjReplace(Tcl_Interp *interp, Tcl_Obj *listPtr, int first, - int count, int objc, Tcl_Obj *const objv[]) + int Tcl_ListObjReplace(Tcl_Interp *interp, Tcl_Obj *listPtr, size_t first, + size_t count, size_t objc, Tcl_Obj *const objv[]) } # Removed in 9.0 (changed to macro): #declare 49 { @@ -216,7 +216,7 @@ declare 51 { # Tcl_Obj *Tcl_NewIntObj(int intValue) #} declare 53 { - Tcl_Obj *Tcl_NewListObj(int objc, Tcl_Obj *const objv[]) + Tcl_Obj *Tcl_NewListObj(size_t objc, Tcl_Obj *const objv[]) } # Removed in 9.0 (changed to macro): #declare 54 { @@ -247,7 +247,7 @@ declare 60 { # void Tcl_SetIntObj(Tcl_Obj *objPtr, int intValue) #} declare 62 { - void Tcl_SetListObj(Tcl_Obj *objPtr, int objc, Tcl_Obj *const objv[]) + void Tcl_SetListObj(Tcl_Obj *objPtr, size_t objc, Tcl_Obj *const objv[]) } # Removed in 9.0 (changed to macro): #declare 63 { @@ -2505,6 +2505,16 @@ declare 660 { int Tcl_AsyncMarkFromSignal(Tcl_AsyncHandler async, int sigNumber) } +# TIP #??? +declare 661 { + int Tcl_ListObjGetElements(Tcl_Interp *interp, Tcl_Obj *listPtr, + size_t *objcPtr, Tcl_Obj ***objvPtr) +} +declare 662 { + int Tcl_ListObjLength(Tcl_Interp *interp, Tcl_Obj *listPtr, + size_t *lengthPtr) +} + # ----- BASELINE -- FOR -- 8.7.0 ----- # ############################################################################## diff --git a/generic/tclAssembly.c b/generic/tclAssembly.c index 8a95acc..8061f92 100644 --- a/generic/tclAssembly.c +++ b/generic/tclAssembly.c @@ -1983,7 +1983,7 @@ CreateMirrorJumpTable( * table. */ int i; - if (Tcl_ListObjGetElements(interp, jumps, &objc, &objv) != TCL_OK) { + if (TclListObjGetElements_(interp, jumps, &objc, &objv) != TCL_OK) { return TCL_ERROR; } if (objc % 2 != 0) { diff --git a/generic/tclBasic.c b/generic/tclBasic.c index 9b6df4f..e7380d9 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -4714,7 +4714,7 @@ TEOV_NotFound( * itself. */ - Tcl_ListObjGetElements(NULL, currNsPtr->unknownHandlerPtr, + TclListObjGetElements_(NULL, currNsPtr->unknownHandlerPtr, &handlerObjc, &handlerObjv); newObjc = objc + handlerObjc; newObjv = (Tcl_Obj **)TclStackAlloc(interp, sizeof(Tcl_Obj *) * newObjc); @@ -5222,7 +5222,7 @@ TclEvalEx( if (tokenPtr->type == TCL_TOKEN_EXPAND_WORD) { int numElements; - code = TclListObjLength(interp, objv[objectsUsed], + code = TclListObjLength_(interp, objv[objectsUsed], &numElements); if (code == TCL_ERROR) { /* @@ -5274,7 +5274,7 @@ TclEvalEx( int numElements; Tcl_Obj **elements, *temp = copy[wordIdx]; - Tcl_ListObjGetElements(NULL, temp, &numElements, + TclListObjGetElements_(NULL, temp, &numElements, &elements); objectsUsed += numElements; while (numElements--) { @@ -6037,7 +6037,7 @@ TclNREvalObjEx( TclNRAddCallback(interp, TEOEx_ListCallback, listPtr, eoFramePtr, objPtr, NULL); - TclListObjGetElements(NULL, listPtr, &objc, &objv); + TclListObjGetElements_(NULL, listPtr, &objc, &objv); return TclNREvalObjv(interp, objc, objv, flags, NULL); } @@ -8640,7 +8640,7 @@ TclNRTailcallEval( int objc; Tcl_Obj **objv; - Tcl_ListObjGetElements(interp, listPtr, &objc, &objv); + TclListObjGetElements_(interp, listPtr, &objc, &objv); nsObjPtr = objv[0]; if (result == TCL_OK) { @@ -9070,7 +9070,7 @@ TclNREvalList( TclMarkTailcall(interp); TclNRAddCallback(interp, TclNRReleaseValues, listPtr, NULL, NULL,NULL); - TclListObjGetElements(NULL, listPtr, &objc, &objv); + TclListObjGetElements_(NULL, listPtr, &objc, &objv); return TclNREvalObjv(interp, objc, objv, 0, NULL); } @@ -9358,7 +9358,7 @@ InjectHandler( TclMarkTailcall(interp); TclNRAddCallback(interp, InjectHandlerPostCall, corPtr, listPtr, INT2PTR(nargs), isProbe); - TclListObjGetElements(NULL, listPtr, &objc, &objv); + TclListObjGetElements_(NULL, listPtr, &objc, &objv); return TclNREvalObjv(interp, objc, objv, 0, NULL); } diff --git a/generic/tclBinary.c b/generic/tclBinary.c index c93494e..e310960 100644 --- a/generic/tclBinary.c +++ b/generic/tclBinary.c @@ -1013,7 +1013,7 @@ BinaryFormatCmd( * The macro evals its args more than once: avoid arg++ */ - if (TclListObjGetElements(interp, objv[arg], &listc, + if (TclListObjGetElements_(interp, objv[arg], &listc, &listv) != TCL_OK) { return TCL_ERROR; } @@ -1297,7 +1297,7 @@ BinaryFormatCmd( listc = 1; count = 1; } else { - TclListObjGetElements(interp, objv[arg], &listc, &listv); + TclListObjGetElements_(interp, objv[arg], &listc, &listv); if (count == BINARY_ALL) { count = listc; } diff --git a/generic/tclClock.c b/generic/tclClock.c index 620a9d2..f2b6f86 100644 --- a/generic/tclClock.c +++ b/generic/tclClock.c @@ -754,7 +754,7 @@ ConvertLocalToUTC( * Unpack the tz data. */ - if (TclListObjGetElements(interp, tzdata, &rowc, &rowv) != TCL_OK) { + if (TclListObjGetElements_(interp, tzdata, &rowc, &rowv) != TCL_OK) { return TCL_ERROR; } @@ -819,7 +819,7 @@ ConvertLocalToUTCUsingTable( while (!found) { row = LookupLastTransition(interp, fields->seconds, rowc, rowv); if ((row == NULL) - || TclListObjGetElements(interp, row, &cellc, + || TclListObjGetElements_(interp, row, &cellc, &cellv) != TCL_OK || TclGetIntFromObj(interp, cellv[1], &fields->tzOffset) != TCL_OK) { @@ -957,7 +957,7 @@ ConvertUTCToLocal( * Unpack the tz data. */ - if (TclListObjGetElements(interp, tzdata, &rowc, &rowv) != TCL_OK) { + if (TclListObjGetElements_(interp, tzdata, &rowc, &rowv) != TCL_OK) { return TCL_ERROR; } @@ -1009,7 +1009,7 @@ ConvertUTCToLocalUsingTable( row = LookupLastTransition(interp, fields->seconds, rowc, rowv); if (row == NULL || - TclListObjGetElements(interp, row, &cellc, &cellv) != TCL_OK || + TclListObjGetElements_(interp, row, &cellc, &cellv) != TCL_OK || TclGetIntFromObj(interp, cellv[1], &fields->tzOffset) != TCL_OK) { return TCL_ERROR; } diff --git a/generic/tclCmdAH.c b/generic/tclCmdAH.c index 9bab9bf..5f4729c 100644 --- a/generic/tclCmdAH.c +++ b/generic/tclCmdAH.c @@ -2533,7 +2533,7 @@ EachloopCmd( result = TCL_ERROR; goto done; } - TclListObjGetElements(NULL, statePtr->vCopyList[i], + TclListObjGetElements_(NULL, statePtr->vCopyList[i], &statePtr->varcList[i], &statePtr->varvList[i]); if (statePtr->varcList[i] < 1) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( @@ -2551,7 +2551,7 @@ EachloopCmd( result = TCL_ERROR; goto done; } - TclListObjGetElements(NULL, statePtr->aCopyList[i], + TclListObjGetElements_(NULL, statePtr->aCopyList[i], &statePtr->argcList[i], &statePtr->argvList[i]); j = statePtr->argcList[i] / statePtr->varcList[i]; diff --git a/generic/tclCmdIL.c b/generic/tclCmdIL.c index 4eff6f5..8cb6b08 100644 --- a/generic/tclCmdIL.c +++ b/generic/tclCmdIL.c @@ -2194,7 +2194,7 @@ Tcl_JoinObjCmd( * pointer to its array of element pointers. */ - if (TclListObjGetElements(interp, objv[1], &listLen, + if (TclListObjGetElements_(interp, objv[1], &listLen, &elemPtrs) != TCL_OK) { return TCL_ERROR; } @@ -2281,7 +2281,7 @@ Tcl_LassignObjCmd( return TCL_ERROR; } - TclListObjGetElements(NULL, listCopyPtr, &listObjc, &listObjv); + TclListObjGetElements_(NULL, listCopyPtr, &listObjc, &listObjv); objc -= 2; objv += 2; @@ -2407,7 +2407,7 @@ Tcl_LinsertObjCmd( return TCL_ERROR; } - result = TclListObjLength(interp, objv[1], &len); + result = TclListObjLength_(interp, objv[1], &len); if (result != TCL_OK) { return result; } @@ -2525,7 +2525,7 @@ Tcl_LlengthObjCmd( return TCL_ERROR; } - result = TclListObjLength(interp, objv[1], &listLen); + result = TclListObjLength_(interp, objv[1], &listLen); if (result != TCL_OK) { return result; } @@ -2578,7 +2578,7 @@ Tcl_LpopObjCmd( return TCL_ERROR; } - result = TclListObjGetElements(interp, listPtr, &listLen, &elemPtrs); + result = TclListObjGetElements_(interp, listPtr, &listLen, &elemPtrs); if (result != TCL_OK) { return result; } @@ -2673,7 +2673,7 @@ Tcl_LrangeObjCmd( return TCL_ERROR; } - result = TclListObjLength(interp, objv[1], &listLen); + result = TclListObjLength_(interp, objv[1], &listLen); if (result != TCL_OK) { return result; } @@ -2747,7 +2747,7 @@ Tcl_LremoveObjCmd( } listObj = objv[1]; - if (TclListObjLength(interp, listObj, &listLen) != TCL_OK) { + if (TclListObjLength_(interp, listObj, &listLen) != TCL_OK) { return TCL_ERROR; } @@ -2971,7 +2971,7 @@ Tcl_LreplaceObjCmd( return TCL_ERROR; } - result = TclListObjLength(interp, objv[1], &listLen); + result = TclListObjLength_(interp, objv[1], &listLen); if (result != TCL_OK) { return result; } @@ -3069,7 +3069,7 @@ Tcl_LreverseObjCmd( Tcl_WrongNumArgs(interp, 1, objv, "list"); return TCL_ERROR; } - if (TclListObjGetElements(interp, objv[1], &elemc, &elemv) != TCL_OK) { + if (TclListObjGetElements_(interp, objv[1], &elemc, &elemv) != TCL_OK) { return TCL_ERROR; } @@ -3341,7 +3341,7 @@ Tcl_LsearchObjCmd( */ i++; - if (TclListObjGetElements(interp, objv[i], + if (TclListObjGetElements_(interp, objv[i], &sortInfo.indexc, &indices) != TCL_OK) { result = TCL_ERROR; goto done; @@ -3447,7 +3447,7 @@ Tcl_LsearchObjCmd( * pointer to its array of element pointers. */ - result = TclListObjGetElements(interp, objv[objc - 2], &listc, &listv); + result = TclListObjGetElements_(interp, objv[objc - 2], &listc, &listv); if (result != TCL_OK) { goto done; } @@ -3552,7 +3552,7 @@ Tcl_LsearchObjCmd( * 1844789] */ - TclListObjGetElements(NULL, objv[objc - 2], &listc, &listv); + TclListObjGetElements_(NULL, objv[objc - 2], &listc, &listv); break; case REAL: result = Tcl_GetDoubleFromObj(interp, patObj, &patDouble); @@ -3565,7 +3565,7 @@ Tcl_LsearchObjCmd( * 1844789] */ - TclListObjGetElements(NULL, objv[objc - 2], &listc, &listv); + TclListObjGetElements_(NULL, objv[objc - 2], &listc, &listv); break; } } else { @@ -4080,7 +4080,7 @@ Tcl_LsortObjCmd( sortInfo.resultCode = TCL_ERROR; goto done; } - if (TclListObjGetElements(interp, objv[i+1], &sortindex, + if (TclListObjGetElements_(interp, objv[i+1], &sortindex, &indexv) != TCL_OK) { sortInfo.resultCode = TCL_ERROR; goto done; @@ -4173,7 +4173,7 @@ Tcl_LsortObjCmd( if (indexPtr) { Tcl_Obj **indexv; - TclListObjGetElements(interp, indexPtr, &sortInfo.indexc, &indexv); + TclListObjGetElements_(interp, indexPtr, &sortInfo.indexc, &indexv); switch (sortInfo.indexc) { case 0: sortInfo.indexv = NULL; @@ -4233,7 +4233,7 @@ Tcl_LsortObjCmd( sortInfo.compareCmdPtr = newCommandPtr; } - sortInfo.resultCode = TclListObjGetElements(interp, listObj, + sortInfo.resultCode = TclListObjGetElements_(interp, listObj, &length, &listObjPtrs); if (sortInfo.resultCode != TCL_OK || length <= 0) { goto done; @@ -4650,10 +4650,10 @@ SortCompare( * Replace them and evaluate the result. */ - TclListObjLength(infoPtr->interp, infoPtr->compareCmdPtr, &objc); + TclListObjLength_(infoPtr->interp, infoPtr->compareCmdPtr, &objc); Tcl_ListObjReplace(infoPtr->interp, infoPtr->compareCmdPtr, objc - 2, 2, 2, paramObjv); - TclListObjGetElements(infoPtr->interp, infoPtr->compareCmdPtr, + TclListObjGetElements_(infoPtr->interp, infoPtr->compareCmdPtr, &objc, &objv); infoPtr->resultCode = Tcl_EvalObjv(infoPtr->interp, objc, objv, 0); @@ -4863,7 +4863,7 @@ SelectObjFromSublist( int listLen, index; Tcl_Obj *currentObj; - if (TclListObjLength(infoPtr->interp, objPtr, &listLen) != TCL_OK) { + if (TclListObjLength_(infoPtr->interp, objPtr, &listLen) != TCL_OK) { infoPtr->resultCode = TCL_ERROR; return NULL; } diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c index 92b419d..bff2998 100644 --- a/generic/tclCmdMZ.c +++ b/generic/tclCmdMZ.c @@ -675,7 +675,7 @@ Tcl_RegsubObjCmd( * object. (If they aren't, that's cheap to do.) */ - if (Tcl_ListObjLength(interp, objv[2], &numParts) != TCL_OK) { + if (TclListObjLength_(interp, objv[2], &numParts) != TCL_OK) { return TCL_ERROR; } if (numParts < 1) { @@ -777,7 +777,7 @@ Tcl_RegsubObjCmd( Tcl_Obj **args = NULL, **parts; int numArgs; - Tcl_ListObjGetElements(interp, subPtr, &numParts, &parts); + TclListObjGetElements_(interp, subPtr, &numParts, &parts); numArgs = numParts + info.nsubs + 1; args = (Tcl_Obj **)Tcl_Alloc(sizeof(Tcl_Obj*) * numArgs); memcpy(args, parts, sizeof(Tcl_Obj*) * numParts); @@ -1813,7 +1813,7 @@ StringIsCmd( * well-formed lists. */ - if (TCL_OK == TclListObjLength(NULL, objPtr, &length3)) { + if (TCL_OK == TclListObjLength_(NULL, objPtr, &length3)) { break; } @@ -2029,7 +2029,7 @@ StringMapCmd( Tcl_DictObjDone(&search); } else { int i; - if (TclListObjGetElements(interp, objv[objc-2], &i, + if (TclListObjGetElements_(interp, objv[objc-2], &i, &mapElemv) != TCL_OK) { return TCL_ERROR; } @@ -3578,7 +3578,7 @@ TclNRSwitchObjCmd( Tcl_Obj **listv; blist = objv[0]; - if (TclListObjGetElements(interp, objv[0], &objc, &listv) != TCL_OK) { + if (TclListObjGetElements_(interp, objv[0], &objc, &listv) != TCL_OK) { return TCL_ERROR; } @@ -3963,7 +3963,7 @@ Tcl_ThrowObjCmd( * The type must be a list of at least length 1. */ - if (Tcl_ListObjLength(interp, objv[1], &len) != TCL_OK) { + if (TclListObjLength_(interp, objv[1], &len) != TCL_OK) { return TCL_ERROR; } else if (len < 1) { Tcl_SetObjResult(interp, Tcl_NewStringObj( @@ -4751,7 +4751,7 @@ TclNRTryObjCmd( return TCL_ERROR; } code = 1; - if (Tcl_ListObjLength(NULL, objv[i+1], &dummy) != TCL_OK) { + if (TclListObjLength_(NULL, objv[i+1], &dummy) != TCL_OK) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "bad prefix '%s': must be a list", TclGetString(objv[i+1]))); @@ -4763,7 +4763,7 @@ TclNRTryObjCmd( info[2] = objv[i+1]; commonHandler: - if (Tcl_ListObjLength(interp, objv[i+2], &dummy) != TCL_OK) { + if (TclListObjLength_(interp, objv[i+2], &dummy) != TCL_OK) { Tcl_DecrRefCount(handlersObj); return TCL_ERROR; } @@ -4913,12 +4913,12 @@ TryPostBody( int found = 0; Tcl_Obj **handlers, **info; - Tcl_ListObjGetElements(NULL, handlersObj, &numHandlers, &handlers); + TclListObjGetElements_(NULL, handlersObj, &numHandlers, &handlers); for (i=0 ; i 0) { Tcl_Obj *varName; diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c index 5f161af..15f7ec7 100644 --- a/generic/tclCompCmds.c +++ b/generic/tclCompCmds.c @@ -301,7 +301,7 @@ TclCompileArraySetCmd( TclNewObj(literalObj); isDataLiteral = TclWordKnownAtCompileTime(dataTokenPtr, literalObj); isDataValid = (isDataLiteral - && Tcl_ListObjLength(NULL, literalObj, &len) == TCL_OK); + && TclListObjLength_(NULL, literalObj, &len) == TCL_OK); isDataEven = (isDataValid && (len & 1) == 0); /* @@ -893,7 +893,7 @@ TclCompileConcatCmd( int len; size_t slen; - Tcl_ListObjGetElements(NULL, listObj, &len, &objs); + TclListObjGetElements_(NULL, listObj, &len, &objs); objPtr = Tcl_ConcatObj(len, objs); Tcl_DecrRefCount(listObj); bytes = Tcl_GetStringFromObj(objPtr, &slen); @@ -2753,7 +2753,7 @@ CompileEachloopCmd( */ if (!TclWordKnownAtCompileTime(tokenPtr, varListObj) || - TCL_OK != Tcl_ListObjLength(NULL, varListObj, &numVars) || + TCL_OK != TclListObjLength_(NULL, varListObj, &numVars) || numVars == 0) { code = TCL_ERROR; goto done; diff --git a/generic/tclCompCmdsSZ.c b/generic/tclCompCmdsSZ.c index be7789c..960e85a 100644 --- a/generic/tclCompCmdsSZ.c +++ b/generic/tclCompCmdsSZ.c @@ -940,7 +940,7 @@ TclCompileStringMapCmd( if (!TclWordKnownAtCompileTime(mapTokenPtr, mapObj)) { Tcl_DecrRefCount(mapObj); return TclCompileBasic2ArgCmd(interp, parsePtr, cmdPtr, envPtr); - } else if (Tcl_ListObjGetElements(NULL, mapObj, &len, &objv) != TCL_OK) { + } else if (TclListObjGetElements_(NULL, mapObj, &len, &objv) != TCL_OK) { Tcl_DecrRefCount(mapObj); return TclCompileBasic2ArgCmd(interp, parsePtr, cmdPtr, envPtr); } else if (len != 2) { @@ -2735,7 +2735,7 @@ TclCompileThrowCmd( CompileWord(envPtr, msgToken, interp, 2); codeIsList = codeKnown && (TCL_OK == - Tcl_ListObjLength(interp, objPtr, &len)); + TclListObjLength_(interp, objPtr, &len)); codeIsValid = codeIsList && (len != 0); if (codeIsValid) { @@ -2868,7 +2868,7 @@ TclCompileTryCmd( TclNewObj(tmpObj); Tcl_IncrRefCount(tmpObj); if (!TclWordKnownAtCompileTime(tokenPtr, tmpObj) - || Tcl_ListObjLength(NULL, tmpObj, &objc) != TCL_OK + || TclListObjLength_(NULL, tmpObj, &objc) != TCL_OK || (objc == 0)) { TclDecrRefCount(tmpObj); goto failedToCompile; @@ -2911,7 +2911,7 @@ TclCompileTryCmd( TclDecrRefCount(tmpObj); goto failedToCompile; } - if (Tcl_ListObjGetElements(NULL, tmpObj, &objc, &objv) != TCL_OK + if (TclListObjGetElements_(NULL, tmpObj, &objc, &objv) != TCL_OK || (objc > 2)) { TclDecrRefCount(tmpObj); goto failedToCompile; @@ -3123,7 +3123,7 @@ IssueTryClausesInstructions( JUMP4( JUMP_FALSE, notCodeJumpSource); if (matchClauses[i]) { const char *p; - Tcl_ListObjLength(NULL, matchClauses[i], &len); + TclListObjLength_(NULL, matchClauses[i], &len); /* * Match the errorcode according to try/trap rules. @@ -3335,7 +3335,7 @@ IssueTryClausesFinallyInstructions( OP( EQ); JUMP4( JUMP_FALSE, notCodeJumpSource); if (matchClauses[i]) { - Tcl_ListObjLength(NULL, matchClauses[i], &len); + TclListObjLength_(NULL, matchClauses[i], &len); /* * Match the errorcode according to try/trap rules. diff --git a/generic/tclCompExpr.c b/generic/tclCompExpr.c index d58dd24..7be349b 100644 --- a/generic/tclCompExpr.c +++ b/generic/tclCompExpr.c @@ -2226,8 +2226,8 @@ TclCompileExpr( TclAdvanceLines(&envPtr->line, script, script + TclParseAllWhiteSpace(script, numBytes)); - TclListObjGetElements(NULL, litList, &objc, (Tcl_Obj ***)&litObjv); - TclListObjGetElements(NULL, funcList, &objc, &funcObjv); + TclListObjGetElements_(NULL, litList, &objc, (Tcl_Obj ***)&litObjv); + TclListObjGetElements_(NULL, funcList, &objc, &funcObjv); CompileExprTree(interp, opTree, 0, &litObjv, funcObjv, parsePtr->tokenPtr, envPtr, optimize); } else { diff --git a/generic/tclDecls.h b/generic/tclDecls.h index 503823e..b7d88df 100644 --- a/generic/tclDecls.h +++ b/generic/tclDecls.h @@ -113,7 +113,7 @@ EXTERN Tcl_Obj * Tcl_DbNewByteArrayObj(const unsigned char *bytes, EXTERN Tcl_Obj * Tcl_DbNewDoubleObj(double doubleValue, const char *file, int line); /* 25 */ -EXTERN Tcl_Obj * Tcl_DbNewListObj(int objc, Tcl_Obj *const *objv, +EXTERN Tcl_Obj * Tcl_DbNewListObj(size_t objc, Tcl_Obj *const *objv, const char *file, int line); /* Slot 26 is reserved */ /* 27 */ @@ -163,20 +163,20 @@ EXTERN int Tcl_ListObjAppendList(Tcl_Interp *interp, EXTERN int Tcl_ListObjAppendElement(Tcl_Interp *interp, Tcl_Obj *listPtr, Tcl_Obj *objPtr); /* 45 */ -EXTERN int Tcl_ListObjGetElements(Tcl_Interp *interp, +EXTERN int TclListObjGetElements_(Tcl_Interp *interp, Tcl_Obj *listPtr, int *objcPtr, Tcl_Obj ***objvPtr); /* 46 */ EXTERN int Tcl_ListObjIndex(Tcl_Interp *interp, - Tcl_Obj *listPtr, int index, + Tcl_Obj *listPtr, size_t index, Tcl_Obj **objPtrPtr); /* 47 */ -EXTERN int Tcl_ListObjLength(Tcl_Interp *interp, +EXTERN int TclListObjLength_(Tcl_Interp *interp, Tcl_Obj *listPtr, int *lengthPtr); /* 48 */ EXTERN int Tcl_ListObjReplace(Tcl_Interp *interp, - Tcl_Obj *listPtr, int first, int count, - int objc, Tcl_Obj *const objv[]); + Tcl_Obj *listPtr, size_t first, size_t count, + size_t objc, Tcl_Obj *const objv[]); /* Slot 49 is reserved */ /* 50 */ EXTERN Tcl_Obj * Tcl_NewByteArrayObj(const unsigned char *bytes, @@ -185,7 +185,7 @@ EXTERN Tcl_Obj * Tcl_NewByteArrayObj(const unsigned char *bytes, EXTERN Tcl_Obj * Tcl_NewDoubleObj(double doubleValue); /* Slot 52 is reserved */ /* 53 */ -EXTERN Tcl_Obj * Tcl_NewListObj(int objc, Tcl_Obj *const objv[]); +EXTERN Tcl_Obj * Tcl_NewListObj(size_t objc, Tcl_Obj *const objv[]); /* Slot 54 is reserved */ /* 55 */ EXTERN Tcl_Obj * Tcl_NewObj(void); @@ -202,7 +202,7 @@ EXTERN void Tcl_SetByteArrayObj(Tcl_Obj *objPtr, EXTERN void Tcl_SetDoubleObj(Tcl_Obj *objPtr, double doubleValue); /* Slot 61 is reserved */ /* 62 */ -EXTERN void Tcl_SetListObj(Tcl_Obj *objPtr, int objc, +EXTERN void Tcl_SetListObj(Tcl_Obj *objPtr, size_t objc, Tcl_Obj *const objv[]); /* Slot 63 is reserved */ /* 64 */ @@ -1757,6 +1757,13 @@ EXTERN int Tcl_UniCharIsUnicode(int ch); /* 660 */ EXTERN int Tcl_AsyncMarkFromSignal(Tcl_AsyncHandler async, int sigNumber); +/* 661 */ +EXTERN int Tcl_ListObjGetElements(Tcl_Interp *interp, + Tcl_Obj *listPtr, size_t *objcPtr, + Tcl_Obj ***objvPtr); +/* 662 */ +EXTERN int Tcl_ListObjLength(Tcl_Interp *interp, + Tcl_Obj *listPtr, size_t *lengthPtr); typedef struct { const struct TclPlatStubs *tclPlatStubs; @@ -1793,7 +1800,7 @@ typedef struct TclStubs { void (*reserved22)(void); Tcl_Obj * (*tcl_DbNewByteArrayObj) (const unsigned char *bytes, size_t numBytes, const char *file, int line); /* 23 */ Tcl_Obj * (*tcl_DbNewDoubleObj) (double doubleValue, const char *file, int line); /* 24 */ - Tcl_Obj * (*tcl_DbNewListObj) (int objc, Tcl_Obj *const *objv, const char *file, int line); /* 25 */ + Tcl_Obj * (*tcl_DbNewListObj) (size_t objc, Tcl_Obj *const *objv, const char *file, int line); /* 25 */ void (*reserved26)(void); Tcl_Obj * (*tcl_DbNewObj) (const char *file, int line); /* 27 */ Tcl_Obj * (*tcl_DbNewStringObj) (const char *bytes, size_t length, const char *file, int line); /* 28 */ @@ -1813,15 +1820,15 @@ typedef struct TclStubs { void (*tcl_InvalidateStringRep) (Tcl_Obj *objPtr); /* 42 */ int (*tcl_ListObjAppendList) (Tcl_Interp *interp, Tcl_Obj *listPtr, Tcl_Obj *elemListPtr); /* 43 */ int (*tcl_ListObjAppendElement) (Tcl_Interp *interp, Tcl_Obj *listPtr, Tcl_Obj *objPtr); /* 44 */ - int (*tcl_ListObjGetElements) (Tcl_Interp *interp, Tcl_Obj *listPtr, int *objcPtr, Tcl_Obj ***objvPtr); /* 45 */ - int (*tcl_ListObjIndex) (Tcl_Interp *interp, Tcl_Obj *listPtr, int index, Tcl_Obj **objPtrPtr); /* 46 */ - int (*tcl_ListObjLength) (Tcl_Interp *interp, Tcl_Obj *listPtr, int *lengthPtr); /* 47 */ - int (*tcl_ListObjReplace) (Tcl_Interp *interp, Tcl_Obj *listPtr, int first, int count, int objc, Tcl_Obj *const objv[]); /* 48 */ + int (*tclListObjGetElements_) (Tcl_Interp *interp, Tcl_Obj *listPtr, int *objcPtr, Tcl_Obj ***objvPtr); /* 45 */ + int (*tcl_ListObjIndex) (Tcl_Interp *interp, Tcl_Obj *listPtr, size_t index, Tcl_Obj **objPtrPtr); /* 46 */ + int (*tclListObjLength_) (Tcl_Interp *interp, Tcl_Obj *listPtr, int *lengthPtr); /* 47 */ + int (*tcl_ListObjReplace) (Tcl_Interp *interp, Tcl_Obj *listPtr, size_t first, size_t count, size_t objc, Tcl_Obj *const objv[]); /* 48 */ void (*reserved49)(void); Tcl_Obj * (*tcl_NewByteArrayObj) (const unsigned char *bytes, size_t numBytes); /* 50 */ Tcl_Obj * (*tcl_NewDoubleObj) (double doubleValue); /* 51 */ void (*reserved52)(void); - Tcl_Obj * (*tcl_NewListObj) (int objc, Tcl_Obj *const objv[]); /* 53 */ + Tcl_Obj * (*tcl_NewListObj) (size_t objc, Tcl_Obj *const objv[]); /* 53 */ void (*reserved54)(void); Tcl_Obj * (*tcl_NewObj) (void); /* 55 */ Tcl_Obj * (*tcl_NewStringObj) (const char *bytes, size_t length); /* 56 */ @@ -1830,7 +1837,7 @@ typedef struct TclStubs { void (*tcl_SetByteArrayObj) (Tcl_Obj *objPtr, const unsigned char *bytes, size_t numBytes); /* 59 */ void (*tcl_SetDoubleObj) (Tcl_Obj *objPtr, double doubleValue); /* 60 */ void (*reserved61)(void); - void (*tcl_SetListObj) (Tcl_Obj *objPtr, int objc, Tcl_Obj *const objv[]); /* 62 */ + void (*tcl_SetListObj) (Tcl_Obj *objPtr, size_t objc, Tcl_Obj *const objv[]); /* 62 */ void (*reserved63)(void); void (*tcl_SetObjLength) (Tcl_Obj *objPtr, size_t length); /* 64 */ void (*tcl_SetStringObj) (Tcl_Obj *objPtr, const char *bytes, size_t length); /* 65 */ @@ -2429,6 +2436,8 @@ typedef struct TclStubs { void (*reserved658)(void); void (*reserved659)(void); int (*tcl_AsyncMarkFromSignal) (Tcl_AsyncHandler async, int sigNumber); /* 660 */ + int (*tcl_ListObjGetElements) (Tcl_Interp *interp, Tcl_Obj *listPtr, size_t *objcPtr, Tcl_Obj ***objvPtr); /* 661 */ + int (*tcl_ListObjLength) (Tcl_Interp *interp, Tcl_Obj *listPtr, size_t *lengthPtr); /* 662 */ } TclStubs; extern const TclStubs *tclStubsPtr; @@ -2530,12 +2539,12 @@ extern const TclStubs *tclStubsPtr; (tclStubsPtr->tcl_ListObjAppendList) /* 43 */ #define Tcl_ListObjAppendElement \ (tclStubsPtr->tcl_ListObjAppendElement) /* 44 */ -#define Tcl_ListObjGetElements \ - (tclStubsPtr->tcl_ListObjGetElements) /* 45 */ +#define TclListObjGetElements_ \ + (tclStubsPtr->tclListObjGetElements_) /* 45 */ #define Tcl_ListObjIndex \ (tclStubsPtr->tcl_ListObjIndex) /* 46 */ -#define Tcl_ListObjLength \ - (tclStubsPtr->tcl_ListObjLength) /* 47 */ +#define TclListObjLength_ \ + (tclStubsPtr->tclListObjLength_) /* 47 */ #define Tcl_ListObjReplace \ (tclStubsPtr->tcl_ListObjReplace) /* 48 */ /* Slot 49 is reserved */ @@ -3699,6 +3708,10 @@ extern const TclStubs *tclStubsPtr; /* Slot 659 is reserved */ #define Tcl_AsyncMarkFromSignal \ (tclStubsPtr->tcl_AsyncMarkFromSignal) /* 660 */ +#define Tcl_ListObjGetElements \ + (tclStubsPtr->tcl_ListObjGetElements) /* 661 */ +#define Tcl_ListObjLength \ + (tclStubsPtr->tcl_ListObjLength) /* 662 */ #endif /* defined(USE_TCL_STUBS) */ @@ -3895,6 +3908,16 @@ extern const TclStubs *tclStubsPtr; # define Tcl_UtfToWChar (sizeof(wchar_t) != sizeof(short) \ ? (int (*)(const char *, wchar_t *))tclStubsPtr->tcl_UtfToChar16 \ : (int (*)(const char *, wchar_t *))Tcl_UtfToUniChar) +#if 0 +# undef Tcl_ListObjGetElements +# define Tcl_ListObjGetElements(interp, listPtr, objcPtr, objvPtr) (sizeof(*objcPtr) != sizeof(int) \ + ? tclStubsPtr->tcl_ListObjGetElements((interp), (listPtr), (int *)(void *)(objcPtr), (objvPtr)) \ + : tclStubsPtr->tclListObjGetElements_((interp), (listPtr), (size_t *)(void *)(objcPtr), (objvPtr))) +# undef Tcl_ListObjLength +# define Tcl_ListObjLength(interp, listPtr, lengthPtr) (sizeof(*lengthPtr) != sizeof(int) \ + ? tclStubsPtr->tcl_ListObjLength((interp), (listPtr), (int *)(void *)(lengthPtr)) \ + : tclStubsPtr->tclListObjLength_((interp), (listPtr), (size_t *)(void *)(lengthPtr))) +#endif /* TCL_NO_DEPRECATED */ #else # define Tcl_WCharToUtfDString (sizeof(wchar_t) != sizeof(short) \ ? (char *(*)(const wchar_t *, size_t, Tcl_DString *))Tcl_UniCharToUtfDString \ diff --git a/generic/tclDictObj.c b/generic/tclDictObj.c index e92e174..cf82ac8 100644 --- a/generic/tclDictObj.c +++ b/generic/tclDictObj.c @@ -606,7 +606,7 @@ SetDictFromAny( Tcl_Obj **objv; /* Cannot fail, we already know the Tcl_ObjType is "list". */ - TclListObjGetElements(NULL, objPtr, &objc, &objv); + TclListObjGetElements_(NULL, objPtr, &objc, &objv); if (objc & 1) { goto missingValue; } @@ -2471,7 +2471,7 @@ DictForNRCmd( * Parse arguments. */ - if (TclListObjGetElements(interp, objv[1], &varc, &varv) != TCL_OK) { + if (TclListObjGetElements_(interp, objv[1], &varc, &varv) != TCL_OK) { return TCL_ERROR; } if (varc != 2) { @@ -2490,7 +2490,7 @@ DictForNRCmd( TclStackFree(interp, searchPtr); return TCL_OK; } - TclListObjGetElements(NULL, objv[1], &varc, &varv); + TclListObjGetElements_(NULL, objv[1], &varc, &varv); keyVarObj = varv[0]; valueVarObj = varv[1]; scriptObj = objv[3]; @@ -2665,7 +2665,7 @@ DictMapNRCmd( * Parse arguments. */ - if (TclListObjGetElements(interp, objv[1], &varc, &varv) != TCL_OK) { + if (TclListObjGetElements_(interp, objv[1], &varc, &varv) != TCL_OK) { return TCL_ERROR; } if (varc != 2) { @@ -2691,7 +2691,7 @@ DictMapNRCmd( return TCL_OK; } TclNewObj(storagePtr->accumulatorObj); - TclListObjGetElements(NULL, objv[1], &varc, &varv); + TclListObjGetElements_(NULL, objv[1], &varc, &varv); storagePtr->keyVarObj = varv[0]; storagePtr->valueVarObj = varv[1]; storagePtr->scriptObj = objv[3]; @@ -3104,7 +3104,7 @@ DictFilterCmd( * copying from the "dict for" implementation has occurred! */ - if (TclListObjGetElements(interp, objv[3], &varc, &varv) != TCL_OK) { + if (TclListObjGetElements_(interp, objv[3], &varc, &varv) != TCL_OK) { return TCL_ERROR; } if (varc != 2) { @@ -3365,7 +3365,7 @@ FinalizeDictUpdate( * an instruction to remove the key. */ - Tcl_ListObjGetElements(NULL, argsObj, &objc, &objv); + TclListObjGetElements_(NULL, argsObj, &objc, &objv); for (i=0 ; i 0 ? objv[1] : NULL); continue; case CRT_PARAM: - if (TclListObjLength(interp, objv[1], &len) != TCL_OK) { + if (TclListObjLength_(interp, objv[1], &len) != TCL_OK) { if (allocatedMapFlag) { Tcl_DecrRefCount(mapObj); } @@ -271,7 +271,7 @@ TclNamespaceEnsembleCmd( Tcl_Obj **listv; const char *cmd; - if (TclListObjGetElements(interp, listObj, &len, + if (TclListObjGetElements_(interp, listObj, &len, &listv) != TCL_OK) { Tcl_DictObjDone(&search); if (patchedDict) { @@ -336,7 +336,7 @@ TclNamespaceEnsembleCmd( } continue; case CRT_UNKNOWN: - if (TclListObjLength(interp, objv[1], &len) != TCL_OK) { + if (TclListObjLength_(interp, objv[1], &len) != TCL_OK) { if (allocatedMapFlag) { Tcl_DecrRefCount(mapObj); } @@ -531,13 +531,13 @@ TclNamespaceEnsembleCmd( } switch ((enum EnsConfigOpts) index) { case CONF_SUBCMDS: - if (TclListObjLength(interp, objv[1], &len) != TCL_OK) { + if (TclListObjLength_(interp, objv[1], &len) != TCL_OK) { goto freeMapAndError; } subcmdObj = (len > 0 ? objv[1] : NULL); continue; case CONF_PARAM: - if (TclListObjLength(interp, objv[1], &len) != TCL_OK) { + if (TclListObjLength_(interp, objv[1], &len) != TCL_OK) { goto freeMapAndError; } paramObj = (len > 0 ? objv[1] : NULL); @@ -559,7 +559,7 @@ TclNamespaceEnsembleCmd( continue; } do { - if (TclListObjGetElements(interp, listObj, &len, + if (TclListObjGetElements_(interp, listObj, &len, &listv) != TCL_OK) { Tcl_DictObjDone(&search); if (patchedDict) { @@ -621,7 +621,7 @@ TclNamespaceEnsembleCmd( } continue; case CONF_UNKNOWN: - if (TclListObjLength(interp, objv[1], &len) != TCL_OK) { + if (TclListObjLength_(interp, objv[1], &len) != TCL_OK) { goto freeMapAndError; } unknownObj = (len > 0 ? objv[1] : NULL); @@ -790,7 +790,7 @@ Tcl_SetEnsembleSubcommandList( if (subcmdList != NULL) { int length; - if (TclListObjLength(interp, subcmdList, &length) != TCL_OK) { + if (TclListObjLength_(interp, subcmdList, &length) != TCL_OK) { return TCL_ERROR; } if (length < 1) { @@ -866,7 +866,7 @@ Tcl_SetEnsembleParameterList( if (paramList == NULL) { length = 0; } else { - if (TclListObjLength(interp, paramList, &length) != TCL_OK) { + if (TclListObjLength_(interp, paramList, &length) != TCL_OK) { return TCL_ERROR; } if (length < 1) { @@ -1041,7 +1041,7 @@ Tcl_SetEnsembleUnknownHandler( if (unknownList != NULL) { int length; - if (TclListObjLength(interp, unknownList, &length) != TCL_OK) { + if (TclListObjLength_(interp, unknownList, &length) != TCL_OK) { return TCL_ERROR; } if (length < 1) { @@ -1884,7 +1884,7 @@ NsEnsembleImplementationCmdNR( Tcl_Obj **copyObjv; int copyObjc, prefixObjc; - Tcl_ListObjLength(NULL, prefixObj, &prefixObjc); + TclListObjLength_(NULL, prefixObj, &prefixObjc); if (objc == 2) { copyPtr = TclListObjCopy(NULL, prefixObj); @@ -1918,7 +1918,7 @@ NsEnsembleImplementationCmdNR( */ TclSkipTailcall(interp); - Tcl_ListObjGetElements(NULL, copyPtr, ©Objc, ©Objv); + TclListObjGetElements_(NULL, copyPtr, ©Objc, ©Objv); ((Interp *)interp)->lookupNsPtr = ensemblePtr->nsPtr; return TclNREvalObjv(interp, copyObjc, copyObjv, TCL_EVAL_INVOKE, NULL); } @@ -2292,7 +2292,7 @@ EnsembleUnknownCallback( for (i=1 ; itokenPtr; i < parsePtr->numWords; i++, tokPtr = TokenAfter(tokPtr)) { if (i > 0 && i < numWords+1) { diff --git a/generic/tclEvent.c b/generic/tclEvent.c index 183b973..aa69b90 100644 --- a/generic/tclEvent.c +++ b/generic/tclEvent.c @@ -219,7 +219,7 @@ HandleBgErrors( errPtr = assocPtr->firstBgPtr; - Tcl_ListObjGetElements(NULL, copyObj, &prefixObjc, &prefixObjv); + TclListObjGetElements_(NULL, copyObj, &prefixObjc, &prefixObjv); tempObjv = (Tcl_Obj**)Tcl_Alloc((prefixObjc+2) * sizeof(Tcl_Obj *)); memcpy(tempObjv, prefixObjv, prefixObjc*sizeof(Tcl_Obj *)); tempObjv[prefixObjc] = errPtr->errorMsg; diff --git a/generic/tclExecute.c b/generic/tclExecute.c index 73f3309..422e0ff 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -2672,7 +2672,7 @@ TEBCresume( objPtr = OBJ_AT_TOS; TRACE(("\"%.30s\" => ", O2S(objPtr))); - if (TclListObjGetElements(interp, objPtr, &objc, &objv) != TCL_OK) { + if (TclListObjGetElements_(interp, objPtr, &objc, &objv) != TCL_OK) { TRACE_ERROR(interp); goto gotError; } @@ -2882,7 +2882,7 @@ TEBCresume( TclMarkTailcall(interp); TclNRAddCallback(interp, TclClearRootEnsemble, NULL, NULL, NULL, NULL); - Tcl_ListObjGetElements(NULL, objPtr, &objc, &objv); + TclListObjGetElements_(NULL, objPtr, &objc, &objv); TclNRAddCallback(interp, TclNRReleaseValues, objPtr, NULL, NULL, NULL); return TclNREvalObjv(interp, objc, objv, TCL_EVAL_INVOKE, NULL); @@ -3293,7 +3293,7 @@ TEBCresume( varPtr = varPtr->value.linkPtr; } TRACE(("%u <- \"%.30s\" => ", opnd, O2S(valuePtr))); - if (TclListObjGetElements(interp, valuePtr, &objc, &objv) + if (TclListObjGetElements_(interp, valuePtr, &objc, &objv) != TCL_OK) { TRACE_ERROR(interp); goto gotError; @@ -3319,7 +3319,7 @@ TEBCresume( } TRACE(("%u \"%.30s\" \"%.30s\" => ", opnd, O2S(part2Ptr), O2S(valuePtr))); - if (TclListObjGetElements(interp, valuePtr, &objc, &objv) + if (TclListObjGetElements_(interp, valuePtr, &objc, &objv) != TCL_OK) { TRACE_ERROR(interp); goto gotError; @@ -3361,7 +3361,7 @@ TEBCresume( lappendListDirect: objResultPtr = varPtr->value.objPtr; - if (TclListObjLength(interp, objResultPtr, &len) != TCL_OK) { + if (TclListObjLength_(interp, objResultPtr, &len) != TCL_OK) { TRACE_ERROR(interp); goto gotError; } @@ -3382,7 +3382,7 @@ TEBCresume( lappendList: opnd = -1; - if (TclListObjGetElements(interp, valuePtr, &objc, &objv) + if (TclListObjGetElements_(interp, valuePtr, &objc, &objv) != TCL_OK) { TRACE_ERROR(interp); goto gotError; @@ -3420,7 +3420,7 @@ TEBCresume( if (!objResultPtr) { valueToAssign = valuePtr; - } else if (TclListObjLength(interp, objResultPtr, &len)!=TCL_OK) { + } else if (TclListObjLength_(interp, objResultPtr, &len)!=TCL_OK) { TRACE_ERROR(interp); goto gotError; } else { @@ -4636,7 +4636,7 @@ TEBCresume( case INST_LIST_LENGTH: TRACE(("\"%.30s\" => ", O2S(OBJ_AT_TOS))); - if (TclListObjLength(interp, OBJ_AT_TOS, &length) != TCL_OK) { + if (TclListObjLength_(interp, OBJ_AT_TOS, &length) != TCL_OK) { TRACE_ERROR(interp); goto gotError; } @@ -4653,7 +4653,7 @@ TEBCresume( * Extract the desired list element. */ - if ((TclListObjGetElements(interp, valuePtr, &objc, &objv) == TCL_OK) + if ((TclListObjGetElements_(interp, valuePtr, &objc, &objv) == TCL_OK) && !TclHasInternalRep(value2Ptr, &tclListType)) { int code; @@ -4698,7 +4698,7 @@ TEBCresume( * in the process. */ - if (TclListObjGetElements(interp, valuePtr, &objc, &objv) != TCL_OK) { + if (TclListObjGetElements_(interp, valuePtr, &objc, &objv) != TCL_OK) { TRACE_ERROR(interp); goto gotError; } @@ -4837,7 +4837,7 @@ TEBCresume( * in the process. */ - if (TclListObjLength(interp, valuePtr, &objc) != TCL_OK) { + if (TclListObjLength_(interp, valuePtr, &objc) != TCL_OK) { TRACE_ERROR(interp); goto gotError; } @@ -4902,7 +4902,7 @@ TEBCresume( s1 = Tcl_GetStringFromObj(valuePtr, &s1len); TRACE(("\"%.30s\" \"%.30s\" => ", O2S(valuePtr), O2S(value2Ptr))); - if (TclListObjLength(interp, value2Ptr, &length) != TCL_OK) { + if (TclListObjLength_(interp, value2Ptr, &length) != TCL_OK) { TRACE_ERROR(interp); goto gotError; } @@ -6244,7 +6244,7 @@ TEBCresume( varListPtr = infoPtr->varLists[i]; numVars = varListPtr->numVars; listPtr = OBJ_AT_DEPTH(listTmpDepth); - if (TclListObjLength(interp, listPtr, &listLen) != TCL_OK) { + if (TclListObjLength_(interp, listPtr, &listLen) != TCL_OK) { TRACE_APPEND(("ERROR converting list %ld, \"%s\": %s", i, O2S(listPtr), O2S(Tcl_GetObjResult(interp)))); goto gotError; @@ -6325,7 +6325,7 @@ TEBCresume( numVars = varListPtr->numVars; listPtr = OBJ_AT_DEPTH(listTmpDepth); - TclListObjGetElements(interp, listPtr, &listLen, &elements); + TclListObjGetElements_(interp, listPtr, &listLen, &elements); valIndex = (iterNum * numVars); for (j = 0; j < numVars; j++) { @@ -6937,7 +6937,7 @@ TEBCresume( } } Tcl_IncrRefCount(dictPtr); - if (TclListObjGetElements(interp, OBJ_AT_TOS, &length, + if (TclListObjGetElements_(interp, OBJ_AT_TOS, &length, &keyPtrPtr) != TCL_OK) { TRACE_ERROR(interp); goto gotError; @@ -6997,7 +6997,7 @@ TEBCresume( NEXT_INST_F(9, 1, 0); } if (Tcl_DictObjSize(interp, dictPtr, &length) != TCL_OK - || TclListObjGetElements(interp, OBJ_AT_TOS, &length, + || TclListObjGetElements_(interp, OBJ_AT_TOS, &length, &keyPtrPtr) != TCL_OK) { TRACE_ERROR(interp); goto gotError; @@ -7056,7 +7056,7 @@ TEBCresume( dictPtr = OBJ_UNDER_TOS; listPtr = OBJ_AT_TOS; TRACE(("\"%.30s\" \"%.30s\" =>", O2S(dictPtr), O2S(listPtr))); - if (TclListObjGetElements(interp, listPtr, &objc, &objv) != TCL_OK) { + if (TclListObjGetElements_(interp, listPtr, &objc, &objv) != TCL_OK) { TRACE_ERROR(interp); goto gotError; } @@ -7074,7 +7074,7 @@ TEBCresume( listPtr = OBJ_AT_TOS; TRACE(("\"%.30s\" \"%.30s\" \"%.30s\" => ", O2S(varNamePtr), O2S(valuePtr), O2S(keysPtr))); - if (TclListObjGetElements(interp, listPtr, &objc, &objv) != TCL_OK) { + if (TclListObjGetElements_(interp, listPtr, &objc, &objv) != TCL_OK) { TRACE_ERROR(interp); TclDecrRefCount(keysPtr); goto gotError; @@ -7105,7 +7105,7 @@ TEBCresume( varPtr = LOCAL(opnd); TRACE(("%u <- \"%.30s\" \"%.30s\" => ", opnd, O2S(valuePtr), O2S(keysPtr))); - if (TclListObjGetElements(interp, listPtr, &objc, &objv) != TCL_OK) { + if (TclListObjGetElements_(interp, listPtr, &objc, &objv) != TCL_OK) { TRACE_ERROR(interp); goto gotError; } diff --git a/generic/tclFCmd.c b/generic/tclFCmd.c index 4e37574..c931866 100644 --- a/generic/tclFCmd.c +++ b/generic/tclFCmd.c @@ -1006,7 +1006,7 @@ TclFileAttrsCmd( * Use objStrings as a list object. */ - if (Tcl_ListObjLength(interp, objStrings, &numObjStrings) != TCL_OK) { + if (TclListObjLength_(interp, objStrings, &numObjStrings) != TCL_OK) { goto end; } attributeStringsAllocated = (const char **) diff --git a/generic/tclFileName.c b/generic/tclFileName.c index b58d23b..e48381d 100644 --- a/generic/tclFileName.c +++ b/generic/tclFileName.c @@ -516,7 +516,7 @@ TclpNativeSplitPath( */ if (lenPtr != NULL) { - Tcl_ListObjLength(NULL, resultPtr, lenPtr); + TclListObjLength_(NULL, resultPtr, lenPtr); } return resultPtr; } @@ -1334,7 +1334,7 @@ Tcl_GlobObjCmd( return TCL_ERROR; } typePtr = objv[i+1]; - if (Tcl_ListObjLength(interp, typePtr, &length) != TCL_OK) { + if (TclListObjLength_(interp, typePtr, &length) != TCL_OK) { return TCL_ERROR; } i++; @@ -1456,7 +1456,7 @@ Tcl_GlobObjCmd( * platform. */ - Tcl_ListObjLength(interp, typePtr, &length); + TclListObjLength_(interp, typePtr, &length); if (length <= 0) { goto skipTypes; } @@ -1527,7 +1527,7 @@ Tcl_GlobObjCmd( Tcl_Obj *item; int llen; - if ((Tcl_ListObjLength(NULL, look, &llen) == TCL_OK) + if ((TclListObjLength_(NULL, look, &llen) == TCL_OK) && (llen == 3)) { Tcl_ListObjIndex(interp, look, 0, &item); if (!strcmp("macintosh", TclGetString(item))) { @@ -1634,7 +1634,7 @@ Tcl_GlobObjCmd( } if ((globFlags & TCL_GLOBMODE_NO_COMPLAIN) == 0) { - if (Tcl_ListObjLength(interp, Tcl_GetObjResult(interp), + if (TclListObjLength_(interp, Tcl_GetObjResult(interp), &length) != TCL_OK) { /* * This should never happen. Maybe we should be more dramatic. @@ -2017,7 +2017,7 @@ TclGlob( } } - Tcl_ListObjGetElements(NULL, filenamesObj, &objc, &objv); + TclListObjGetElements_(NULL, filenamesObj, &objc, &objv); for (i = 0; i< objc; i++) { size_t len; const char *oldStr = Tcl_GetStringFromObj(objv[i], &len); @@ -2346,13 +2346,13 @@ DoGlob( int subdirc, i, repair = -1; Tcl_Obj **subdirv; - result = Tcl_ListObjGetElements(interp, subdirsPtr, + result = TclListObjGetElements_(interp, subdirsPtr, &subdirc, &subdirv); for (i=0; result==TCL_OK && ifsPtr->listVolumesProc(); if (thisFsVolumes != NULL) { - if (Tcl_ListObjLength(NULL, thisFsVolumes, &numVolumes) + if (TclListObjLength_(NULL, thisFsVolumes, &numVolumes) != TCL_OK) { /* * This is VERY bad; the listVolumesProc didn't return a diff --git a/generic/tclIndexObj.c b/generic/tclIndexObj.c index b7511bc..629a107 100644 --- a/generic/tclIndexObj.c +++ b/generic/tclIndexObj.c @@ -121,7 +121,7 @@ GetIndexFromObjList( * of the code there. This is a bit ineffiecient but simpler. */ - result = Tcl_ListObjGetElements(interp, tableObjPtr, &objc, &objv); + result = TclListObjGetElements_(interp, tableObjPtr, &objc, &objv); if (result != TCL_OK) { return result; } @@ -522,7 +522,7 @@ PrefixMatchObjCmd( return TCL_ERROR; } i++; - result = Tcl_ListObjLength(interp, objv[i], &errorLength); + result = TclListObjLength_(interp, objv[i], &errorLength); if (result != TCL_OK) { return TCL_ERROR; } @@ -546,7 +546,7 @@ PrefixMatchObjCmd( * error case regardless of level. */ - result = Tcl_ListObjLength(interp, tablePtr, &dummyLength); + result = TclListObjLength_(interp, tablePtr, &dummyLength); if (result != TCL_OK) { return result; } @@ -612,7 +612,7 @@ PrefixAllObjCmd( return TCL_ERROR; } - result = Tcl_ListObjGetElements(interp, objv[1], &tableObjc, &tableObjv); + result = TclListObjGetElements_(interp, objv[1], &tableObjc, &tableObjv); if (result != TCL_OK) { return result; } @@ -670,7 +670,7 @@ PrefixLongestObjCmd( return TCL_ERROR; } - result = Tcl_ListObjGetElements(interp, objv[1], &tableObjc, &tableObjv); + result = TclListObjGetElements_(interp, objv[1], &tableObjc, &tableObjv); if (result != TCL_OK) { return result; } diff --git a/generic/tclInt.h b/generic/tclInt.h index 30d108b..e9ba3b9 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -2381,8 +2381,8 @@ typedef enum TclEolTranslation { typedef struct List { size_t refCount; - int maxElemCount; /* Total number of element array slots. */ - int elemCount; /* Current number of list elements. */ + size_t maxElemCount; /* Total number of element array slots. */ + size_t elemCount; /* Current number of list elements. */ int canonicalFlag; /* Set if the string representation was * derived from the list representation. May * be ignored if there is no string rep at @@ -3025,7 +3025,7 @@ MODULE_SCOPE void TclLimitRemoveAllHandlers(Tcl_Interp *interp); MODULE_SCOPE Tcl_Obj * TclLindexList(Tcl_Interp *interp, Tcl_Obj *listPtr, Tcl_Obj *argPtr); MODULE_SCOPE Tcl_Obj * TclLindexFlat(Tcl_Interp *interp, Tcl_Obj *listPtr, - int indexCount, Tcl_Obj *const indexArray[]); + size_t indexCount, Tcl_Obj *const indexArray[]); /* TIP #280 */ MODULE_SCOPE void TclListLines(Tcl_Obj *listObj, int line, int n, int *lines, Tcl_Obj *const *elems); diff --git a/generic/tclInterp.c b/generic/tclInterp.c index d448c3b..3c2f2be 100644 --- a/generic/tclInterp.c +++ b/generic/tclInterp.c @@ -2324,7 +2324,7 @@ GetInterp( Tcl_Interp *searchInterp; /* Interim storage for interp. to find. */ InterpInfo *parentInfoPtr; - if (TclListObjGetElements(interp, pathPtr, &objc, &objv) != TCL_OK) { + if (TclListObjGetElements_(interp, pathPtr, &objc, &objv) != TCL_OK) { return NULL; } @@ -2380,7 +2380,7 @@ ChildBgerror( if (objc) { int length; - if (TCL_ERROR == TclListObjLength(NULL, objv[0], &length) + if (TCL_ERROR == TclListObjLength_(NULL, objv[0], &length) || (length < 1)) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "cmdPrefix must be list of length >= 1", -1)); @@ -2427,7 +2427,7 @@ ChildCreate( int isNew, objc; Tcl_Obj **objv; - if (Tcl_ListObjGetElements(interp, pathPtr, &objc, &objv) != TCL_OK) { + if (TclListObjGetElements_(interp, pathPtr, &objc, &objv) != TCL_OK) { return NULL; } if (objc < 2) { diff --git a/generic/tclLink.c b/generic/tclLink.c index 139788e..d637dbd 100644 --- a/generic/tclLink.c +++ b/generic/tclLink.c @@ -947,7 +947,7 @@ LinkTraceProc( */ if (linkPtr->flags & LINK_ALLOC_LAST) { - if (Tcl_ListObjGetElements(NULL, (valueObj), &objc, &objv) == TCL_ERROR + if (TclListObjGetElements_(NULL, (valueObj), &objc, &objv) == TCL_ERROR || (size_t)objc != linkPtr->numElems) { return (char *) "wrong dimension"; } diff --git a/generic/tclListObj.c b/generic/tclListObj.c index 0d5aad5..747cf0d 100644 --- a/generic/tclListObj.c +++ b/generic/tclListObj.c @@ -18,9 +18,9 @@ * Prototypes for functions defined later in this file: */ -static List * AttemptNewList(Tcl_Interp *interp, int objc, +static List * AttemptNewList(Tcl_Interp *interp, size_t objc, Tcl_Obj *const objv[]); -static List * NewListIntRep(int objc, Tcl_Obj *const objv[], int p); +static List * NewListIntRep(size_t objc, Tcl_Obj *const objv[], size_t p); static void DupListInternalRep(Tcl_Obj *srcPtr, Tcl_Obj *copyPtr); static void FreeListInternalRep(Tcl_Obj *listPtr); static int SetListFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr); @@ -99,31 +99,12 @@ const Tcl_ObjType tclListType = { static List * NewListIntRep( - int objc, + size_t objc, Tcl_Obj *const objv[], - int p) + size_t p) { List *listRepPtr; - if (objc <= 0) { - Tcl_Panic("NewListIntRep: expects postive element count"); - } - - /* - * First check to see if we'd overflow and try to allocate an object - * larger than our memory allocator allows. Note that this is actually a - * fairly small value when you're on a serious 64-bit machine, but that - * requires API changes to fix. See [Bug 219196] for a discussion. - */ - - if ((size_t)objc > LIST_MAX) { - if (p) { - Tcl_Panic("max length of a Tcl list (%d elements) exceeded", - LIST_MAX); - } - return NULL; - } - listRepPtr = (List *)Tcl_AttemptAlloc(LIST_SIZE(objc)); if (listRepPtr == NULL) { if (p) { @@ -139,7 +120,7 @@ NewListIntRep( if (objv) { Tcl_Obj **elemPtrs; - int i; + size_t i; listRepPtr->elemCount = objc; elemPtrs = &listRepPtr->elements; @@ -166,7 +147,7 @@ NewListIntRep( static List * AttemptNewList( Tcl_Interp *interp, - int objc, + size_t objc, Tcl_Obj *const objv[]) { List *listRepPtr = NewListIntRep(objc, objv, 0); @@ -214,7 +195,7 @@ AttemptNewList( Tcl_Obj * Tcl_NewListObj( - int objc, /* Count of objects referenced by objv. */ + size_t objc, /* Count of objects referenced by objv. */ Tcl_Obj *const objv[]) /* An array of pointers to Tcl objects. */ { return Tcl_DbNewListObj(objc, objv, "unknown", 0); @@ -224,7 +205,7 @@ Tcl_NewListObj( Tcl_Obj * Tcl_NewListObj( - int objc, /* Count of objects referenced by objv. */ + size_t objc, /* Count of objects referenced by objv. */ Tcl_Obj *const objv[]) /* An array of pointers to Tcl objects. */ { List *listRepPtr; @@ -232,7 +213,7 @@ Tcl_NewListObj( TclNewObj(listPtr); - if (objc <= 0) { + if (objc + 1 <= 1) { return listPtr; } @@ -271,7 +252,7 @@ Tcl_NewListObj( Tcl_Obj * Tcl_DbNewListObj( - int objc, /* Count of objects referenced by objv. */ + size_t objc, /* Count of objects referenced by objv. */ Tcl_Obj *const objv[], /* An array of pointers to Tcl objects. */ const char *file, /* The name of the source file calling this * function; used for debugging. */ @@ -283,7 +264,7 @@ Tcl_DbNewListObj( TclDbNewObj(listPtr, file, line); - if (objc <= 0) { + if (objc + 1 <= 1) { return listPtr; } @@ -307,7 +288,7 @@ Tcl_DbNewListObj( Tcl_Obj * Tcl_DbNewListObj( - int objc, /* Count of objects referenced by objv. */ + size_t objc, /* Count of objects referenced by objv. */ Tcl_Obj *const objv[], /* An array of pointers to Tcl objects. */ TCL_UNUSED(const char *) /*file*/, TCL_UNUSED(int) /*line*/) @@ -330,7 +311,7 @@ Tcl_DbNewListObj( void Tcl_SetListObj( Tcl_Obj *objPtr, /* Object whose internal rep to init. */ - int objc, /* Count of objects referenced by objv. */ + size_t objc, /* Count of objects referenced by objv. */ Tcl_Obj *const objv[]) /* An array of pointers to Tcl objects. */ { List *listRepPtr; @@ -431,16 +412,16 @@ TclListObjRange( size_t toIdx) /* Index of last element to include. */ { Tcl_Obj **elemPtrs; - int listLen; + size_t listLen; size_t i, newLen; List *listRepPtr; - TclListObjGetElements(NULL, listPtr, &listLen, &elemPtrs); + Tcl_ListObjGetElements(NULL, listPtr, &listLen, &elemPtrs); if (fromIdx == TCL_INDEX_NONE) { fromIdx = 0; } - if (toIdx + 1 >= (size_t)listLen + 1) { + if (toIdx + 1 >= listLen + 1) { toIdx = listLen-1; } if (fromIdx + 1 > toIdx + 1) { @@ -527,7 +508,7 @@ Tcl_ListObjGetElements( Tcl_Interp *interp, /* Used to report errors if not NULL. */ Tcl_Obj *listPtr, /* List object for which an element array is * to be returned. */ - int *objcPtr, /* Where to store the count of objects + size_t *objcPtr, /* Where to store the count of objects * referenced by objv. */ Tcl_Obj ***objvPtr) /* Where to store the pointer to an array of * pointers to the list's objects. */ @@ -593,7 +574,7 @@ Tcl_ListObjAppendList( Tcl_Obj *listPtr, /* List object to append elements to. */ Tcl_Obj *elemListPtr) /* List obj with elements to append. */ { - int objc; + size_t objc; Tcl_Obj **objv; if (Tcl_IsShared(listPtr)) { @@ -604,7 +585,7 @@ Tcl_ListObjAppendList( * Pull the elements to append from elemListPtr. */ - if (TCL_OK != TclListObjGetElements(interp, elemListPtr, &objc, &objv)) { + if (TCL_OK != Tcl_ListObjGetElements(interp, elemListPtr, &objc, &objv)) { return TCL_ERROR; } @@ -653,7 +634,8 @@ Tcl_ListObjAppendElement( Tcl_Obj *objPtr) /* Object to append to listPtr's list. */ { List *listRepPtr, *newPtr = NULL; - int numElems, numRequired, needGrow, isShared, attempt; + size_t numElems, numRequired; + int needGrow, isShared, attempt; if (Tcl_IsShared(listPtr)) { Tcl_Panic("%s called with shared object", "Tcl_ListObjAppendElement"); @@ -829,7 +811,7 @@ int Tcl_ListObjIndex( Tcl_Interp *interp, /* Used to report errors if not NULL. */ Tcl_Obj *listPtr, /* List object to index into. */ - int index, /* Index of element to return. */ + size_t index, /* Index of element to return. */ Tcl_Obj **objPtrPtr) /* The resulting Tcl_Obj* is stored here. */ { List *listRepPtr; @@ -851,7 +833,7 @@ Tcl_ListObjIndex( ListGetIntRep(listPtr, listRepPtr); } - if ((index < 0) || (index >= listRepPtr->elemCount)) { + if (index >= listRepPtr->elemCount) { *objPtrPtr = NULL; } else { *objPtrPtr = (&listRepPtr->elements)[index]; @@ -887,7 +869,7 @@ int Tcl_ListObjLength( Tcl_Interp *interp, /* Used to report errors if not NULL. */ Tcl_Obj *listPtr, /* List object whose #elements to return. */ - int *intPtr) /* The resulting int is stored here. */ + size_t *intPtr) /* The resulting size_t is stored here. */ { List *listRepPtr; @@ -955,15 +937,16 @@ int Tcl_ListObjReplace( Tcl_Interp *interp, /* Used for error reporting if not NULL. */ Tcl_Obj *listPtr, /* List object whose elements to replace. */ - int first, /* Index of first element to replace. */ - int count, /* Number of elements to replace. */ - int objc, /* Number of objects to insert. */ + size_t first, /* Index of first element to replace. */ + size_t count, /* Number of elements to replace. */ + size_t objc, /* Number of objects to insert. */ Tcl_Obj *const objv[]) /* An array of objc pointers to Tcl objects to * insert. */ { List *listRepPtr; Tcl_Obj **elemPtrs; - int needGrow, numElems, numRequired, numAfterLast, start, i, j, isShared; + size_t numElems, numRequired, numAfterLast, start, i, j; + int needGrow, isShared; if (Tcl_IsShared(listPtr)) { Tcl_Panic("%s called with shared object", "Tcl_ListObjReplace"); @@ -1000,13 +983,13 @@ Tcl_ListObjReplace( elemPtrs = &listRepPtr->elements; numElems = listRepPtr->elemCount; - if (first < 0) { + if (first == TCL_INDEX_NONE) { first = 0; } if (first >= numElems) { first = numElems; /* So we'll insert after last element. */ } - if (count < 0) { + if (count == TCL_INDEX_NONE) { count = 0; } else if (first > INT_MAX - count /* Handle integer overflow */ || numElems < first+count) { @@ -1014,14 +997,6 @@ Tcl_ListObjReplace( count = numElems - first; } - if (objc > LIST_MAX - (numElems - count)) { - if (interp != NULL) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "max length of a Tcl list (%d elements) exceeded", - LIST_MAX)); - } - return TCL_ERROR; - } isShared = (listRepPtr->refCount > 1); numRequired = numElems - count + objc; /* Known <= LIST_MAX */ needGrow = numRequired > listRepPtr->maxElemCount; @@ -1033,7 +1008,7 @@ Tcl_ListObjReplace( if (needGrow && !isShared) { /* Try to use realloc */ List *newPtr = NULL; - int attempt = 2 * numRequired; + size_t attempt = 2 * numRequired; if (attempt <= LIST_MAX) { newPtr = (List *)Tcl_AttemptRealloc(listRepPtr, LIST_SIZE(attempt)); } @@ -1311,17 +1286,17 @@ Tcl_Obj * TclLindexFlat( Tcl_Interp *interp, /* Tcl interpreter. */ Tcl_Obj *listPtr, /* Tcl object representing the list. */ - int indexCount, /* Count of indices. */ + size_t indexCount, /* Count of indices. */ Tcl_Obj *const indexArray[])/* Array of pointers to Tcl objects that * represent the indices in the list. */ { - int i; + size_t i; Tcl_IncrRefCount(listPtr); for (i=0 ; iresetErrorStack = 0; - Tcl_ListObjLength(interp, iPtr->errorStack, &len); + TclListObjLength_(interp, iPtr->errorStack, &len); /* * Reset while keeping the list internalrep as much as possible. @@ -5098,7 +5098,7 @@ TclErrorStackResetIf( int len; iPtr->resetErrorStack = 0; - Tcl_ListObjLength(interp, iPtr->errorStack, &len); + TclListObjLength_(interp, iPtr->errorStack, &len); /* * Reset while keeping the list internalrep as much as possible. diff --git a/generic/tclOODefineCmds.c b/generic/tclOODefineCmds.c index 8831056..4676599 100644 --- a/generic/tclOODefineCmds.c +++ b/generic/tclOODefineCmds.c @@ -1065,7 +1065,7 @@ MagicDefinitionInvoke( Tcl_ListObjAppendElement(NULL, objPtr, obj2Ptr); /* TODO: overflow? */ Tcl_ListObjReplace(NULL, objPtr, 1, 0, objc - offset, objv + offset); - Tcl_ListObjGetElements(NULL, objPtr, &dummy, &objs); + TclListObjGetElements_(NULL, objPtr, &dummy, &objs); result = Tcl_EvalObjv(interp, objc - cmdIndex, objs, TCL_EVAL_INVOKE); if (isRoot) { @@ -2372,7 +2372,7 @@ ClassFilterSet( "attempt to misuse API", -1)); Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL); return TCL_ERROR; - } else if (Tcl_ListObjGetElements(interp, objv[0], &filterc, + } else if (TclListObjGetElements_(interp, objv[0], &filterc, &filterv) != TCL_OK) { return TCL_ERROR; } @@ -2456,7 +2456,7 @@ ClassMixinSet( "attempt to misuse API", -1)); Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL); return TCL_ERROR; - } else if (Tcl_ListObjGetElements(interp, objv[0], &mixinc, + } else if (TclListObjGetElements_(interp, objv[0], &mixinc, &mixinv) != TCL_OK) { return TCL_ERROR; } @@ -2566,7 +2566,7 @@ ClassSuperSet( "may not modify the superclass of the root object", -1)); Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL); return TCL_ERROR; - } else if (Tcl_ListObjGetElements(interp, objv[0], &superc, + } else if (TclListObjGetElements_(interp, objv[0], &superc, &superv) != TCL_OK) { return TCL_ERROR; } @@ -2736,7 +2736,7 @@ ClassVarsSet( "attempt to misuse API", -1)); Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL); return TCL_ERROR; - } else if (Tcl_ListObjGetElements(interp, objv[0], &varc, + } else if (TclListObjGetElements_(interp, objv[0], &varc, &varv) != TCL_OK) { return TCL_ERROR; } @@ -2828,7 +2828,7 @@ ObjFilterSet( return TCL_ERROR; } objv += Tcl_ObjectContextSkippedArgs(context); - if (Tcl_ListObjGetElements(interp, objv[0], &filterc, + if (TclListObjGetElements_(interp, objv[0], &filterc, &filterv) != TCL_OK) { return TCL_ERROR; } @@ -2902,7 +2902,7 @@ ObjMixinSet( return TCL_ERROR; } objv += Tcl_ObjectContextSkippedArgs(context); - if (Tcl_ListObjGetElements(interp, objv[0], &mixinc, + if (TclListObjGetElements_(interp, objv[0], &mixinc, &mixinv) != TCL_OK) { return TCL_ERROR; } @@ -2992,7 +2992,7 @@ ObjVarsSet( return TCL_ERROR; } objv += Tcl_ObjectContextSkippedArgs(context); - if (Tcl_ListObjGetElements(interp, objv[0], &varc, + if (TclListObjGetElements_(interp, objv[0], &varc, &varv) != TCL_OK) { return TCL_ERROR; } diff --git a/generic/tclOOMethod.c b/generic/tclOOMethod.c index a6eca3e..d266697 100644 --- a/generic/tclOOMethod.c +++ b/generic/tclOOMethod.c @@ -339,7 +339,7 @@ TclOONewProcInstanceMethod( ProcedureMethod *pmPtr; Tcl_Method method; - if (Tcl_ListObjLength(interp, argsObj, &argsLen) != TCL_OK) { + if (TclListObjLength_(interp, argsObj, &argsLen) != TCL_OK) { return NULL; } pmPtr = (ProcedureMethod *)Tcl_Alloc(sizeof(ProcedureMethod)); @@ -397,7 +397,7 @@ TclOONewProcMethod( TclNewObj(argsObj); Tcl_IncrRefCount(argsObj); procName = ""; - } else if (Tcl_ListObjLength(interp, argsObj, &argsLen) != TCL_OK) { + } else if (TclListObjLength_(interp, argsObj, &argsLen) != TCL_OK) { return NULL; } else { procName = (nameObj==NULL ? "" : TclGetString(nameObj)); @@ -1390,7 +1390,7 @@ TclOONewForwardInstanceMethod( int prefixLen; ForwardMethod *fmPtr; - if (Tcl_ListObjLength(interp, prefixObj, &prefixLen) != TCL_OK) { + if (TclListObjLength_(interp, prefixObj, &prefixLen) != TCL_OK) { return NULL; } if (prefixLen < 1) { @@ -1429,7 +1429,7 @@ TclOONewForwardMethod( int prefixLen; ForwardMethod *fmPtr; - if (Tcl_ListObjLength(interp, prefixObj, &prefixLen) != TCL_OK) { + if (TclListObjLength_(interp, prefixObj, &prefixLen) != TCL_OK) { return NULL; } if (prefixLen < 1) { @@ -1477,7 +1477,7 @@ InvokeForwardMethod( * can ignore here. */ - Tcl_ListObjGetElements(NULL, fmPtr->prefixObj, &numPrefixes, &prefixObjs); + TclListObjGetElements_(NULL, fmPtr->prefixObj, &numPrefixes, &prefixObjs); argObjs = InitEnsembleRewrite(interp, objc, objv, skip, numPrefixes, prefixObjs, &len); Tcl_NRAddCallback(interp, FinalizeForwardCall, argObjs, NULL, NULL, NULL); diff --git a/generic/tclObj.c b/generic/tclObj.c index 37dae8d..d32f9be 100644 --- a/generic/tclObj.c +++ b/generic/tclObj.c @@ -841,7 +841,7 @@ Tcl_AppendAllObjTypes( * Get the test for a valid list out of the way first. */ - if (TclListObjLength(interp, objPtr, &numElems) != TCL_OK) { + if (TclListObjLength_(interp, objPtr, &numElems) != TCL_OK) { return TCL_ERROR; } diff --git a/generic/tclPathObj.c b/generic/tclPathObj.c index ad1e04d..bb60a14 100644 --- a/generic/tclPathObj.c +++ b/generic/tclPathObj.c @@ -810,12 +810,12 @@ Tcl_FSJoinPath( int objc; Tcl_Obj **objv; - if (Tcl_ListObjLength(NULL, listObj, &objc) != TCL_OK) { + if (TclListObjLength_(NULL, listObj, &objc) != TCL_OK) { return NULL; } elements = ((elements >= 0) && (elements <= objc)) ? elements : objc; - Tcl_ListObjGetElements(NULL, listObj, &objc, &objv); + TclListObjGetElements_(NULL, listObj, &objc, &objv); res = TclJoinPath(elements, objv, 0); return res; } @@ -2314,7 +2314,7 @@ SetFsPathFromAny( Tcl_Obj **objv; Tcl_Obj *parts = TclpNativeSplitPath(pathPtr, NULL); - Tcl_ListObjGetElements(NULL, parts, &objc, &objv); + TclListObjGetElements_(NULL, parts, &objc, &objv); /* * Skip '~'. It's replaced by its expansion. diff --git a/generic/tclPkg.c b/generic/tclPkg.c index a369a29..5e025a9 100644 --- a/generic/tclPkg.c +++ b/generic/tclPkg.c @@ -1361,7 +1361,7 @@ TclNRPackageObjCmd( objvListPtr = Tcl_NewListObj(0, NULL); Tcl_IncrRefCount(objvListPtr); Tcl_ListObjAppendElement(interp, objvListPtr, ov); - Tcl_ListObjGetElements(interp, objvListPtr, &newobjc, &newObjvPtr); + TclListObjGetElements_(interp, objvListPtr, &newobjc, &newObjvPtr); Tcl_NRAddCallback(interp, TclNRPackageObjCmdCleanup, objv[3], objvListPtr, NULL,NULL); @@ -1388,7 +1388,7 @@ TclNRPackageObjCmd( Tcl_ListObjAppendElement(interp, objvListPtr, Tcl_DuplicateObj(newobjv[i])); } - Tcl_ListObjGetElements(interp, objvListPtr, &newobjc, &newObjvPtr); + TclListObjGetElements_(interp, objvListPtr, &newobjc, &newObjvPtr); Tcl_NRAddCallback(interp, TclNRPackageObjCmdCleanup, objv[2], objvListPtr, NULL,NULL); Tcl_NRAddCallback(interp, diff --git a/generic/tclProc.c b/generic/tclProc.c index ff1b1b3..3908771 100644 --- a/generic/tclProc.c +++ b/generic/tclProc.c @@ -484,7 +484,7 @@ TclCreateProc( * in the Proc. */ - result = Tcl_ListObjGetElements(interp , argsPtr ,&numArgs ,&argArray); + result = TclListObjGetElements_(interp , argsPtr ,&numArgs ,&argArray); if (result != TCL_OK) { goto procError; } @@ -515,7 +515,7 @@ TclCreateProc( * Now divide the specifier up into name and default. */ - result = Tcl_ListObjGetElements(interp, argArray[i], &fieldCount, + result = TclListObjGetElements_(interp, argArray[i], &fieldCount, &fieldValues); if (result != TCL_OK) { goto procError; @@ -920,7 +920,7 @@ TclNRUplevelObjCmd( return TCL_ERROR; } else if (!TclHasStringRep(objv[1]) && objc == 2) { int status ,llength; - status = Tcl_ListObjLength(interp, objv[1], &llength); + status = TclListObjLength_(interp, objv[1], &llength); if (status == TCL_OK && llength > 1) { /* the first argument can't interpreted as a level. Avoid * generating a string representation of the script. */ @@ -2395,7 +2395,7 @@ SetLambdaFromAny( * length is not 2, then it cannot be converted to lambdaType. */ - result = TclListObjGetElements(NULL, objPtr, &objc, &objv); + result = TclListObjGetElements_(NULL, objPtr, &objc, &objv); if ((result != TCL_OK) || ((objc != 2) && (objc != 3))) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "can't interpret \"%s\" as a lambda expression", diff --git a/generic/tclProcess.c b/generic/tclProcess.c index 49b4068..31a17fa 100644 --- a/generic/tclProcess.c +++ b/generic/tclProcess.c @@ -533,7 +533,7 @@ ProcessStatusObjCmd( * Only return statuses of provided processes. */ - result = Tcl_ListObjGetElements(interp, objv[1], &numPids, &pidObjs); + result = TclListObjGetElements_(interp, objv[1], &numPids, &pidObjs); if (result != TCL_OK) { return result; } @@ -648,7 +648,7 @@ ProcessPurgeObjCmd( * Purge only provided processes. */ - result = Tcl_ListObjGetElements(interp, objv[1], &numPids, &pidObjs); + result = TclListObjGetElements_(interp, objv[1], &numPids, &pidObjs); if (result != TCL_OK) { return result; } diff --git a/generic/tclResult.c b/generic/tclResult.c index 7a28e10..b447e67 100644 --- a/generic/tclResult.c +++ b/generic/tclResult.c @@ -750,12 +750,12 @@ TclProcessReturn( * if someone does [return -errorstack [info errorstack]] */ - if (Tcl_ListObjGetElements(interp, valuePtr, &valueObjc, + if (TclListObjGetElements_(interp, valuePtr, &valueObjc, &valueObjv) == TCL_ERROR) { return TCL_ERROR; } iPtr->resetErrorStack = 0; - Tcl_ListObjLength(interp, iPtr->errorStack, &len); + TclListObjLength_(interp, iPtr->errorStack, &len); /* * Reset while keeping the list internalrep as much as possible. @@ -912,7 +912,7 @@ TclMergeReturnOptions( if (valuePtr != NULL) { int length; - if (TCL_ERROR == Tcl_ListObjLength(NULL, valuePtr, &length )) { + if (TCL_ERROR == TclListObjLength_(NULL, valuePtr, &length )) { /* * Value is not a list, which is illegal for -errorcode. */ @@ -934,7 +934,7 @@ TclMergeReturnOptions( if (valuePtr != NULL) { int length; - if (TCL_ERROR == Tcl_ListObjLength(NULL, valuePtr, &length )) { + if (TCL_ERROR == TclListObjLength_(NULL, valuePtr, &length )) { /* * Value is not a list, which is illegal for -errorstack. */ @@ -1104,7 +1104,7 @@ Tcl_SetReturnOptions( Tcl_Obj **objv, *mergedOpts; Tcl_IncrRefCount(options); - if (TCL_ERROR == TclListObjGetElements(interp, options, &objc, &objv) + if (TCL_ERROR == TclListObjGetElements_(interp, options, &objc, &objv) || (objc % 2)) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "expected dict but got \"%s\"", TclGetString(options))); diff --git a/generic/tclStrToD.c b/generic/tclStrToD.c index f6fe00f..5ce4c78 100644 --- a/generic/tclStrToD.c +++ b/generic/tclStrToD.c @@ -559,7 +559,7 @@ TclParseNumber( if (TclHasInternalRep(objPtr, &tclListType)) { int length; /* A list can only be a (single) number if its length == 1 */ - TclListObjLength(NULL, objPtr, &length); + TclListObjLength_(NULL, objPtr, &length); if (length != 1) { return TCL_ERROR; } diff --git a/generic/tclStringObj.c b/generic/tclStringObj.c index d760f17..b52e33c 100644 --- a/generic/tclStringObj.c +++ b/generic/tclStringObj.c @@ -473,7 +473,7 @@ TclCheckEmptyString( } if (TclListObjIsCanonical(objPtr)) { - Tcl_ListObjLength(NULL, objPtr, &length); + TclListObjLength_(NULL, objPtr, &length); return length == 0; } @@ -2678,7 +2678,7 @@ AppendPrintfToObjVA( } } while (seekingConversion); } - TclListObjGetElements(NULL, list, &objc, &objv); + TclListObjGetElements_(NULL, list, &objc, &objv); code = Tcl_AppendFormatToObj(NULL, objPtr, format, objc, objv); if (code != TCL_OK) { Tcl_AppendPrintfToObj(objPtr, diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c index 1759171..6885e07 100644 --- a/generic/tclStubInit.c +++ b/generic/tclStubInit.c @@ -86,6 +86,24 @@ static void uniCodePanic() { #define TclUtfNext Tcl_UtfNext #define TclUtfPrev Tcl_UtfPrev +int TclListObjGetElements_(Tcl_Interp *interp, Tcl_Obj *listPtr, + int *objcPtr, Tcl_Obj ***objvPtr) { + size_t n; + int result = Tcl_ListObjGetElements(interp, listPtr, &n, objvPtr); + if (objcPtr) { + *objcPtr = n; + } + return result; +} +int TclListObjLength_(Tcl_Interp *interp, Tcl_Obj *listPtr, + int *lengthPtr) { + size_t n; + int result = Tcl_ListObjLength(interp, listPtr, &n); + if (lengthPtr) { + *lengthPtr = n; + } + return result; +} #define TclBN_mp_add mp_add #define TclBN_mp_add_d mp_add_d @@ -736,9 +754,9 @@ const TclStubs tclStubs = { Tcl_InvalidateStringRep, /* 42 */ Tcl_ListObjAppendList, /* 43 */ Tcl_ListObjAppendElement, /* 44 */ - Tcl_ListObjGetElements, /* 45 */ + TclListObjGetElements_, /* 45 */ Tcl_ListObjIndex, /* 46 */ - Tcl_ListObjLength, /* 47 */ + TclListObjLength_, /* 47 */ Tcl_ListObjReplace, /* 48 */ 0, /* 49 */ Tcl_NewByteArrayObj, /* 50 */ @@ -1352,6 +1370,8 @@ const TclStubs tclStubs = { 0, /* 658 */ 0, /* 659 */ Tcl_AsyncMarkFromSignal, /* 660 */ + Tcl_ListObjGetElements, /* 661 */ + Tcl_ListObjLength, /* 662 */ }; /* !END!: Do not edit above this line. */ diff --git a/generic/tclTest.c b/generic/tclTest.c index 91239a9..fc14e1d 100644 --- a/generic/tclTest.c +++ b/generic/tclTest.c @@ -440,7 +440,8 @@ Tcltest_Init( Tcl_Interp *interp) /* Interpreter for application. */ { Tcl_Obj **objv, *objPtr; - int objc, index; + size_t objc; + int index; static const char *const specialOptions[] = { "-appinitprocerror", "-appinitprocdeleteinterp", "-appinitprocclosestderr", "-appinitprocsetrcfile", NULL @@ -6789,7 +6790,7 @@ SimpleMatchInDirectory( origPtr = SimpleRedirect(dirPtr); res = Tcl_FSMatchInDirectory(interp, resPtr, origPtr, pattern, types); if (res == TCL_OK) { - int gLength, j; + size_t gLength, j; Tcl_ListObjLength(NULL, resPtr, &gLength); for (j = 0; j < gLength; j++) { Tcl_Obj *gElt, *nElt; @@ -7355,7 +7356,8 @@ TestconcatobjCmd( TCL_UNUSED(const char **) /*argv*/) { Tcl_Obj *list1Ptr, *list2Ptr, *emptyPtr, *concatPtr, *tmpPtr; - int result = TCL_OK, len; + int result = TCL_OK; + size_t len; Tcl_Obj *objv[3]; /* diff --git a/generic/tclTrace.c b/generic/tclTrace.c index aed3c2e..f469233 100644 --- a/generic/tclTrace.c +++ b/generic/tclTrace.c @@ -433,7 +433,7 @@ TraceExecutionObjCmd( * pointer to its array of element pointers. */ - result = Tcl_ListObjGetElements(interp, objv[4], &listLen, &elemPtrs); + result = TclListObjGetElements_(interp, objv[4], &listLen, &elemPtrs); if (result != TCL_OK) { return result; } @@ -603,7 +603,7 @@ TraceExecutionObjCmd( TclNewLiteralStringObj(opObj, "leavestep"); Tcl_ListObjAppendElement(NULL, elemObjPtr, opObj); } - Tcl_ListObjLength(NULL, elemObjPtr, &numOps); + TclListObjLength_(NULL, elemObjPtr, &numOps); if (0 == numOps) { Tcl_DecrRefCount(elemObjPtr); continue; @@ -674,7 +674,7 @@ TraceCommandObjCmd( * pointer to its array of element pointers. */ - result = Tcl_ListObjGetElements(interp, objv[4], &listLen, &elemPtrs); + result = TclListObjGetElements_(interp, objv[4], &listLen, &elemPtrs); if (result != TCL_OK) { return result; } @@ -798,7 +798,7 @@ TraceCommandObjCmd( TclNewLiteralStringObj(opObj, "delete"); Tcl_ListObjAppendElement(NULL, elemObjPtr, opObj); } - Tcl_ListObjLength(NULL, elemObjPtr, &numOps); + TclListObjLength_(NULL, elemObjPtr, &numOps); if (0 == numOps) { Tcl_DecrRefCount(elemObjPtr); continue; @@ -873,7 +873,7 @@ TraceVariableObjCmd( * pointer to its array of element pointers. */ - result = Tcl_ListObjGetElements(interp, objv[4], &listLen, &elemPtrs); + result = TclListObjGetElements_(interp, objv[4], &listLen, &elemPtrs); if (result != TCL_OK) { return result; } diff --git a/generic/tclUtil.c b/generic/tclUtil.c index 3aceb67..fa54310 100644 --- a/generic/tclUtil.c +++ b/generic/tclUtil.c @@ -3484,7 +3484,7 @@ GetEndOffsetFromObj( if ((TclMaxListLength(bytes, -1, NULL) > 1) /* If it's possible, do the full list parse. */ - && (TCL_OK == Tcl_ListObjLength(NULL, objPtr, &len)) + && (TCL_OK == TclListObjLength_(NULL, objPtr, &len)) && (len > 1)) { goto parseError; } diff --git a/generic/tclVar.c b/generic/tclVar.c index 35ce05c..e9c0134 100644 --- a/generic/tclVar.c +++ b/generic/tclVar.c @@ -2835,7 +2835,7 @@ Tcl_LappendObjCmd( return TCL_ERROR; } } else { - result = TclListObjLength(interp, newValuePtr, &numElems); + result = TclListObjLength_(interp, newValuePtr, &numElems); if (result != TCL_OK) { return result; } @@ -2893,7 +2893,7 @@ Tcl_LappendObjCmd( createdNewObj = 1; } - result = TclListObjLength(interp, varValuePtr, &numElems); + result = TclListObjLength_(interp, varValuePtr, &numElems); if (result == TCL_OK) { result = Tcl_ListObjReplace(interp, varValuePtr, numElems, 0, (objc-2), (objv+2)); @@ -3045,7 +3045,7 @@ ArrayForNRCmd( * Parse arguments. */ - if (Tcl_ListObjLength(interp, objv[1], &numVars) != TCL_OK) { + if (TclListObjLength_(interp, objv[1], &numVars) != TCL_OK) { return TCL_ERROR; } @@ -3156,7 +3156,7 @@ ArrayForLoopCallback( goto arrayfordone; } - Tcl_ListObjGetElements(NULL, varListObj, &varc, &varv); + TclListObjGetElements_(NULL, varListObj, &varc, &varv); if (Tcl_ObjSetVar2(interp, varv[0], NULL, keyObj, TCL_LEAVE_ERR_MSG) == NULL) { result = TCL_ERROR; @@ -3696,7 +3696,7 @@ ArrayGetCmd( */ TclNewObj(tmpResObj); - result = Tcl_ListObjGetElements(interp, nameLstObj, &count, &nameObjPtr); + result = TclListObjGetElements_(interp, nameLstObj, &count, &nameObjPtr); if (result != TCL_OK) { goto errorInArrayGet; } @@ -4019,7 +4019,7 @@ ArraySetCmd( int elemLen; Tcl_Obj **elemPtrs, *copyListObj; - result = TclListObjGetElements(interp, arrayElemObj, + result = TclListObjGetElements_(interp, arrayElemObj, &elemLen, &elemPtrs); if (result != TCL_OK) { return result; diff --git a/generic/tclZipfs.c b/generic/tclZipfs.c index f3e1e33..6413499 100644 --- a/generic/tclZipfs.c +++ b/generic/tclZipfs.c @@ -3033,7 +3033,7 @@ ZipFSMkZipOrImg( } } Tcl_IncrRefCount(list); - if (Tcl_ListObjGetElements(interp, list, &lobjc, &lobjv) != TCL_OK) { + if (TclListObjGetElements_(interp, list, &lobjc, &lobjv) != TCL_OK) { Tcl_DecrRefCount(list); return TCL_ERROR; } diff --git a/generic/tclZlib.c b/generic/tclZlib.c index 7e1b379..b874750 100644 --- a/generic/tclZlib.c +++ b/generic/tclZlib.c @@ -1373,7 +1373,7 @@ Tcl_ZlibStreamGet( Tcl_DecrRefCount(zshPtr->currentInput); zshPtr->currentInput = NULL; } - Tcl_ListObjLength(NULL, zshPtr->inData, &listLen); + TclListObjLength_(NULL, zshPtr->inData, &listLen); if (listLen > 0) { /* * There is more input available, get it from the list and @@ -1422,7 +1422,7 @@ Tcl_ZlibStreamGet( e = inflate(&zshPtr->stream, zshPtr->flush); } }; - Tcl_ListObjLength(NULL, zshPtr->inData, &listLen); + TclListObjLength_(NULL, zshPtr->inData, &listLen); while ((zshPtr->stream.avail_out > 0) && (e == Z_OK || e == Z_BUF_ERROR) && (listLen > 0)) { @@ -1502,7 +1502,7 @@ Tcl_ZlibStreamGet( inflateEnd(&zshPtr->stream); } } else { - Tcl_ListObjLength(NULL, zshPtr->outData, &listLen); + TclListObjLength_(NULL, zshPtr->outData, &listLen); if (count == TCL_INDEX_NONE) { count = 0; for (i=0; i dataPos) && - (Tcl_ListObjLength(NULL, zshPtr->outData, &listLen) == TCL_OK) + (TclListObjLength_(NULL, zshPtr->outData, &listLen) == TCL_OK) && (listLen > 0)) { /* * Get the next chunk off our list of chunks and grab the data out diff --git a/win/tclWinDde.c b/win/tclWinDde.c index 2570954..8398677 100644 --- a/win/tclWinDde.c +++ b/win/tclWinDde.c @@ -314,7 +314,8 @@ DdeSetServerName( Tcl_DString dString; const WCHAR *actualName; Tcl_Obj *srvListPtr = NULL, **srvPtrPtr = NULL; - int n, srvCount = 0, lastSuffix, r = TCL_OK; + size_t n, srvCount = 0; + int lastSuffix, r = TCL_OK; ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); /* diff --git a/win/tclWinReg.c b/win/tclWinReg.c index 998521c..0d048ca 100644 --- a/win/tclWinReg.c +++ b/win/tclWinReg.c @@ -1318,7 +1318,7 @@ SetValue( (DWORD) type, (BYTE *) &value, sizeof(DWORD)); } else if (type == REG_MULTI_SZ) { Tcl_DString data, buf; - int objc, i; + size_t objc, i; Tcl_Obj **objv; if (Tcl_ListObjGetElements(interp, dataObj, &objc, &objv) != TCL_OK) { -- cgit v0.12 From 16e6b20816194ac97a6a8adb11ab9ca050ee51d7 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 24 Jan 2022 10:00:06 +0000 Subject: Extend for Tcl dicts too (API only) --- doc/DictObj.3 | 2 +- doc/ListObj.3 | 6 +++--- generic/tcl.decls | 5 ++++- generic/tclDecls.h | 12 +++++++++++- generic/tclStubInit.c | 11 +++++++++++ 5 files changed, 30 insertions(+), 6 deletions(-) diff --git a/doc/DictObj.3 b/doc/DictObj.3 index 0b4c1ca..73b0da8 100644 --- a/doc/DictObj.3 +++ b/doc/DictObj.3 @@ -70,7 +70,7 @@ Points to a variable that will have the value from a key/value pair placed within it. For \fBTcl_DictObjFirst\fR and \fBTcl_DictObjNext\fR, this may be NULL to indicate that the caller is not interested in the value. -.AP int *sizePtr out +.AP size_t | int *sizePtr out Points to a variable that will have the number of key/value pairs contained within the dictionary placed within it. .AP Tcl_DictSearch *searchPtr in/out diff --git a/doc/ListObj.3 b/doc/ListObj.3 index 67721c9..403789d 100644 --- a/doc/ListObj.3 +++ b/doc/ListObj.3 @@ -28,7 +28,7 @@ int \fBTcl_ListObjGetElements\fR(\fIinterp, listPtr, objcPtr, objvPtr\fR) .sp int -\fBTcl_ListObjLength\fR(\fIinterp, listPtr, intPtr\fR) +\fBTcl_ListObjLength\fR(\fIinterp, listPtr, lengthPtr\fR) .sp int \fBTcl_ListObjIndex\fR(\fIinterp, listPtr, index, objPtrPtr\fR) @@ -76,7 +76,7 @@ An array of pointers to values. \fBTcl_NewListObj\fR will insert these values into a new list value and \fBTcl_ListObjReplace\fR will insert them into an existing \fIlistPtr\fR. Each value will become a separate list element. -.AP int *intPtr out +.AP size_t | int *lengthPtr out Points to location where \fBTcl_ListObjLength\fR stores the length of the list. .AP int index in @@ -162,7 +162,7 @@ Otherwise it returns \fBTCL_OK\fR after storing the count and array pointer. .PP \fBTcl_ListObjLength\fR returns the number of elements in the list value referenced by \fIlistPtr\fR. -It returns this count by storing an integer in the address \fIintPtr\fR. +It returns this count by storing a value in the address \fIlengthPtr\fR. If the value is not already a list value, \fBTcl_ListObjLength\fR will attempt to convert it to one; if the conversion fails, it returns \fBTCL_ERROR\fR diff --git a/generic/tcl.decls b/generic/tcl.decls index 249a361..b0d2dd4 100644 --- a/generic/tcl.decls +++ b/generic/tcl.decls @@ -2442,7 +2442,7 @@ declare 660 { int Tcl_AsyncMarkFromSignal(Tcl_AsyncHandler async, int sigNumber) } -# TIP #??? +# TIP #616 declare 661 { int TclListObjGetElements_(Tcl_Interp *interp, Tcl_Obj *listPtr, size_t *objcPtr, Tcl_Obj ***objvPtr) @@ -2451,6 +2451,9 @@ declare 662 { int TclListObjLength_(Tcl_Interp *interp, Tcl_Obj *listPtr, size_t *lengthPtr) } +declare 663 { + int TclDictObjSize_(Tcl_Interp *interp, Tcl_Obj *dictPtr, size_t *sizePtr) +} # ----- BASELINE -- FOR -- 8.7.0 ----- # diff --git a/generic/tclDecls.h b/generic/tclDecls.h index 18f9ed7..d19881d 100644 --- a/generic/tclDecls.h +++ b/generic/tclDecls.h @@ -1955,6 +1955,9 @@ EXTERN int TclListObjGetElements_(Tcl_Interp *interp, /* 662 */ EXTERN int TclListObjLength_(Tcl_Interp *interp, Tcl_Obj *listPtr, size_t *lengthPtr); +/* 663 */ +EXTERN int TclDictObjSize_(Tcl_Interp *interp, Tcl_Obj *dictPtr, + size_t *sizePtr); typedef struct { const struct TclPlatStubs *tclPlatStubs; @@ -2653,6 +2656,7 @@ typedef struct TclStubs { int (*tcl_AsyncMarkFromSignal) (Tcl_AsyncHandler async, int sigNumber); /* 660 */ int (*tclListObjGetElements_) (Tcl_Interp *interp, Tcl_Obj *listPtr, size_t *objcPtr, Tcl_Obj ***objvPtr); /* 661 */ int (*tclListObjLength_) (Tcl_Interp *interp, Tcl_Obj *listPtr, size_t *lengthPtr); /* 662 */ + int (*tclDictObjSize_) (Tcl_Interp *interp, Tcl_Obj *dictPtr, size_t *sizePtr); /* 663 */ } TclStubs; extern const TclStubs *tclStubsPtr; @@ -4007,6 +4011,8 @@ extern const TclStubs *tclStubsPtr; (tclStubsPtr->tclListObjGetElements_) /* 661 */ #define TclListObjLength_ \ (tclStubsPtr->tclListObjLength_) /* 662 */ +#define TclDictObjSize_ \ + (tclStubsPtr->tclDictObjSize_) /* 663 */ #endif /* defined(USE_TCL_STUBS) */ @@ -4285,7 +4291,7 @@ extern const TclStubs *tclStubsPtr; ? (int (*)(const char *, wchar_t *))tclStubsPtr->tcl_UtfToChar16 \ : (int (*)(const char *, wchar_t *))Tcl_UtfToUniChar) # undef Tcl_ListObjGetElements -#ifndef TCL_NO_DEPRECATED +#ifdef TCL_NO_DEPRECATED # define Tcl_ListObjGetElements(interp, listPtr, objcPtr, objvPtr) (sizeof(*objcPtr) == sizeof(int) \ ? tclStubsPtr->tcl_ListObjGetElements((interp), (listPtr), (int *)(void *)(objcPtr), (objvPtr)) \ : tclStubsPtr->tclListObjGetElements_((interp), (listPtr), (size_t *)(void *)(objcPtr), (objvPtr))) @@ -4293,6 +4299,10 @@ extern const TclStubs *tclStubsPtr; # define Tcl_ListObjLength(interp, listPtr, lengthPtr) (sizeof(*lengthPtr) == sizeof(int) \ ? tclStubsPtr->tcl_ListObjLength((interp), (listPtr), (int *)(void *)(lengthPtr)) \ : tclStubsPtr->tclListObjLength_((interp), (listPtr), (size_t *)(void *)(lengthPtr))) +# undef Tcl_DictObjSize +# define Tcl_DictObjSize(interp, dictPtr, sizePtr) (sizeof(*sizePtr) == sizeof(int) \ + ? tclStubsPtr->tcl_DictObjSize((interp), (dictPtr), (int *)(void *)(sizePtr)) \ + : tclStubsPtr->tclDictObjSize_((interp), (dictPtr), (size_t *)(void *)(sizePtr))) #endif /* TCL_NO_DEPRECATED */ #else # define Tcl_WCharToUtfDString (sizeof(wchar_t) != sizeof(short) \ diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c index 836eddc..234805c 100644 --- a/generic/tclStubInit.c +++ b/generic/tclStubInit.c @@ -125,6 +125,7 @@ static const char *TclUtfPrev(const char *src, const char *start) { #define TclListObjGetElements_ LOGetElements #define TclListObjLength_ LOLength +#define TclDictObjSize_ DOSize static int LOGetElements(Tcl_Interp *interp, Tcl_Obj *listPtr, size_t *objcPtr, Tcl_Obj ***objvPtr) { int n; @@ -143,6 +144,15 @@ static int LOLength(Tcl_Interp *interp, Tcl_Obj *listPtr, } return result; } +static int DOSize(Tcl_Interp *interp, Tcl_Obj *dictPtr, + size_t *sizePtr) { + int n; + int result = Tcl_DictObjSize(interp, dictPtr, &n); + if (sizePtr) { + *sizePtr = n; + } + return result; +} #define TclBN_mp_add mp_add #define TclBN_mp_and mp_and @@ -1967,6 +1977,7 @@ const TclStubs tclStubs = { Tcl_AsyncMarkFromSignal, /* 660 */ TclListObjGetElements_, /* 661 */ TclListObjLength_, /* 662 */ + TclDictObjSize_, /* 663 */ }; /* !END!: Do not edit above this line. */ -- cgit v0.12 From bc8c2ad47a5fc72622020a829493e50e449bd040 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 24 Jan 2022 11:01:07 +0000 Subject: Fix another bug in Tcl_GetIntForIndex() (demonstrated by the new testcases from the previous commit) --- generic/tclTest.c | 7 ++++--- generic/tclUtil.c | 2 +- 2 files changed, 5 insertions(+), 4 deletions(-) diff --git a/generic/tclTest.c b/generic/tclTest.c index 95ef5b7..5e6ca8c 100644 --- a/generic/tclTest.c +++ b/generic/tclTest.c @@ -7046,20 +7046,21 @@ TestGetIntForIndexCmd( int objc, Tcl_Obj *const objv[]) { - int result, endvalue; + int result; + Tcl_WideInt endvalue; if (objc != 3) { Tcl_WrongNumArgs(interp, 1, objv, "index endvalue"); return TCL_ERROR; } - if (Tcl_GetIntFromObj(interp, objv[2], &endvalue) != TCL_OK) { + if (Tcl_GetWideIntFromObj(interp, objv[2], &endvalue) != TCL_OK) { return TCL_ERROR; } if (Tcl_GetIntForIndex(interp, objv[1], endvalue, &result) != TCL_OK) { return TCL_ERROR; } - Tcl_SetObjResult(interp, Tcl_NewIntObj(result)); + Tcl_SetObjResult(interp, Tcl_NewWideIntObj(result)); return TCL_OK; } diff --git a/generic/tclUtil.c b/generic/tclUtil.c index 10153fb..e29afcc 100644 --- a/generic/tclUtil.c +++ b/generic/tclUtil.c @@ -3699,7 +3699,7 @@ Tcl_GetIntForIndex( { Tcl_WideInt wide; - if (GetWideForIndex(interp, objPtr, (size_t)(endValue + 1) - 1, &wide) == TCL_ERROR) { + if (GetWideForIndex(interp, objPtr, endValue, &wide) == TCL_ERROR) { return TCL_ERROR; } if (indexPtr != NULL) { -- cgit v0.12 From d46657f1f739cdf35daf961140c922498eb151f7 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 24 Jan 2022 11:15:39 +0000 Subject: Don't document the size_t form of Tcl_GetStringFromObj() (yet), because it's only available if TCL_NO_DEPRECATED is defined --- doc/StringObj.3 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/doc/StringObj.3 b/doc/StringObj.3 index 90b53f2..1b04dd4 100644 --- a/doc/StringObj.3 +++ b/doc/StringObj.3 @@ -121,7 +121,7 @@ the last one available. Points to a value to manipulate. .AP Tcl_Obj *appendObjPtr in The value to append to \fIobjPtr\fR in \fBTcl_AppendObjToObj\fR. -.AP size_t | int *lengthPtr out +.AP int *lengthPtr out The location where \fBTcl_GetStringFromObj\fR will store the length of a value's string representation. May be (int *)NULL when not used. .AP "const char" *string in -- cgit v0.12 From 8997eb06b951e71416f99c512ebed977f8cb61fb Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 24 Jan 2022 11:53:34 +0000 Subject: Tcl Dicts > 2^31 elements too --- doc/DictObj.3 | 2 +- doc/ListObj.3 | 8 ++++---- generic/tcl.decls | 7 +++++-- generic/tclCmdMZ.c | 4 ++-- generic/tclCompCmdsGR.c | 2 +- generic/tclConfig.c | 2 +- generic/tclDecls.h | 18 ++++++++++++++---- generic/tclDictObj.c | 16 +++++++++------- generic/tclEnsemble.c | 2 +- generic/tclExecute.c | 4 ++-- generic/tclListObj.c | 3 ++- generic/tclStringObj.c | 4 ++-- generic/tclStubInit.c | 12 +++++++++++- generic/tclVar.c | 2 +- generic/tclZlib.c | 2 +- 15 files changed, 57 insertions(+), 31 deletions(-) diff --git a/doc/DictObj.3 b/doc/DictObj.3 index 0b4c1ca..73b0da8 100644 --- a/doc/DictObj.3 +++ b/doc/DictObj.3 @@ -70,7 +70,7 @@ Points to a variable that will have the value from a key/value pair placed within it. For \fBTcl_DictObjFirst\fR and \fBTcl_DictObjNext\fR, this may be NULL to indicate that the caller is not interested in the value. -.AP int *sizePtr out +.AP size_t | int *sizePtr out Points to a variable that will have the number of key/value pairs contained within the dictionary placed within it. .AP Tcl_DictSearch *searchPtr in/out diff --git a/doc/ListObj.3 b/doc/ListObj.3 index 948be49..09ab3b7 100644 --- a/doc/ListObj.3 +++ b/doc/ListObj.3 @@ -28,7 +28,7 @@ int \fBTcl_ListObjGetElements\fR(\fIinterp, listPtr, objcPtr, objvPtr\fR) .sp int -\fBTcl_ListObjLength\fR(\fIinterp, listPtr, intPtr\fR) +\fBTcl_ListObjLength\fR(\fIinterp, listPtr, lengthPtr\fR) .sp int \fBTcl_ListObjIndex\fR(\fIinterp, listPtr, index, objPtrPtr\fR) @@ -59,7 +59,7 @@ points to the Tcl value that will be appended to \fIlistPtr\fR. For \fBTcl_SetListObj\fR, this points to the Tcl value that will be converted to a list value containing the \fIobjc\fR elements of the array referenced by \fIobjv\fR. -.AP int|size_t *objcPtr in +.AP size_t | int *objcPtr in Points to location where \fBTcl_ListObjGetElements\fR stores the number of element values in \fIlistPtr\fR. .AP Tcl_Obj ***objvPtr out @@ -76,7 +76,7 @@ An array of pointers to values. \fBTcl_NewListObj\fR will insert these values into a new list value and \fBTcl_ListObjReplace\fR will insert them into an existing \fIlistPtr\fR. Each value will become a separate list element. -.AP int|size_t *intPtr out +.AP size_t | int *lengthPtr out Points to location where \fBTcl_ListObjLength\fR stores the length of the list. .AP size_t index in @@ -162,7 +162,7 @@ Otherwise it returns \fBTCL_OK\fR after storing the count and array pointer. .PP \fBTcl_ListObjLength\fR returns the number of elements in the list value referenced by \fIlistPtr\fR. -It returns this count by storing an integer in the address \fIintPtr\fR. +It returns this count by storing a value in the address \fIlengthPtr\fR. If the value is not already a list value, \fBTcl_ListObjLength\fR will attempt to convert it to one; if the conversion fails, it returns \fBTCL_ERROR\fR diff --git a/generic/tcl.decls b/generic/tcl.decls index 033d506..9b572ff 100644 --- a/generic/tcl.decls +++ b/generic/tcl.decls @@ -1841,7 +1841,7 @@ declare 496 { Tcl_Obj *keyPtr) } declare 497 { - int Tcl_DictObjSize(Tcl_Interp *interp, Tcl_Obj *dictPtr, int *sizePtr) + int TclDictObjSize_(Tcl_Interp *interp, Tcl_Obj *dictPtr, int *sizePtr) } declare 498 { int Tcl_DictObjFirst(Tcl_Interp *interp, Tcl_Obj *dictPtr, @@ -2505,7 +2505,7 @@ declare 660 { int Tcl_AsyncMarkFromSignal(Tcl_AsyncHandler async, int sigNumber) } -# TIP #??? +# TIP #616 declare 661 { int Tcl_ListObjGetElements(Tcl_Interp *interp, Tcl_Obj *listPtr, size_t *objcPtr, Tcl_Obj ***objvPtr) @@ -2514,6 +2514,9 @@ declare 662 { int Tcl_ListObjLength(Tcl_Interp *interp, Tcl_Obj *listPtr, size_t *lengthPtr) } +declare 663 { + int Tcl_DictObjSize(Tcl_Interp *interp, Tcl_Obj *dictPtr, size_t *sizePtr) +} # ----- BASELINE -- FOR -- 8.7.0 ----- # diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c index bff2998..573d653 100644 --- a/generic/tclCmdMZ.c +++ b/generic/tclCmdMZ.c @@ -1633,7 +1633,7 @@ StringIsCmd( case STR_IS_DICT: { int dresult, dsize; - dresult = Tcl_DictObjSize(interp, objPtr, &dsize); + dresult = TclDictObjSize_(interp, objPtr, &dsize); Tcl_ResetResult(interp); result = (dresult == TCL_OK) ? 1 : 0; if (dresult != TCL_OK && failVarObj != NULL) { @@ -2002,7 +2002,7 @@ StringMapCmd( * sure. This shortens this code quite a bit. */ - Tcl_DictObjSize(interp, objv[objc-2], &i); + TclDictObjSize_(interp, objv[objc-2], &i); if (i == 0) { /* * Empty charMap, just return whatever string was given. diff --git a/generic/tclCompCmdsGR.c b/generic/tclCompCmdsGR.c index ecd087e..46d39be 100644 --- a/generic/tclCompCmdsGR.c +++ b/generic/tclCompCmdsGR.c @@ -2529,7 +2529,7 @@ TclCompileReturnCmd( } /* Optimize [return -level 0 $x]. */ - Tcl_DictObjSize(NULL, returnOpts, &size); + TclDictObjSize_(NULL, returnOpts, &size); if (size == 0 && level == 0 && code == TCL_OK) { Tcl_DecrRefCount(returnOpts); return TCL_OK; diff --git a/generic/tclConfig.c b/generic/tclConfig.c index 09b1b27..9d41a45 100644 --- a/generic/tclConfig.c +++ b/generic/tclConfig.c @@ -272,7 +272,7 @@ QueryConfigObjCmd( return TCL_ERROR; } - Tcl_DictObjSize(interp, pkgDict, &m); + TclDictObjSize_(interp, pkgDict, &m); listPtr = Tcl_NewListObj(m, NULL); if (!listPtr) { diff --git a/generic/tclDecls.h b/generic/tclDecls.h index b7d88df..d354969 100644 --- a/generic/tclDecls.h +++ b/generic/tclDecls.h @@ -1293,7 +1293,7 @@ EXTERN int Tcl_DictObjGet(Tcl_Interp *interp, Tcl_Obj *dictPtr, EXTERN int Tcl_DictObjRemove(Tcl_Interp *interp, Tcl_Obj *dictPtr, Tcl_Obj *keyPtr); /* 497 */ -EXTERN int Tcl_DictObjSize(Tcl_Interp *interp, Tcl_Obj *dictPtr, +EXTERN int TclDictObjSize_(Tcl_Interp *interp, Tcl_Obj *dictPtr, int *sizePtr); /* 498 */ EXTERN int Tcl_DictObjFirst(Tcl_Interp *interp, @@ -1764,6 +1764,9 @@ EXTERN int Tcl_ListObjGetElements(Tcl_Interp *interp, /* 662 */ EXTERN int Tcl_ListObjLength(Tcl_Interp *interp, Tcl_Obj *listPtr, size_t *lengthPtr); +/* 663 */ +EXTERN int Tcl_DictObjSize(Tcl_Interp *interp, Tcl_Obj *dictPtr, + size_t *sizePtr); typedef struct { const struct TclPlatStubs *tclPlatStubs; @@ -2272,7 +2275,7 @@ typedef struct TclStubs { int (*tcl_DictObjPut) (Tcl_Interp *interp, Tcl_Obj *dictPtr, Tcl_Obj *keyPtr, Tcl_Obj *valuePtr); /* 494 */ int (*tcl_DictObjGet) (Tcl_Interp *interp, Tcl_Obj *dictPtr, Tcl_Obj *keyPtr, Tcl_Obj **valuePtrPtr); /* 495 */ int (*tcl_DictObjRemove) (Tcl_Interp *interp, Tcl_Obj *dictPtr, Tcl_Obj *keyPtr); /* 496 */ - int (*tcl_DictObjSize) (Tcl_Interp *interp, Tcl_Obj *dictPtr, int *sizePtr); /* 497 */ + int (*tclDictObjSize_) (Tcl_Interp *interp, Tcl_Obj *dictPtr, int *sizePtr); /* 497 */ int (*tcl_DictObjFirst) (Tcl_Interp *interp, Tcl_Obj *dictPtr, Tcl_DictSearch *searchPtr, Tcl_Obj **keyPtrPtr, Tcl_Obj **valuePtrPtr, int *donePtr); /* 498 */ void (*tcl_DictObjNext) (Tcl_DictSearch *searchPtr, Tcl_Obj **keyPtrPtr, Tcl_Obj **valuePtrPtr, int *donePtr); /* 499 */ void (*tcl_DictObjDone) (Tcl_DictSearch *searchPtr); /* 500 */ @@ -2438,6 +2441,7 @@ typedef struct TclStubs { int (*tcl_AsyncMarkFromSignal) (Tcl_AsyncHandler async, int sigNumber); /* 660 */ int (*tcl_ListObjGetElements) (Tcl_Interp *interp, Tcl_Obj *listPtr, size_t *objcPtr, Tcl_Obj ***objvPtr); /* 661 */ int (*tcl_ListObjLength) (Tcl_Interp *interp, Tcl_Obj *listPtr, size_t *lengthPtr); /* 662 */ + int (*tcl_DictObjSize) (Tcl_Interp *interp, Tcl_Obj *dictPtr, size_t *sizePtr); /* 663 */ } TclStubs; extern const TclStubs *tclStubsPtr; @@ -3383,8 +3387,8 @@ extern const TclStubs *tclStubsPtr; (tclStubsPtr->tcl_DictObjGet) /* 495 */ #define Tcl_DictObjRemove \ (tclStubsPtr->tcl_DictObjRemove) /* 496 */ -#define Tcl_DictObjSize \ - (tclStubsPtr->tcl_DictObjSize) /* 497 */ +#define TclDictObjSize_ \ + (tclStubsPtr->tclDictObjSize_) /* 497 */ #define Tcl_DictObjFirst \ (tclStubsPtr->tcl_DictObjFirst) /* 498 */ #define Tcl_DictObjNext \ @@ -3712,6 +3716,8 @@ extern const TclStubs *tclStubsPtr; (tclStubsPtr->tcl_ListObjGetElements) /* 661 */ #define Tcl_ListObjLength \ (tclStubsPtr->tcl_ListObjLength) /* 662 */ +#define Tcl_DictObjSize \ + (tclStubsPtr->tcl_DictObjSize) /* 663 */ #endif /* defined(USE_TCL_STUBS) */ @@ -3917,6 +3923,10 @@ extern const TclStubs *tclStubsPtr; # define Tcl_ListObjLength(interp, listPtr, lengthPtr) (sizeof(*lengthPtr) != sizeof(int) \ ? tclStubsPtr->tcl_ListObjLength((interp), (listPtr), (int *)(void *)(lengthPtr)) \ : tclStubsPtr->tclListObjLength_((interp), (listPtr), (size_t *)(void *)(lengthPtr))) +# undef Tcl_DictObjSize +# define Tcl_DictObjSize(interp, dictPtr, sizePtr) (sizeof(*sizePtr) != sizeof(int) \ + ? tclStubsPtr->tcl_DictObjSize((interp), (dictPtr), (int *)(void *)(sizePtr)) \ + : tclStubsPtr->tclDictObjSize_((interp), (dictPtr), (size_t *)(void *)(sizePtr))) #endif /* TCL_NO_DEPRECATED */ #else # define Tcl_WCharToUtfDString (sizeof(wchar_t) != sizeof(short) \ diff --git a/generic/tclDictObj.c b/generic/tclDictObj.c index cf82ac8..a124a32 100644 --- a/generic/tclDictObj.c +++ b/generic/tclDictObj.c @@ -1065,7 +1065,7 @@ int Tcl_DictObjSize( Tcl_Interp *interp, Tcl_Obj *dictPtr, - int *sizePtr) + size_t *sizePtr) { Dict *dict; @@ -2021,7 +2021,8 @@ DictSizeCmd( int objc, Tcl_Obj *const *objv) { - int result, size; + int result; + size_t size; if (objc != 2) { Tcl_WrongNumArgs(interp, 1, objv, "dictionary"); @@ -3268,7 +3269,8 @@ DictUpdateCmd( { Interp *iPtr = (Interp *) interp; Tcl_Obj *dictPtr, *objPtr; - int i, dummy; + int i; + size_t dummy; if (objc < 5 || !(objc & 1)) { Tcl_WrongNumArgs(interp, 1, objv, @@ -3321,7 +3323,7 @@ FinalizeDictUpdate( { Tcl_Obj *dictPtr, *objPtr, **objv; Tcl_InterpState state; - int i, objc; + size_t i, objc; Tcl_Obj *varName = (Tcl_Obj *)data[0]; Tcl_Obj *argsObj = (Tcl_Obj *)data[1]; @@ -3365,7 +3367,7 @@ FinalizeDictUpdate( * an instruction to remove the key. */ - TclListObjGetElements_(NULL, argsObj, &objc, &objv); + Tcl_ListObjGetElements(NULL, argsObj, &objc, &objv); for (i=0 ; i ", O2S(dictPtr))); - if (Tcl_DictObjSize(interp, dictPtr, &done) != TCL_OK) { + if (TclDictObjSize_(interp, dictPtr, &done) != TCL_OK) { TRACE_APPEND(("ERROR verifying dictionary nature of \"%.30s\": %s\n", O2S(dictPtr), O2S(Tcl_GetObjResult(interp)))); goto gotError; @@ -6996,7 +6996,7 @@ TEBCresume( TRACE_APPEND(("storage was unset\n")); NEXT_INST_F(9, 1, 0); } - if (Tcl_DictObjSize(interp, dictPtr, &length) != TCL_OK + if (TclDictObjSize_(interp, dictPtr, &length) != TCL_OK || TclListObjGetElements_(interp, OBJ_AT_TOS, &length, &keyPtrPtr) != TCL_OK) { TRACE_ERROR(interp); diff --git a/generic/tclListObj.c b/generic/tclListObj.c index 747cf0d..37392e4 100644 --- a/generic/tclListObj.c +++ b/generic/tclListObj.c @@ -1961,7 +1961,8 @@ SetListFromAny( if (!TclHasStringRep(objPtr) && TclHasInternalRep(objPtr, &tclDictType)) { Tcl_Obj *keyPtr, *valuePtr; Tcl_DictSearch search; - int done, size; + int done; + size_t size; /* * Create the new list representation. Note that we do not need to do diff --git a/generic/tclStringObj.c b/generic/tclStringObj.c index b52e33c..65c9983 100644 --- a/generic/tclStringObj.c +++ b/generic/tclStringObj.c @@ -466,14 +466,14 @@ int TclCheckEmptyString( Tcl_Obj *objPtr) { - int length = -1; + size_t length = TCL_INDEX_NONE; if (objPtr->bytes == &tclEmptyString) { return TCL_EMPTYSTRING_YES; } if (TclListObjIsCanonical(objPtr)) { - TclListObjLength_(NULL, objPtr, &length); + Tcl_ListObjLength(NULL, objPtr, &length); return length == 0; } diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c index 6885e07..98d0d21 100644 --- a/generic/tclStubInit.c +++ b/generic/tclStubInit.c @@ -104,6 +104,15 @@ int TclListObjLength_(Tcl_Interp *interp, Tcl_Obj *listPtr, } return result; } +int TclDictObjSize_(Tcl_Interp *interp, Tcl_Obj *dictPtr, + int *sizePtr) { + size_t n; + int result = Tcl_DictObjSize(interp, dictPtr, &n); + if (sizePtr) { + *sizePtr = n; + } + return result; +} #define TclBN_mp_add mp_add #define TclBN_mp_add_d mp_add_d @@ -1206,7 +1215,7 @@ const TclStubs tclStubs = { Tcl_DictObjPut, /* 494 */ Tcl_DictObjGet, /* 495 */ Tcl_DictObjRemove, /* 496 */ - Tcl_DictObjSize, /* 497 */ + TclDictObjSize_, /* 497 */ Tcl_DictObjFirst, /* 498 */ Tcl_DictObjNext, /* 499 */ Tcl_DictObjDone, /* 500 */ @@ -1372,6 +1381,7 @@ const TclStubs tclStubs = { Tcl_AsyncMarkFromSignal, /* 660 */ Tcl_ListObjGetElements, /* 661 */ Tcl_ListObjLength, /* 662 */ + Tcl_DictObjSize, /* 663 */ }; /* !END!: Do not edit above this line. */ diff --git a/generic/tclVar.c b/generic/tclVar.c index e9c0134..fe6fda3 100644 --- a/generic/tclVar.c +++ b/generic/tclVar.c @@ -3974,7 +3974,7 @@ ArraySetCmd( Tcl_DictSearch search; int done; - if (Tcl_DictObjSize(interp, arrayElemObj, &done) != TCL_OK) { + if (TclDictObjSize_(interp, arrayElemObj, &done) != TCL_OK) { return TCL_ERROR; } if (done == 0) { diff --git a/generic/tclZlib.c b/generic/tclZlib.c index b874750..89ffc47 100644 --- a/generic/tclZlib.c +++ b/generic/tclZlib.c @@ -2492,7 +2492,7 @@ ZlibPushSubcmd( switch ((enum pushOptionsEnum) option) { case poHeader: headerObj = objv[i]; - if (Tcl_DictObjSize(interp, headerObj, &dummy) != TCL_OK) { + if (TclDictObjSize_(interp, headerObj, &dummy) != TCL_OK) { goto genericOptionError; } break; -- cgit v0.12 From 875e3b392ba9b930fa009077b451b08f15b4ea72 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 24 Jan 2022 15:23:21 +0000 Subject: change signature for Tcl_DictObjPutKeyList and Tcl_DictObjRemoveKeyList too --- generic/tcl.decls | 4 ++-- generic/tclCmdMZ.c | 48 ++++++++++++++++++++++++++---------------------- generic/tclCompCmdsGR.c | 5 +++-- generic/tclConfig.c | 6 +++--- generic/tclDecls.h | 8 ++++---- generic/tclDictObj.c | 37 ++++++++++++++++++++----------------- generic/tclEnsemble.c | 13 +++++++------ generic/tclExecute.c | 26 +++++++++++++++----------- generic/tclInt.decls | 2 +- generic/tclIntDecls.h | 4 ++-- generic/tclVar.c | 35 ++++++++++++++++++++--------------- generic/tclZipfs.c | 6 +++--- generic/tclZlib.c | 17 +++++++++-------- 13 files changed, 115 insertions(+), 96 deletions(-) diff --git a/generic/tcl.decls b/generic/tcl.decls index 9b572ff..6a969d7 100644 --- a/generic/tcl.decls +++ b/generic/tcl.decls @@ -1857,11 +1857,11 @@ declare 500 { } declare 501 { int Tcl_DictObjPutKeyList(Tcl_Interp *interp, Tcl_Obj *dictPtr, - int keyc, Tcl_Obj *const *keyv, Tcl_Obj *valuePtr) + size_t keyc, Tcl_Obj *const *keyv, Tcl_Obj *valuePtr) } declare 502 { int Tcl_DictObjRemoveKeyList(Tcl_Interp *interp, Tcl_Obj *dictPtr, - int keyc, Tcl_Obj *const *keyv) + size_t keyc, Tcl_Obj *const *keyv) } declare 503 { Tcl_Obj *Tcl_NewDictObj(void) diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c index 573d653..6ef3220 100644 --- a/generic/tclCmdMZ.c +++ b/generic/tclCmdMZ.c @@ -487,8 +487,8 @@ Tcl_RegsubObjCmd( int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - int result, cflags, all, match, command, numParts; - size_t idx, wlen, wsublen = 0, offset, numMatches; + int result, cflags, all, match, command; + size_t idx, wlen, wsublen = 0, offset, numMatches, numParts; size_t start, end, subStart, subEnd; Tcl_RegExp regExpr; Tcl_RegExpInfo info; @@ -675,7 +675,7 @@ Tcl_RegsubObjCmd( * object. (If they aren't, that's cheap to do.) */ - if (TclListObjLength_(interp, objv[2], &numParts) != TCL_OK) { + if (Tcl_ListObjLength(interp, objv[2], &numParts) != TCL_OK) { return TCL_ERROR; } if (numParts < 1) { @@ -775,9 +775,9 @@ Tcl_RegsubObjCmd( if (command) { Tcl_Obj **args = NULL, **parts; - int numArgs; + size_t numArgs; - TclListObjGetElements_(interp, subPtr, &numParts, &parts); + Tcl_ListObjGetElements(interp, subPtr, &numParts, &parts); numArgs = numParts + info.nsubs + 1; args = (Tcl_Obj **)Tcl_Alloc(sizeof(Tcl_Obj*) * numArgs); memcpy(args, parts, sizeof(Tcl_Obj*) * numParts); @@ -1631,9 +1631,10 @@ StringIsCmd( chcomp = Tcl_UniCharIsControl; break; case STR_IS_DICT: { - int dresult, dsize; + int dresult; + size_t dsize; - dresult = TclDictObjSize_(interp, objPtr, &dsize); + dresult = Tcl_DictObjSize(interp, objPtr, &dsize); Tcl_ResetResult(interp); result = (dresult == TCL_OK) ? 1 : 0; if (dresult != TCL_OK && failVarObj != NULL) { @@ -1994,7 +1995,8 @@ StringMapCmd( if (!TclHasStringRep(objv[objc-2]) && TclHasInternalRep(objv[objc-2], &tclDictType)) { - int i, done; + size_t i; + int done; Tcl_DictSearch search; /* @@ -2002,7 +2004,7 @@ StringMapCmd( * sure. This shortens this code quite a bit. */ - TclDictObjSize_(interp, objv[objc-2], &i); + Tcl_DictObjSize(interp, objv[objc-2], &i); if (i == 0) { /* * Empty charMap, just return whatever string was given. @@ -2028,8 +2030,8 @@ StringMapCmd( } Tcl_DictObjDone(&search); } else { - int i; - if (TclListObjGetElements_(interp, objv[objc-2], &i, + size_t i; + if (Tcl_ListObjGetElements(interp, objv[objc-2], &i, &mapElemv) != TCL_OK) { return TCL_ERROR; } @@ -3576,9 +3578,10 @@ TclNRSwitchObjCmd( splitObjs = 0; if (objc == 1) { Tcl_Obj **listv; + size_t listc; blist = objv[0]; - if (TclListObjGetElements_(interp, objv[0], &objc, &listv) != TCL_OK) { + if (Tcl_ListObjGetElements(interp, objv[0], &listc, &listv) != TCL_OK) { return TCL_ERROR; } @@ -3586,11 +3589,12 @@ TclNRSwitchObjCmd( * Ensure that the list is non-empty. */ - if (objc < 1) { + if (listc < 1 || listc > INT_MAX) { Tcl_WrongNumArgs(interp, 1, savedObjv, "?-option ...? string {?pattern body ...? ?default body?}"); return TCL_ERROR; } + objc = listc; objv = listv; splitObjs = 1; } @@ -4865,8 +4869,8 @@ TryPostBody( int result) { Tcl_Obj *resultObj, *options, *handlersObj, *finallyObj, *cmdObj, **objv; - int i, code, objc; - int numHandlers = 0; + int code, objc; + size_t i, numHandlers = 0; handlersObj = (Tcl_Obj *)data[0]; finallyObj = (Tcl_Obj *)data[1]; @@ -4913,12 +4917,12 @@ TryPostBody( int found = 0; Tcl_Obj **handlers, **info; - TclListObjGetElements_(NULL, handlersObj, &numHandlers, &handlers); + Tcl_ListObjGetElements(NULL, handlersObj, &numHandlers, &handlers); for (i=0 ; i 0) { Tcl_Obj *varName; diff --git a/generic/tclCompCmdsGR.c b/generic/tclCompCmdsGR.c index 46d39be..bb1c21b 100644 --- a/generic/tclCompCmdsGR.c +++ b/generic/tclCompCmdsGR.c @@ -2399,7 +2399,8 @@ TclCompileReturnCmd( * General syntax: [return ?-option value ...? ?result?] * An even number of words means an explicit result argument is present. */ - int level, code, objc, size, status = TCL_OK; + int level, code, objc, status = TCL_OK; + size_t size; int numWords = parsePtr->numWords; int explicitResult = (0 == (numWords % 2)); int numOptionWords = numWords - 1 - explicitResult; @@ -2529,7 +2530,7 @@ TclCompileReturnCmd( } /* Optimize [return -level 0 $x]. */ - TclDictObjSize_(NULL, returnOpts, &size); + Tcl_DictObjSize(NULL, returnOpts, &size); if (size == 0 && level == 0 && code == TCL_OK) { Tcl_DecrRefCount(returnOpts); return TCL_OK; diff --git a/generic/tclConfig.c b/generic/tclConfig.c index 9d41a45..08d5f1b 100644 --- a/generic/tclConfig.c +++ b/generic/tclConfig.c @@ -199,8 +199,8 @@ QueryConfigObjCmd( QCCD *cdPtr = (QCCD *)clientData; Tcl_Obj *pkgName = cdPtr->pkg; Tcl_Obj *pDB, *pkgDict, *val, *listPtr; - size_t n = 0; - int index, m; + size_t m, n = 0; + int index; static const char *const subcmdStrings[] = { "get", "list", NULL }; @@ -272,7 +272,7 @@ QueryConfigObjCmd( return TCL_ERROR; } - TclDictObjSize_(interp, pkgDict, &m); + Tcl_DictObjSize(interp, pkgDict, &m); listPtr = Tcl_NewListObj(m, NULL); if (!listPtr) { diff --git a/generic/tclDecls.h b/generic/tclDecls.h index d354969..e83a8de 100644 --- a/generic/tclDecls.h +++ b/generic/tclDecls.h @@ -1308,11 +1308,11 @@ EXTERN void Tcl_DictObjNext(Tcl_DictSearch *searchPtr, EXTERN void Tcl_DictObjDone(Tcl_DictSearch *searchPtr); /* 501 */ EXTERN int Tcl_DictObjPutKeyList(Tcl_Interp *interp, - Tcl_Obj *dictPtr, int keyc, + Tcl_Obj *dictPtr, size_t keyc, Tcl_Obj *const *keyv, Tcl_Obj *valuePtr); /* 502 */ EXTERN int Tcl_DictObjRemoveKeyList(Tcl_Interp *interp, - Tcl_Obj *dictPtr, int keyc, + Tcl_Obj *dictPtr, size_t keyc, Tcl_Obj *const *keyv); /* 503 */ EXTERN Tcl_Obj * Tcl_NewDictObj(void); @@ -2279,8 +2279,8 @@ typedef struct TclStubs { int (*tcl_DictObjFirst) (Tcl_Interp *interp, Tcl_Obj *dictPtr, Tcl_DictSearch *searchPtr, Tcl_Obj **keyPtrPtr, Tcl_Obj **valuePtrPtr, int *donePtr); /* 498 */ void (*tcl_DictObjNext) (Tcl_DictSearch *searchPtr, Tcl_Obj **keyPtrPtr, Tcl_Obj **valuePtrPtr, int *donePtr); /* 499 */ void (*tcl_DictObjDone) (Tcl_DictSearch *searchPtr); /* 500 */ - int (*tcl_DictObjPutKeyList) (Tcl_Interp *interp, Tcl_Obj *dictPtr, int keyc, Tcl_Obj *const *keyv, Tcl_Obj *valuePtr); /* 501 */ - int (*tcl_DictObjRemoveKeyList) (Tcl_Interp *interp, Tcl_Obj *dictPtr, int keyc, Tcl_Obj *const *keyv); /* 502 */ + int (*tcl_DictObjPutKeyList) (Tcl_Interp *interp, Tcl_Obj *dictPtr, size_t keyc, Tcl_Obj *const *keyv, Tcl_Obj *valuePtr); /* 501 */ + int (*tcl_DictObjRemoveKeyList) (Tcl_Interp *interp, Tcl_Obj *dictPtr, size_t keyc, Tcl_Obj *const *keyv); /* 502 */ Tcl_Obj * (*tcl_NewDictObj) (void); /* 503 */ Tcl_Obj * (*tcl_DbNewDictObj) (const char *file, int line); /* 504 */ void (*tcl_RegisterConfig) (Tcl_Interp *interp, const char *pkgName, const Tcl_Config *configuration, const char *valEncoding); /* 505 */ diff --git a/generic/tclDictObj.c b/generic/tclDictObj.c index a124a32..1e1d1eb 100644 --- a/generic/tclDictObj.c +++ b/generic/tclDictObj.c @@ -602,11 +602,11 @@ SetDictFromAny( */ if (TclHasInternalRep(objPtr, &tclListType)) { - int objc, i; + size_t objc, i; Tcl_Obj **objv; /* Cannot fail, we already know the Tcl_ObjType is "list". */ - TclListObjGetElements_(NULL, objPtr, &objc, &objv); + Tcl_ListObjGetElements(NULL, objPtr, &objc, &objv); if (objc & 1) { goto missingValue; } @@ -777,12 +777,12 @@ Tcl_Obj * TclTraceDictPath( Tcl_Interp *interp, Tcl_Obj *dictPtr, - int keyc, + size_t keyc, Tcl_Obj *const keyv[], int flags) { Dict *dict, *newDict; - int i; + size_t i; DictGetInternalRep(dictPtr, dict); if (dict == NULL) { @@ -1278,7 +1278,7 @@ int Tcl_DictObjPutKeyList( Tcl_Interp *interp, Tcl_Obj *dictPtr, - int keyc, + size_t keyc, Tcl_Obj *const keyv[], Tcl_Obj *valuePtr) { @@ -1289,7 +1289,7 @@ Tcl_DictObjPutKeyList( if (Tcl_IsShared(dictPtr)) { Tcl_Panic("%s called with shared object", "Tcl_DictObjPutKeyList"); } - if (keyc < 1) { + if (keyc + 1 < 2) { Tcl_Panic("%s called with empty key list", "Tcl_DictObjPutKeyList"); } @@ -1339,7 +1339,7 @@ int Tcl_DictObjRemoveKeyList( Tcl_Interp *interp, Tcl_Obj *dictPtr, - int keyc, + size_t keyc, Tcl_Obj *const keyv[]) { Dict *dict; @@ -2460,7 +2460,8 @@ DictForNRCmd( Tcl_Obj *scriptObj, *keyVarObj, *valueVarObj; Tcl_Obj **varv, *keyObj, *valueObj; Tcl_DictSearch *searchPtr; - int varc, done; + size_t varc; + int done; if (objc != 4) { Tcl_WrongNumArgs(interp, 1, objv, @@ -2472,7 +2473,7 @@ DictForNRCmd( * Parse arguments. */ - if (TclListObjGetElements_(interp, objv[1], &varc, &varv) != TCL_OK) { + if (Tcl_ListObjGetElements(interp, objv[1], &varc, &varv) != TCL_OK) { return TCL_ERROR; } if (varc != 2) { @@ -2491,7 +2492,7 @@ DictForNRCmd( TclStackFree(interp, searchPtr); return TCL_OK; } - TclListObjGetElements_(NULL, objv[1], &varc, &varv); + Tcl_ListObjGetElements(NULL, objv[1], &varc, &varv); keyVarObj = varv[0]; valueVarObj = varv[1]; scriptObj = objv[3]; @@ -2654,7 +2655,8 @@ DictMapNRCmd( Interp *iPtr = (Interp *) interp; Tcl_Obj **varv, *keyObj, *valueObj; DictMapStorage *storagePtr; - int varc, done; + size_t varc; + int done; if (objc != 4) { Tcl_WrongNumArgs(interp, 1, objv, @@ -2666,7 +2668,7 @@ DictMapNRCmd( * Parse arguments. */ - if (TclListObjGetElements_(interp, objv[1], &varc, &varv) != TCL_OK) { + if (Tcl_ListObjGetElements(interp, objv[1], &varc, &varv) != TCL_OK) { return TCL_ERROR; } if (varc != 2) { @@ -2692,7 +2694,7 @@ DictMapNRCmd( return TCL_OK; } TclNewObj(storagePtr->accumulatorObj); - TclListObjGetElements_(NULL, objv[1], &varc, &varv); + Tcl_ListObjGetElements(NULL, objv[1], &varc, &varv); storagePtr->keyVarObj = varv[0]; storagePtr->valueVarObj = varv[1]; storagePtr->scriptObj = objv[3]; @@ -2992,7 +2994,8 @@ DictFilterCmd( Tcl_Obj *scriptObj, *keyVarObj, *valueVarObj; Tcl_Obj **varv, *keyObj = NULL, *valueObj = NULL, *resultObj, *boolObj; Tcl_DictSearch search; - int index, varc, done, result, satisfied; + int index, done, result, satisfied; + size_t varc; const char *pattern; if (objc < 3) { @@ -3105,7 +3108,7 @@ DictFilterCmd( * copying from the "dict for" implementation has occurred! */ - if (TclListObjGetElements_(interp, objv[3], &varc, &varv) != TCL_OK) { + if (Tcl_ListObjGetElements(interp, objv[3], &varc, &varv) != TCL_OK) { return TCL_ERROR; } if (varc != 2) { @@ -3473,7 +3476,7 @@ FinalizeDictWith( int result) { Tcl_Obj **pathv; - int pathc; + size_t pathc; Tcl_InterpState state; Tcl_Obj *varName = (Tcl_Obj *)data[0]; Tcl_Obj *keysPtr = (Tcl_Obj *)data[1]; @@ -3491,7 +3494,7 @@ FinalizeDictWith( state = Tcl_SaveInterpState(interp, result); if (pathPtr != NULL) { - TclListObjGetElements_(NULL, pathPtr, &pathc, &pathv); + Tcl_ListObjGetElements(NULL, pathPtr, &pathc, &pathv); } else { pathc = 0; pathv = NULL; diff --git a/generic/tclEnsemble.c b/generic/tclEnsemble.c index 49ac9af..4131651 100644 --- a/generic/tclEnsemble.c +++ b/generic/tclEnsemble.c @@ -940,11 +940,12 @@ Tcl_SetEnsembleMappingDict( return TCL_ERROR; } if (mapDict != NULL) { - int size, done; + size_t size; + int done; Tcl_DictSearch search; Tcl_Obj *valuePtr; - if (TclDictObjSize_(interp, mapDict, &size) != TCL_OK) { + if (Tcl_DictObjSize(interp, mapDict, &size) != TCL_OK) { return TCL_ERROR; } @@ -3377,8 +3378,8 @@ CompileToInvokedCommand( Tcl_Token *tokPtr; Tcl_Obj *objPtr, **words; const char *bytes; - int i, numWords, cmdLit, extraLiteralFlags = LITERAL_CMD_NAME; - size_t length; + int i, cmdLit, extraLiteralFlags = LITERAL_CMD_NAME; + size_t numWords, length; /* * Push the words of the command. Take care; the command words may be @@ -3386,10 +3387,10 @@ CompileToInvokedCommand( * difference. Hence the call to TclContinuationsEnterDerived... */ - TclListObjGetElements_(NULL, replacements, &numWords, &words); + Tcl_ListObjGetElements(NULL, replacements, &numWords, &words); for (i = 0, tokPtr = parsePtr->tokenPtr; i < parsePtr->numWords; i++, tokPtr = TokenAfter(tokPtr)) { - if (i > 0 && i < numWords+1) { + if (i > 0 && (size_t)i <= numWords) { bytes = Tcl_GetStringFromObj(words[i-1], &length); PushLiteral(envPtr, bytes, length); continue; diff --git a/generic/tclExecute.c b/generic/tclExecute.c index 3691b28..e0ac6336 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -2049,7 +2049,8 @@ TEBCresume( Tcl_Obj *objPtr, *valuePtr, *value2Ptr, *part1Ptr, *part2Ptr, *tmpPtr; Tcl_Obj **objv = NULL; int objc = 0; - int opnd, length, pcAdjustment; + int opnd, pcAdjustment; + size_t length; Var *varPtr, *arrayPtr; #ifdef TCL_COMPILE_DEBUG char cmdNameBuf[21]; @@ -4636,7 +4637,7 @@ TEBCresume( case INST_LIST_LENGTH: TRACE(("\"%.30s\" => ", O2S(OBJ_AT_TOS))); - if (TclListObjLength_(interp, OBJ_AT_TOS, &length) != TCL_OK) { + if (Tcl_ListObjLength(interp, OBJ_AT_TOS, &length) != TCL_OK) { TRACE_ERROR(interp); goto gotError; } @@ -4902,13 +4903,13 @@ TEBCresume( s1 = Tcl_GetStringFromObj(valuePtr, &s1len); TRACE(("\"%.30s\" \"%.30s\" => ", O2S(valuePtr), O2S(value2Ptr))); - if (TclListObjLength_(interp, value2Ptr, &length) != TCL_OK) { + if (Tcl_ListObjLength(interp, value2Ptr, &length) != TCL_OK) { TRACE_ERROR(interp); goto gotError; } match = 0; if (length > 0) { - int i = 0; + size_t i = 0; Tcl_Obj *o; /* @@ -6483,22 +6484,25 @@ TEBCresume( */ { - int opnd2, allocateDict, done, i, allocdict; + int opnd2, allocateDict, done, allocdict; + size_t i; Tcl_Obj *dictPtr, *statePtr, *keyPtr, *listPtr, *varNamePtr, *keysPtr; Tcl_Obj *emptyPtr, **keyPtrPtr; Tcl_DictSearch *searchPtr; DictUpdateInfo *duiPtr; - case INST_DICT_VERIFY: + case INST_DICT_VERIFY: { + size_t size; dictPtr = OBJ_AT_TOS; TRACE(("\"%.30s\" => ", O2S(dictPtr))); - if (TclDictObjSize_(interp, dictPtr, &done) != TCL_OK) { + if (Tcl_DictObjSize(interp, dictPtr, &size) != TCL_OK) { TRACE_APPEND(("ERROR verifying dictionary nature of \"%.30s\": %s\n", O2S(dictPtr), O2S(Tcl_GetObjResult(interp)))); goto gotError; } TRACE_APPEND(("OK\n")); NEXT_INST_F(1, 1, 0); + } break; case INST_DICT_EXISTS: { @@ -6937,12 +6941,12 @@ TEBCresume( } } Tcl_IncrRefCount(dictPtr); - if (TclListObjGetElements_(interp, OBJ_AT_TOS, &length, + if (Tcl_ListObjGetElements(interp, OBJ_AT_TOS, &length, &keyPtrPtr) != TCL_OK) { TRACE_ERROR(interp); goto gotError; } - if ((size_t)length != duiPtr->length) { + if (length != duiPtr->length) { Tcl_Panic("dictUpdateStart argument length mismatch"); } for (i=0 ; icurrentInput); zshPtr->currentInput = NULL; } - TclListObjLength_(NULL, zshPtr->inData, &listLen); + Tcl_ListObjLength(NULL, zshPtr->inData, &listLen); if (listLen > 0) { /* * There is more input available, get it from the list and @@ -1422,7 +1422,7 @@ Tcl_ZlibStreamGet( e = inflate(&zshPtr->stream, zshPtr->flush); } }; - TclListObjLength_(NULL, zshPtr->inData, &listLen); + Tcl_ListObjLength(NULL, zshPtr->inData, &listLen); while ((zshPtr->stream.avail_out > 0) && (e == Z_OK || e == Z_BUF_ERROR) && (listLen > 0)) { @@ -1502,7 +1502,7 @@ Tcl_ZlibStreamGet( inflateEnd(&zshPtr->stream); } } else { - TclListObjLength_(NULL, zshPtr->outData, &listLen); + Tcl_ListObjLength(NULL, zshPtr->outData, &listLen); if (count == TCL_INDEX_NONE) { count = 0; for (i=0; i dataPos) && - (TclListObjLength_(NULL, zshPtr->outData, &listLen) == TCL_OK) + (Tcl_ListObjLength(NULL, zshPtr->outData, &listLen) == TCL_OK) && (listLen > 0)) { /* * Get the next chunk off our list of chunks and grab the data out @@ -2409,7 +2409,8 @@ ZlibPushSubcmd( const char *const *pushOptions = pushDecompressOptions; enum pushOptionsEnum {poDictionary, poHeader, poLevel, poLimit}; Tcl_Obj *headerObj = NULL, *compDictObj = NULL; - int limit = DEFAULT_BUFFER_SIZE, dummy; + int limit = DEFAULT_BUFFER_SIZE; + size_t dummy; if (objc < 4) { Tcl_WrongNumArgs(interp, 2, objv, "mode channel ?options...?"); @@ -2492,7 +2493,7 @@ ZlibPushSubcmd( switch ((enum pushOptionsEnum) option) { case poHeader: headerObj = objv[i]; - if (TclDictObjSize_(interp, headerObj, &dummy) != TCL_OK) { + if (Tcl_DictObjSize(interp, headerObj, &dummy) != TCL_OK) { goto genericOptionError; } break; -- cgit v0.12 From 5d9db7d9acbe609d68bb6f81daeaa5abeea212aa Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 24 Jan 2022 15:29:36 +0000 Subject: intPtr -> lengthPtr in Tcl_ListObjLength() documentation, so the documentation matches the signature in the header file --- doc/ListObj.3 | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/doc/ListObj.3 b/doc/ListObj.3 index ab836d8..f282039 100644 --- a/doc/ListObj.3 +++ b/doc/ListObj.3 @@ -28,7 +28,7 @@ int \fBTcl_ListObjGetElements\fR(\fIinterp, listPtr, objcPtr, objvPtr\fR) .sp int -\fBTcl_ListObjLength\fR(\fIinterp, listPtr, intPtr\fR) +\fBTcl_ListObjLength\fR(\fIinterp, listPtr, lengthPtr\fR) .sp int \fBTcl_ListObjIndex\fR(\fIinterp, listPtr, index, objPtrPtr\fR) @@ -76,7 +76,7 @@ An array of pointers to values. \fBTcl_NewListObj\fR will insert these values into a new list value and \fBTcl_ListObjReplace\fR will insert them into an existing \fIlistPtr\fR. Each value will become a separate list element. -.AP int *intPtr out +.AP int *lengthPtr out Points to location where \fBTcl_ListObjLength\fR stores the length of the list. .AP int index in @@ -162,7 +162,7 @@ Otherwise it returns \fBTCL_OK\fR after storing the count and array pointer. .PP \fBTcl_ListObjLength\fR returns the number of elements in the list value referenced by \fIlistPtr\fR. -It returns this count by storing an integer in the address \fIintPtr\fR. +It returns this count by storing an integer in the address \fIlengthPtr\fR. If the value is not already a list value, \fBTcl_ListObjLength\fR will attempt to convert it to one; if the conversion fails, it returns \fBTCL_ERROR\fR -- cgit v0.12 From 364d37365b43f2cb17f975257f2280788348cdb1 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 24 Jan 2022 21:24:02 +0000 Subject: 3 more stub-entries --- generic/tcl.decls | 10 ++++++++++ generic/tclDecls.h | 30 ++++++++++++++++++++++++++++++ generic/tclStubInit.c | 30 ++++++++++++++++++++++++++++++ 3 files changed, 70 insertions(+) diff --git a/generic/tcl.decls b/generic/tcl.decls index b0d2dd4..e59f841 100644 --- a/generic/tcl.decls +++ b/generic/tcl.decls @@ -2454,6 +2454,16 @@ declare 662 { declare 663 { int TclDictObjSize_(Tcl_Interp *interp, Tcl_Obj *dictPtr, size_t *sizePtr) } +declare 664 { + int TclSplitList_(Tcl_Interp *interp, const char *listStr, size_t *argcPtr, + const char ***argvPtr) +} +declare 665 { + void TclSplitPath_(const char *path, size_t *argcPtr, const char ***argvPtr) +} +declare 666 { + Tcl_Obj *TclFSSplitPath_(Tcl_Obj *pathPtr, size_t *lenPtr) +} # ----- BASELINE -- FOR -- 8.7.0 ----- # diff --git a/generic/tclDecls.h b/generic/tclDecls.h index d19881d..94cfddd 100644 --- a/generic/tclDecls.h +++ b/generic/tclDecls.h @@ -1958,6 +1958,15 @@ EXTERN int TclListObjLength_(Tcl_Interp *interp, /* 663 */ EXTERN int TclDictObjSize_(Tcl_Interp *interp, Tcl_Obj *dictPtr, size_t *sizePtr); +/* 664 */ +EXTERN int TclSplitList_(Tcl_Interp *interp, + const char *listStr, size_t *argcPtr, + const char ***argvPtr); +/* 665 */ +EXTERN void TclSplitPath_(const char *path, size_t *argcPtr, + const char ***argvPtr); +/* 666 */ +EXTERN Tcl_Obj * TclFSSplitPath_(Tcl_Obj *pathPtr, size_t *lenPtr); typedef struct { const struct TclPlatStubs *tclPlatStubs; @@ -2657,6 +2666,9 @@ typedef struct TclStubs { int (*tclListObjGetElements_) (Tcl_Interp *interp, Tcl_Obj *listPtr, size_t *objcPtr, Tcl_Obj ***objvPtr); /* 661 */ int (*tclListObjLength_) (Tcl_Interp *interp, Tcl_Obj *listPtr, size_t *lengthPtr); /* 662 */ int (*tclDictObjSize_) (Tcl_Interp *interp, Tcl_Obj *dictPtr, size_t *sizePtr); /* 663 */ + int (*tclSplitList_) (Tcl_Interp *interp, const char *listStr, size_t *argcPtr, const char ***argvPtr); /* 664 */ + void (*tclSplitPath_) (const char *path, size_t *argcPtr, const char ***argvPtr); /* 665 */ + Tcl_Obj * (*tclFSSplitPath_) (Tcl_Obj *pathPtr, size_t *lenPtr); /* 666 */ } TclStubs; extern const TclStubs *tclStubsPtr; @@ -4013,6 +4025,12 @@ extern const TclStubs *tclStubsPtr; (tclStubsPtr->tclListObjLength_) /* 662 */ #define TclDictObjSize_ \ (tclStubsPtr->tclDictObjSize_) /* 663 */ +#define TclSplitList_ \ + (tclStubsPtr->tclSplitList_) /* 664 */ +#define TclSplitPath_ \ + (tclStubsPtr->tclSplitPath_) /* 665 */ +#define TclFSSplitPath_ \ + (tclStubsPtr->tclFSSplitPath_) /* 666 */ #endif /* defined(USE_TCL_STUBS) */ @@ -4303,6 +4321,18 @@ extern const TclStubs *tclStubsPtr; # define Tcl_DictObjSize(interp, dictPtr, sizePtr) (sizeof(*sizePtr) == sizeof(int) \ ? tclStubsPtr->tcl_DictObjSize((interp), (dictPtr), (int *)(void *)(sizePtr)) \ : tclStubsPtr->tclDictObjSize_((interp), (dictPtr), (size_t *)(void *)(sizePtr))) +# undef Tcl_SplitList +# define Tcl_SplitList(interp, listStr, argcPtr, argvPtr) (sizeof(*argcPtr) == sizeof(int) \ + ? tclStubsPtr->tcl_SplitList((interp), (listStr), (int *)(void *)(argcPtr), (argvPtr)) \ + : tclStubsPtr->tclSplitList_((interp), (listStr), (size_t *)(void *)(argcPtr), (argvPtr))) +# undef Tcl_SplitPath +# define Tcl_SplitPath(path, argcPtr, argvPtr) (sizeof(*argcPtr) == sizeof(int) \ + ? tclStubsPtr->tcl_SplitPath((path), (int *)(void *)(argcPtr), (argvPtr)) \ + : tclStubsPtr->tclSplitPath_((path), (size_t *)(void *)(argcPtr), (argvPtr))) +# undef Tcl_FSSplitPath +# define Tcl_FSSplitPath(pathPtr, lenPtr) (sizeof(*lenPtr) == sizeof(int) \ + ? tclStubsPtr->tcl_FSSplitPath((pathPtr), (int *)(void *)(lenPtr)) \ + : tclStubsPtr->tclFSSplitPath_((pathPtr), (size_t *)(void *)(lenPtr))) #endif /* TCL_NO_DEPRECATED */ #else # define Tcl_WCharToUtfDString (sizeof(wchar_t) != sizeof(short) \ diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c index 234805c..62d2fce 100644 --- a/generic/tclStubInit.c +++ b/generic/tclStubInit.c @@ -126,6 +126,9 @@ static const char *TclUtfPrev(const char *src, const char *start) { #define TclListObjGetElements_ LOGetElements #define TclListObjLength_ LOLength #define TclDictObjSize_ DOSize +#define TclSplitList_ SplitList +#define TclSplitPath_ SplitPath +#define TclFSSplitPath_ FSSplitPath static int LOGetElements(Tcl_Interp *interp, Tcl_Obj *listPtr, size_t *objcPtr, Tcl_Obj ***objvPtr) { int n; @@ -153,6 +156,30 @@ static int DOSize(Tcl_Interp *interp, Tcl_Obj *dictPtr, } return result; } +static int SplitList(Tcl_Interp *interp, const char *listStr, size_t *argcPtr, + const char ***argvPtr) { + int n; + int result = Tcl_SplitList(interp, listStr, &n, argvPtr); + if (argcPtr) { + *argcPtr = n; + } + return result; +} +static void SplitPath(const char *path, size_t *argcPtr, const char ***argvPtr) { + int n; + Tcl_SplitPath(path, &n, argvPtr); + if (argcPtr) { + *argcPtr = n; + } +} +static Tcl_Obj *FSSplitPath(Tcl_Obj *pathPtr, size_t *lenPtr) { + int n; + Tcl_Obj *result = Tcl_FSSplitPath(pathPtr, &n); + if (lenPtr) { + *lenPtr = n; + } + return result; +} #define TclBN_mp_add mp_add #define TclBN_mp_and mp_and @@ -1978,6 +2005,9 @@ const TclStubs tclStubs = { TclListObjGetElements_, /* 661 */ TclListObjLength_, /* 662 */ TclDictObjSize_, /* 663 */ + TclSplitList_, /* 664 */ + TclSplitPath_, /* 665 */ + TclFSSplitPath_, /* 666 */ }; /* !END!: Do not edit above this line. */ -- cgit v0.12 From bf32d5a0ab8f0030ffed9ba63186dbb3cdb02bdd Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 24 Jan 2022 21:37:32 +0000 Subject: 3 more stub-entries --- generic/tcl.decls | 16 ++++++++++++--- generic/tclDecls.h | 56 +++++++++++++++++++++++++++++++++++++++------------ generic/tclStubInit.c | 36 ++++++++++++++++++++++++++++++--- 3 files changed, 89 insertions(+), 19 deletions(-) diff --git a/generic/tcl.decls b/generic/tcl.decls index 9ac859b..a231b04 100644 --- a/generic/tcl.decls +++ b/generic/tcl.decls @@ -879,12 +879,12 @@ declare 241 { void Tcl_SourceRCFile(Tcl_Interp *interp) } declare 242 { - int Tcl_SplitList(Tcl_Interp *interp, const char *listStr, size_t *argcPtr, + int TclSplitList_(Tcl_Interp *interp, const char *listStr, int *argcPtr, const char ***argvPtr) } # Obsolete, use Tcl_FSSplitPath declare 243 { - void Tcl_SplitPath(const char *path, size_t *argcPtr, const char ***argvPtr) + void TclSplitPath_(const char *path, int *argcPtr, const char ***argvPtr) } # Removed in 9.0 (stub entry only) #declare 244 { @@ -1702,7 +1702,7 @@ declare 460 { Tcl_Obj *Tcl_FSJoinPath(Tcl_Obj *listObj, size_t elements) } declare 461 { - Tcl_Obj *Tcl_FSSplitPath(Tcl_Obj *pathPtr, size_t *lenPtr) + Tcl_Obj *TclFSSplitPath_(Tcl_Obj *pathPtr, int *lenPtr) } declare 462 { int Tcl_FSEqualPaths(Tcl_Obj *firstPtr, Tcl_Obj *secondPtr) @@ -2517,6 +2517,16 @@ declare 662 { declare 663 { int Tcl_DictObjSize(Tcl_Interp *interp, Tcl_Obj *dictPtr, size_t *sizePtr) } +declare 664 { + int Tcl_SplitList(Tcl_Interp *interp, const char *listStr, size_t *argcPtr, + const char ***argvPtr) +} +declare 665 { + void Tcl_SplitPath(const char *path, size_t *argcPtr, const char ***argvPtr) +} +declare 666 { + Tcl_Obj *Tcl_FSSplitPath(Tcl_Obj *pathPtr, size_t *lenPtr) +} # ----- BASELINE -- FOR -- 8.7.0 ----- # diff --git a/generic/tclDecls.h b/generic/tclDecls.h index 5f616a7..cfe07b6 100644 --- a/generic/tclDecls.h +++ b/generic/tclDecls.h @@ -658,11 +658,11 @@ EXTERN const char * Tcl_SignalMsg(int sig); /* 241 */ EXTERN void Tcl_SourceRCFile(Tcl_Interp *interp); /* 242 */ -EXTERN int Tcl_SplitList(Tcl_Interp *interp, - const char *listStr, size_t *argcPtr, +EXTERN int TclSplitList_(Tcl_Interp *interp, + const char *listStr, int *argcPtr, const char ***argvPtr); /* 243 */ -EXTERN void Tcl_SplitPath(const char *path, size_t *argcPtr, +EXTERN void TclSplitPath_(const char *path, int *argcPtr, const char ***argvPtr); /* Slot 244 is reserved */ /* Slot 245 is reserved */ @@ -1198,7 +1198,7 @@ EXTERN int Tcl_FSConvertToPathType(Tcl_Interp *interp, /* 460 */ EXTERN Tcl_Obj * Tcl_FSJoinPath(Tcl_Obj *listObj, size_t elements); /* 461 */ -EXTERN Tcl_Obj * Tcl_FSSplitPath(Tcl_Obj *pathPtr, size_t *lenPtr); +EXTERN Tcl_Obj * TclFSSplitPath_(Tcl_Obj *pathPtr, int *lenPtr); /* 462 */ EXTERN int Tcl_FSEqualPaths(Tcl_Obj *firstPtr, Tcl_Obj *secondPtr); @@ -1767,6 +1767,15 @@ EXTERN int Tcl_ListObjLength(Tcl_Interp *interp, /* 663 */ EXTERN int Tcl_DictObjSize(Tcl_Interp *interp, Tcl_Obj *dictPtr, size_t *sizePtr); +/* 664 */ +EXTERN int Tcl_SplitList(Tcl_Interp *interp, + const char *listStr, size_t *argcPtr, + const char ***argvPtr); +/* 665 */ +EXTERN void Tcl_SplitPath(const char *path, size_t *argcPtr, + const char ***argvPtr); +/* 666 */ +EXTERN Tcl_Obj * Tcl_FSSplitPath(Tcl_Obj *pathPtr, size_t *lenPtr); typedef struct { const struct TclPlatStubs *tclPlatStubs; @@ -2020,8 +2029,8 @@ typedef struct TclStubs { const char * (*tcl_SignalId) (int sig); /* 239 */ const char * (*tcl_SignalMsg) (int sig); /* 240 */ void (*tcl_SourceRCFile) (Tcl_Interp *interp); /* 241 */ - int (*tcl_SplitList) (Tcl_Interp *interp, const char *listStr, size_t *argcPtr, const char ***argvPtr); /* 242 */ - void (*tcl_SplitPath) (const char *path, size_t *argcPtr, const char ***argvPtr); /* 243 */ + int (*tclSplitList_) (Tcl_Interp *interp, const char *listStr, int *argcPtr, const char ***argvPtr); /* 242 */ + void (*tclSplitPath_) (const char *path, int *argcPtr, const char ***argvPtr); /* 243 */ void (*reserved244)(void); void (*reserved245)(void); void (*reserved246)(void); @@ -2239,7 +2248,7 @@ typedef struct TclStubs { int (*tcl_FSChdir) (Tcl_Obj *pathPtr); /* 458 */ int (*tcl_FSConvertToPathType) (Tcl_Interp *interp, Tcl_Obj *pathPtr); /* 459 */ Tcl_Obj * (*tcl_FSJoinPath) (Tcl_Obj *listObj, size_t elements); /* 460 */ - Tcl_Obj * (*tcl_FSSplitPath) (Tcl_Obj *pathPtr, size_t *lenPtr); /* 461 */ + Tcl_Obj * (*tclFSSplitPath_) (Tcl_Obj *pathPtr, int *lenPtr); /* 461 */ int (*tcl_FSEqualPaths) (Tcl_Obj *firstPtr, Tcl_Obj *secondPtr); /* 462 */ Tcl_Obj * (*tcl_FSGetNormalizedPath) (Tcl_Interp *interp, Tcl_Obj *pathPtr); /* 463 */ Tcl_Obj * (*tcl_FSJoinToPath) (Tcl_Obj *pathPtr, size_t objc, Tcl_Obj *const objv[]); /* 464 */ @@ -2442,6 +2451,9 @@ typedef struct TclStubs { int (*tcl_ListObjGetElements) (Tcl_Interp *interp, Tcl_Obj *listPtr, size_t *objcPtr, Tcl_Obj ***objvPtr); /* 661 */ int (*tcl_ListObjLength) (Tcl_Interp *interp, Tcl_Obj *listPtr, size_t *lengthPtr); /* 662 */ int (*tcl_DictObjSize) (Tcl_Interp *interp, Tcl_Obj *dictPtr, size_t *sizePtr); /* 663 */ + int (*tcl_SplitList) (Tcl_Interp *interp, const char *listStr, size_t *argcPtr, const char ***argvPtr); /* 664 */ + void (*tcl_SplitPath) (const char *path, size_t *argcPtr, const char ***argvPtr); /* 665 */ + Tcl_Obj * (*tcl_FSSplitPath) (Tcl_Obj *pathPtr, size_t *lenPtr); /* 666 */ } TclStubs; extern const TclStubs *tclStubsPtr; @@ -2912,10 +2924,10 @@ extern const TclStubs *tclStubsPtr; (tclStubsPtr->tcl_SignalMsg) /* 240 */ #define Tcl_SourceRCFile \ (tclStubsPtr->tcl_SourceRCFile) /* 241 */ -#define Tcl_SplitList \ - (tclStubsPtr->tcl_SplitList) /* 242 */ -#define Tcl_SplitPath \ - (tclStubsPtr->tcl_SplitPath) /* 243 */ +#define TclSplitList_ \ + (tclStubsPtr->tclSplitList_) /* 242 */ +#define TclSplitPath_ \ + (tclStubsPtr->tclSplitPath_) /* 243 */ /* Slot 244 is reserved */ /* Slot 245 is reserved */ /* Slot 246 is reserved */ @@ -3315,8 +3327,8 @@ extern const TclStubs *tclStubsPtr; (tclStubsPtr->tcl_FSConvertToPathType) /* 459 */ #define Tcl_FSJoinPath \ (tclStubsPtr->tcl_FSJoinPath) /* 460 */ -#define Tcl_FSSplitPath \ - (tclStubsPtr->tcl_FSSplitPath) /* 461 */ +#define TclFSSplitPath_ \ + (tclStubsPtr->tclFSSplitPath_) /* 461 */ #define Tcl_FSEqualPaths \ (tclStubsPtr->tcl_FSEqualPaths) /* 462 */ #define Tcl_FSGetNormalizedPath \ @@ -3718,6 +3730,12 @@ extern const TclStubs *tclStubsPtr; (tclStubsPtr->tcl_ListObjLength) /* 662 */ #define Tcl_DictObjSize \ (tclStubsPtr->tcl_DictObjSize) /* 663 */ +#define Tcl_SplitList \ + (tclStubsPtr->tcl_SplitList) /* 664 */ +#define Tcl_SplitPath \ + (tclStubsPtr->tcl_SplitPath) /* 665 */ +#define Tcl_FSSplitPath \ + (tclStubsPtr->tcl_FSSplitPath) /* 666 */ #endif /* defined(USE_TCL_STUBS) */ @@ -3927,6 +3945,18 @@ extern const TclStubs *tclStubsPtr; # define Tcl_DictObjSize(interp, dictPtr, sizePtr) (sizeof(*sizePtr) != sizeof(int) \ ? tclStubsPtr->tcl_DictObjSize((interp), (dictPtr), (int *)(void *)(sizePtr)) \ : tclStubsPtr->tclDictObjSize_((interp), (dictPtr), (size_t *)(void *)(sizePtr))) +# undef Tcl_SplitList +# define Tcl_SplitList(interp, listStr, argcPtr, argvPtr) (sizeof(*argcPtr) != sizeof(int) \ + ? tclStubsPtr->tcl_SplitList((interp), (listStr), (int *)(void *)(argcPtr), (argvPtr)) \ + : tclStubsPtr->tclSplitList_((interp), (listStr), (size_t *)(void *)(argcPtr), (argvPtr))) +# undef Tcl_SplitPath +# define Tcl_SplitPath(path, argcPtr, argvPtr) (sizeof(*argcPtr) != sizeof(int) \ + ? tclStubsPtr->tcl_SplitPath((path), (int *)(void *)(argcPtr), (argvPtr)) \ + : tclStubsPtr->tclSplitPath_((path), (size_t *)(void *)(argcPtr), (argvPtr))) +# undef Tcl_FSSplitPath +# define Tcl_FSSplitPath(pathPtr, lenPtr) (sizeof(*lenPtr) != sizeof(int) \ + ? tclStubsPtr->tcl_FSSplitPath((pathPtr), (int *)(void *)(lenPtr)) \ + : tclStubsPtr->tclFSSplitPath_((pathPtr), (size_t *)(void *)(lenPtr))) #endif /* TCL_NO_DEPRECATED */ #else # define Tcl_WCharToUtfDString (sizeof(wchar_t) != sizeof(short) \ diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c index 74892fe..1b1ad89 100644 --- a/generic/tclStubInit.c +++ b/generic/tclStubInit.c @@ -89,6 +89,9 @@ static void uniCodePanic() { #define LOGetElements TclListObjGetElements_ #define LOLength TclListObjLength_ #define TclDictObjSize_ DOSize +#define TclSplitList_ SplitList +#define TclSplitPath_ SplitPath +#define TclFSSplitPath_ FSSplitPath int LOGetElements(Tcl_Interp *interp, Tcl_Obj *listPtr, int *objcPtr, Tcl_Obj ***objvPtr) { size_t n; @@ -116,6 +119,30 @@ static int DOSize(Tcl_Interp *interp, Tcl_Obj *dictPtr, } return result; } +static int SplitList(Tcl_Interp *interp, const char *listStr, int *argcPtr, + const char ***argvPtr) { + size_t n; + int result = Tcl_SplitList(interp, listStr, &n, argvPtr); + if (argcPtr) { + *argcPtr = n; + } + return result; +} +static void SplitPath(const char *path, int *argcPtr, const char ***argvPtr) { + size_t n; + Tcl_SplitPath(path, &n, argvPtr); + if (argcPtr) { + *argcPtr = n; + } +} +static Tcl_Obj *FSSplitPath(Tcl_Obj *pathPtr, int *lenPtr) { + size_t n; + Tcl_Obj *result = Tcl_FSSplitPath(pathPtr, &n); + if (lenPtr) { + *lenPtr = n; + } + return result; +} #define TclBN_mp_add mp_add #define TclBN_mp_add_d mp_add_d @@ -963,8 +990,8 @@ const TclStubs tclStubs = { Tcl_SignalId, /* 239 */ Tcl_SignalMsg, /* 240 */ Tcl_SourceRCFile, /* 241 */ - Tcl_SplitList, /* 242 */ - Tcl_SplitPath, /* 243 */ + TclSplitList_, /* 242 */ + TclSplitPath_, /* 243 */ 0, /* 244 */ 0, /* 245 */ 0, /* 246 */ @@ -1182,7 +1209,7 @@ const TclStubs tclStubs = { Tcl_FSChdir, /* 458 */ Tcl_FSConvertToPathType, /* 459 */ Tcl_FSJoinPath, /* 460 */ - Tcl_FSSplitPath, /* 461 */ + TclFSSplitPath_, /* 461 */ Tcl_FSEqualPaths, /* 462 */ Tcl_FSGetNormalizedPath, /* 463 */ Tcl_FSJoinToPath, /* 464 */ @@ -1385,6 +1412,9 @@ const TclStubs tclStubs = { Tcl_ListObjGetElements, /* 661 */ Tcl_ListObjLength, /* 662 */ Tcl_DictObjSize, /* 663 */ + Tcl_SplitList, /* 664 */ + Tcl_SplitPath, /* 665 */ + Tcl_FSSplitPath, /* 666 */ }; /* !END!: Do not edit above this line. */ -- cgit v0.12 From bd3452ab58ddcb280f56576e2404a728e7e69816 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 25 Jan 2022 15:19:52 +0000 Subject: unbreak (windows) build --- generic/tclDecls.h | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/generic/tclDecls.h b/generic/tclDecls.h index 94cfddd..d3728d2 100644 --- a/generic/tclDecls.h +++ b/generic/tclDecls.h @@ -4308,8 +4308,8 @@ extern const TclStubs *tclStubsPtr; # define Tcl_UtfToWChar (sizeof(wchar_t) != sizeof(short) \ ? (int (*)(const char *, wchar_t *))tclStubsPtr->tcl_UtfToChar16 \ : (int (*)(const char *, wchar_t *))Tcl_UtfToUniChar) -# undef Tcl_ListObjGetElements #ifdef TCL_NO_DEPRECATED +# undef Tcl_ListObjGetElements # define Tcl_ListObjGetElements(interp, listPtr, objcPtr, objvPtr) (sizeof(*objcPtr) == sizeof(int) \ ? tclStubsPtr->tcl_ListObjGetElements((interp), (listPtr), (int *)(void *)(objcPtr), (objvPtr)) \ : tclStubsPtr->tclListObjGetElements_((interp), (listPtr), (size_t *)(void *)(objcPtr), (objvPtr))) -- cgit v0.12 From 789ce0b97106ca8a3f91ab68ddaaf1fa904dcace Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 26 Jan 2022 08:37:09 +0000 Subject: More WIP --- doc/StringObj.3 | 2 +- generic/tcl.decls | 4 ++-- generic/tclAssembly.c | 6 +++--- generic/tclBinary.c | 10 +++++----- generic/tclCompCmds.c | 5 ++--- generic/tclDecls.h | 8 ++++---- generic/tclIO.c | 5 +++-- generic/tclIOUtil.c | 9 +++++---- generic/tclLink.c | 9 ++++----- generic/tclNamesp.c | 20 ++++++++++---------- generic/tclOOMethod.c | 22 ++++++++++++---------- generic/tclPathObj.c | 4 ++-- generic/tclPkg.c | 9 +++++---- generic/tclProc.c | 24 ++++++++++++------------ generic/tclProcess.c | 13 +++++-------- generic/tclResult.c | 5 +++-- generic/tclStringObj.c | 13 +++++++------ generic/tclTrace.c | 18 +++++++++--------- generic/tclUtil.c | 6 +++--- win/tclWinSerial.c | 3 ++- 20 files changed, 99 insertions(+), 96 deletions(-) diff --git a/doc/StringObj.3 b/doc/StringObj.3 index 156618b..859e27a 100644 --- a/doc/StringObj.3 +++ b/doc/StringObj.3 @@ -135,7 +135,7 @@ If NULL is passed then the suffix is used. .AP "const char" *format in Format control string including % conversion specifiers. -.AP int objc in +.AP size_t objc in The number of elements to format or concatenate. .AP Tcl_Obj *objv[] in The array of values to format or concatenate. diff --git a/generic/tcl.decls b/generic/tcl.decls index a231b04..022fe1d 100644 --- a/generic/tcl.decls +++ b/generic/tcl.decls @@ -89,7 +89,7 @@ declare 16 { void Tcl_AppendToObj(Tcl_Obj *objPtr, const char *bytes, size_t length) } declare 17 { - Tcl_Obj *Tcl_ConcatObj(int objc, Tcl_Obj *const objv[]) + Tcl_Obj *Tcl_ConcatObj(size_t objc, Tcl_Obj *const objv[]) } declare 18 { int Tcl_ConvertToType(Tcl_Interp *interp, Tcl_Obj *objPtr, @@ -2160,7 +2160,7 @@ declare 576 { } declare 577 { int Tcl_AppendFormatToObj(Tcl_Interp *interp, Tcl_Obj *objPtr, - const char *format, int objc, Tcl_Obj *const objv[]) + const char *format, size_t objc, Tcl_Obj *const objv[]) } declare 578 { Tcl_Obj *Tcl_ObjPrintf(const char *format, ...) diff --git a/generic/tclAssembly.c b/generic/tclAssembly.c index 8061f92..da55cea 100644 --- a/generic/tclAssembly.c +++ b/generic/tclAssembly.c @@ -1968,7 +1968,7 @@ CreateMirrorJumpTable( AssemblyEnv* assemEnvPtr, /* Assembly environment */ Tcl_Obj* jumps) /* List of alternating keywords and labels */ { - int objc; /* Number of elements in the 'jumps' list */ + size_t objc; /* Number of elements in the 'jumps' list */ Tcl_Obj** objv; /* Pointers to the elements in the list */ CompileEnv* envPtr = assemEnvPtr->envPtr; /* Compilation environment */ @@ -1981,9 +1981,9 @@ CreateMirrorJumpTable( Tcl_HashEntry* hashEntry; /* Entry for a key in the hashtable */ int isNew; /* Flag==1 if the key is not yet in the * table. */ - int i; + size_t i; - if (TclListObjGetElements_(interp, jumps, &objc, &objv) != TCL_OK) { + if (Tcl_ListObjGetElements(interp, jumps, &objc, &objv) != TCL_OK) { return TCL_ERROR; } if (objc % 2 != 0) { diff --git a/generic/tclBinary.c b/generic/tclBinary.c index e310960..ae454c4 100644 --- a/generic/tclBinary.c +++ b/generic/tclBinary.c @@ -1006,14 +1006,14 @@ BinaryFormatCmd( arg++; count = 1; } else { - int listc; + size_t listc; Tcl_Obj **listv; /* * The macro evals its args more than once: avoid arg++ */ - if (TclListObjGetElements_(interp, objv[arg], &listc, + if (Tcl_ListObjGetElements(interp, objv[arg], &listc, &listv) != TCL_OK) { return TCL_ERROR; } @@ -1021,7 +1021,7 @@ BinaryFormatCmd( if (count == BINARY_ALL) { count = listc; - } else if (count > (size_t)listc) { + } else if (count > listc) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "number of elements in list does not match count", -1)); @@ -1284,7 +1284,7 @@ BinaryFormatCmd( case 'q': case 'Q': case 'f': { - int listc, i; + size_t listc, i; Tcl_Obj **listv; if (count == BINARY_NOCOUNT) { @@ -1297,7 +1297,7 @@ BinaryFormatCmd( listc = 1; count = 1; } else { - TclListObjGetElements_(interp, objv[arg], &listc, &listv); + Tcl_ListObjGetElements(interp, objv[arg], &listc, &listv); if (count == BINARY_ALL) { count = listc; } diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c index 35c70c4..b1f5fe5 100644 --- a/generic/tclCompCmds.c +++ b/generic/tclCompCmds.c @@ -890,10 +890,9 @@ TclCompileConcatCmd( if (listObj != NULL) { Tcl_Obj **objs; const char *bytes; - int len; - size_t slen; + size_t len, slen; - TclListObjGetElements_(NULL, listObj, &len, &objs); + Tcl_ListObjGetElements(NULL, listObj, &len, &objs); objPtr = Tcl_ConcatObj(len, objs); Tcl_DecrRefCount(listObj); bytes = Tcl_GetStringFromObj(objPtr, &slen); diff --git a/generic/tclDecls.h b/generic/tclDecls.h index cfe07b6..7b91dc7 100644 --- a/generic/tclDecls.h +++ b/generic/tclDecls.h @@ -92,7 +92,7 @@ EXTERN void Tcl_AppendStringsToObj(Tcl_Obj *objPtr, ...); EXTERN void Tcl_AppendToObj(Tcl_Obj *objPtr, const char *bytes, size_t length); /* 17 */ -EXTERN Tcl_Obj * Tcl_ConcatObj(int objc, Tcl_Obj *const objv[]); +EXTERN Tcl_Obj * Tcl_ConcatObj(size_t objc, Tcl_Obj *const objv[]); /* 18 */ EXTERN int Tcl_ConvertToType(Tcl_Interp *interp, Tcl_Obj *objPtr, const Tcl_ObjType *typePtr); @@ -1526,7 +1526,7 @@ EXTERN Tcl_Obj * Tcl_Format(Tcl_Interp *interp, const char *format, /* 577 */ EXTERN int Tcl_AppendFormatToObj(Tcl_Interp *interp, Tcl_Obj *objPtr, const char *format, - int objc, Tcl_Obj *const objv[]); + size_t objc, Tcl_Obj *const objv[]); /* 578 */ EXTERN Tcl_Obj * Tcl_ObjPrintf(const char *format, ...) TCL_FORMAT_PRINTF(1, 2); /* 579 */ @@ -1804,7 +1804,7 @@ typedef struct TclStubs { int (*tcl_AppendAllObjTypes) (Tcl_Interp *interp, Tcl_Obj *objPtr); /* 14 */ void (*tcl_AppendStringsToObj) (Tcl_Obj *objPtr, ...); /* 15 */ void (*tcl_AppendToObj) (Tcl_Obj *objPtr, const char *bytes, size_t length); /* 16 */ - Tcl_Obj * (*tcl_ConcatObj) (int objc, Tcl_Obj *const objv[]); /* 17 */ + Tcl_Obj * (*tcl_ConcatObj) (size_t objc, Tcl_Obj *const objv[]); /* 17 */ int (*tcl_ConvertToType) (Tcl_Interp *interp, Tcl_Obj *objPtr, const Tcl_ObjType *typePtr); /* 18 */ void (*tcl_DbDecrRefCount) (Tcl_Obj *objPtr, const char *file, int line); /* 19 */ void (*tcl_DbIncrRefCount) (Tcl_Obj *objPtr, const char *file, int line); /* 20 */ @@ -2364,7 +2364,7 @@ typedef struct TclStubs { void (*tcl_AppendObjToErrorInfo) (Tcl_Interp *interp, Tcl_Obj *objPtr); /* 574 */ void (*tcl_AppendLimitedToObj) (Tcl_Obj *objPtr, const char *bytes, size_t length, size_t limit, const char *ellipsis); /* 575 */ Tcl_Obj * (*tcl_Format) (Tcl_Interp *interp, const char *format, int objc, Tcl_Obj *const objv[]); /* 576 */ - int (*tcl_AppendFormatToObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, const char *format, int objc, Tcl_Obj *const objv[]); /* 577 */ + int (*tcl_AppendFormatToObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, const char *format, size_t objc, Tcl_Obj *const objv[]); /* 577 */ Tcl_Obj * (*tcl_ObjPrintf) (const char *format, ...) TCL_FORMAT_PRINTF(1, 2); /* 578 */ void (*tcl_AppendPrintfToObj) (Tcl_Obj *objPtr, const char *format, ...) TCL_FORMAT_PRINTF(2, 3); /* 579 */ int (*tcl_CancelEval) (Tcl_Interp *interp, Tcl_Obj *resultObjPtr, void *clientData, int flags); /* 580 */ diff --git a/generic/tclIO.c b/generic/tclIO.c index ee5f5e3..4aa3f22 100644 --- a/generic/tclIO.c +++ b/generic/tclIO.c @@ -10910,7 +10910,8 @@ static Tcl_Obj * FixLevelCode( Tcl_Obj *msg) { - int explicitResult, numOptions, lc, lcn; + int explicitResult, numOptions, lcn; + size_t lc; Tcl_Obj **lv, **lvn; int res, i, j, val, lignore, cignore; int newlevel = -1, newcode = -1; @@ -10927,7 +10928,7 @@ FixLevelCode( * information. Hence an error means that we've got serious breakage. */ - res = TclListObjGetElements_(NULL, msg, &lc, &lv); + res = Tcl_ListObjGetElements(NULL, msg, &lc, &lv); if (res != TCL_OK) { Tcl_Panic("Tcl_SetChannelError: bad syntax of message"); } diff --git a/generic/tclIOUtil.c b/generic/tclIOUtil.c index 7c3032a..32a96ef 100644 --- a/generic/tclIOUtil.c +++ b/generic/tclIOUtil.c @@ -989,7 +989,8 @@ Tcl_FSMatchInDirectory( { const Tcl_Filesystem *fsPtr; Tcl_Obj *cwd, *tmpResultPtr, **elemsPtr; - int resLength, i, ret = -1; + size_t resLength, i; + int ret = -1; if (types != NULL && (types->type & TCL_GLOB_TYPE_MOUNT)) { /* @@ -1065,7 +1066,7 @@ Tcl_FSMatchInDirectory( * resultPtr and tmpResultPtr are guaranteed to be distinct. */ - ret = TclListObjGetElements_(interp, tmpResultPtr, + ret = Tcl_ListObjGetElements(interp, tmpResultPtr, &resLength, &elemsPtr); for (i=0 ; ret==TCL_OK && iflags & LINK_ALLOC_LAST) { - if (TclListObjGetElements_(NULL, (valueObj), &objc, &objv) == TCL_ERROR - || (size_t)objc != linkPtr->numElems) { + if (Tcl_ListObjGetElements(NULL, (valueObj), &objc, &objv) == TCL_ERROR + || objc != linkPtr->numElems) { return (char *) "wrong dimension"; } } @@ -956,7 +955,7 @@ LinkTraceProc( switch (linkPtr->type) { case TCL_LINK_INT: if (linkPtr->flags & LINK_ALLOC_LAST) { - for (i=0; i < objc; i++) { + for (i = 0; i < objc; i++) { int *varPtr = &linkPtr->lastValue.iPtr[i]; if (GetInt(objv[i], varPtr)) { diff --git a/generic/tclNamesp.c b/generic/tclNamesp.c index dc57c9e..53c5769 100644 --- a/generic/tclNamesp.c +++ b/generic/tclNamesp.c @@ -4036,8 +4036,8 @@ NamespacePathCmd( Tcl_Obj *const objv[]) /* Argument objects. */ { Namespace *nsPtr = (Namespace *) TclGetCurrentNamespace(interp); - size_t i; - int nsObjc, result = TCL_ERROR; + size_t nsObjc, i; + int result = TCL_ERROR; Tcl_Obj **nsObjv; Tcl_Namespace **namespaceList = NULL; @@ -4068,14 +4068,14 @@ NamespacePathCmd( * There is a path given, so parse it into an array of namespace pointers. */ - if (TclListObjGetElements_(interp, objv[1], &nsObjc, &nsObjv) != TCL_OK) { + if (Tcl_ListObjGetElements(interp, objv[1], &nsObjc, &nsObjv) != TCL_OK) { goto badNamespace; } if (nsObjc != 0) { namespaceList = (Tcl_Namespace **)TclStackAlloc(interp, sizeof(Tcl_Namespace *) * nsObjc); - for (i=0 ; i<(size_t)nsObjc ; i++) { + for (i = 0; i < nsObjc; i++) { if (TclGetNamespaceFromObj(interp, nsObjv[i], &namespaceList[i]) != TCL_OK) { goto badNamespace; @@ -4428,7 +4428,7 @@ Tcl_SetNamespaceUnknownHandler( Tcl_Namespace *nsPtr, /* Namespace which is being updated. */ Tcl_Obj *handlerPtr) /* The new handler, or NULL to reset. */ { - int lstlen = 0; + size_t lstlen = 0; Namespace *currNsPtr = (Namespace *) nsPtr; /* @@ -4436,7 +4436,7 @@ Tcl_SetNamespaceUnknownHandler( */ if (handlerPtr != NULL) { - if (TclListObjLength_(interp, handlerPtr, &lstlen) != TCL_OK) { + if (Tcl_ListObjLength(interp, handlerPtr, &lstlen) != TCL_OK) { /* * Not a list. */ @@ -5010,10 +5010,10 @@ TclLogCommandInfo( iPtr->errorStack = newObj; } if (iPtr->resetErrorStack) { - int len; + size_t len; iPtr->resetErrorStack = 0; - TclListObjLength_(interp, iPtr->errorStack, &len); + Tcl_ListObjLength(interp, iPtr->errorStack, &len); /* * Reset while keeping the list internalrep as much as possible. @@ -5095,10 +5095,10 @@ TclErrorStackResetIf( iPtr->errorStack = newObj; } if (iPtr->resetErrorStack) { - int len; + size_t len; iPtr->resetErrorStack = 0; - TclListObjLength_(interp, iPtr->errorStack, &len); + Tcl_ListObjLength(interp, iPtr->errorStack, &len); /* * Reset while keeping the list internalrep as much as possible. diff --git a/generic/tclOOMethod.c b/generic/tclOOMethod.c index 81e94c6..c8b97a5 100644 --- a/generic/tclOOMethod.c +++ b/generic/tclOOMethod.c @@ -387,17 +387,17 @@ TclOONewProcMethod( * structure's contents. NULL if caller is not * interested. */ { - int argsLen; /* -1 => delete argsObj before exit */ + size_t argsLen; /* TCL_INDEX_NONE => delete argsObj before exit */ ProcedureMethod *pmPtr; const char *procName; Tcl_Method method; if (argsObj == NULL) { - argsLen = -1; + argsLen = TCL_INDEX_NONE; TclNewObj(argsObj); Tcl_IncrRefCount(argsObj); procName = ""; - } else if (TclListObjLength_(interp, argsObj, &argsLen) != TCL_OK) { + } else if (Tcl_ListObjLength(interp, argsObj, &argsLen) != TCL_OK) { return NULL; } else { procName = (nameObj==NULL ? "" : TclGetString(nameObj)); @@ -412,7 +412,7 @@ TclOONewProcMethod( method = TclOOMakeProcMethod(interp, clsPtr, flags, nameObj, procName, argsObj, bodyObj, &procMethodType, pmPtr, &pmPtr->procPtr); - if (argsLen == -1) { + if (argsLen == TCL_INDEX_NONE) { Tcl_DecrRefCount(argsObj); } if (method == NULL) { @@ -1387,10 +1387,10 @@ TclOONewForwardInstanceMethod( Tcl_Obj *prefixObj) /* List of arguments that form the command * prefix to forward to. */ { - int prefixLen; + size_t prefixLen; ForwardMethod *fmPtr; - if (TclListObjLength_(interp, prefixObj, &prefixLen) != TCL_OK) { + if (Tcl_ListObjLength(interp, prefixObj, &prefixLen) != TCL_OK) { return NULL; } if (prefixLen < 1) { @@ -1426,10 +1426,10 @@ TclOONewForwardMethod( Tcl_Obj *prefixObj) /* List of arguments that form the command * prefix to forward to. */ { - int prefixLen; + size_t prefixLen; ForwardMethod *fmPtr; - if (TclListObjLength_(interp, prefixObj, &prefixLen) != TCL_OK) { + if (Tcl_ListObjLength(interp, prefixObj, &prefixLen) != TCL_OK) { return NULL; } if (prefixLen < 1) { @@ -1468,7 +1468,9 @@ InvokeForwardMethod( CallContext *contextPtr = (CallContext *) context; ForwardMethod *fmPtr = (ForwardMethod *)clientData; Tcl_Obj **argObjs, **prefixObjs; - int numPrefixes, len, skip = contextPtr->skip; + size_t numPrefixes; + int len; + int skip = contextPtr->skip; /* * Build the real list of arguments to use. Note that we know that the @@ -1477,7 +1479,7 @@ InvokeForwardMethod( * can ignore here. */ - TclListObjGetElements_(NULL, fmPtr->prefixObj, &numPrefixes, &prefixObjs); + Tcl_ListObjGetElements(NULL, fmPtr->prefixObj, &numPrefixes, &prefixObjs); argObjs = InitEnsembleRewrite(interp, objc, objv, skip, numPrefixes, prefixObjs, &len); Tcl_NRAddCallback(interp, FinalizeForwardCall, argObjs, NULL, NULL, NULL); diff --git a/generic/tclPathObj.c b/generic/tclPathObj.c index 6dd1a4e..113c2ed 100644 --- a/generic/tclPathObj.c +++ b/generic/tclPathObj.c @@ -2310,11 +2310,11 @@ SetFsPathFromAny( * beginning with ~ are part of the native filesystem. */ - int objc; + size_t objc; Tcl_Obj **objv; Tcl_Obj *parts = TclpNativeSplitPath(pathPtr, NULL); - TclListObjGetElements_(NULL, parts, &objc, &objv); + Tcl_ListObjGetElements(NULL, parts, &objc, &objv); /* * Skip '~'. It's replaced by its expansion. diff --git a/generic/tclPkg.c b/generic/tclPkg.c index 5e025a9..3f70ab8 100644 --- a/generic/tclPkg.c +++ b/generic/tclPkg.c @@ -1079,7 +1079,8 @@ TclNRPackageObjCmd( PKG_VERSIONS, PKG_VSATISFIES }; Interp *iPtr = (Interp *) interp; - int optionIndex, exact, i, newobjc, satisfies; + int optionIndex, exact, satisfies; + size_t i, newobjc; PkgAvail *availPtr, *prevPtr; Package *pkgPtr; Tcl_HashEntry *hPtr; @@ -1123,7 +1124,7 @@ TclNRPackageObjCmd( PkgFiles *pkgFiles = (PkgFiles *) Tcl_GetAssocData(interp, "tclPkgFiles", NULL); - for (i = 2; i < objc; i++) { + for (i = 2; i < (size_t)objc; i++) { keyString = TclGetString(objv[i]); if (pkgFiles) { hPtr = Tcl_FindHashEntry(&pkgFiles->table, keyString); @@ -1361,7 +1362,7 @@ TclNRPackageObjCmd( objvListPtr = Tcl_NewListObj(0, NULL); Tcl_IncrRefCount(objvListPtr); Tcl_ListObjAppendElement(interp, objvListPtr, ov); - TclListObjGetElements_(interp, objvListPtr, &newobjc, &newObjvPtr); + Tcl_ListObjGetElements(interp, objvListPtr, &newobjc, &newObjvPtr); Tcl_NRAddCallback(interp, TclNRPackageObjCmdCleanup, objv[3], objvListPtr, NULL,NULL); @@ -1388,7 +1389,7 @@ TclNRPackageObjCmd( Tcl_ListObjAppendElement(interp, objvListPtr, Tcl_DuplicateObj(newobjv[i])); } - TclListObjGetElements_(interp, objvListPtr, &newobjc, &newObjvPtr); + Tcl_ListObjGetElements(interp, objvListPtr, &newobjc, &newObjvPtr); Tcl_NRAddCallback(interp, TclNRPackageObjCmdCleanup, objv[2], objvListPtr, NULL,NULL); Tcl_NRAddCallback(interp, diff --git a/generic/tclProc.c b/generic/tclProc.c index 138478c..0162def 100644 --- a/generic/tclProc.c +++ b/generic/tclProc.c @@ -404,10 +404,10 @@ TclCreateProc( Interp *iPtr = (Interp *) interp; Proc *procPtr = NULL; - int i, result, numArgs; + size_t i, numArgs; CompiledLocal *localPtr = NULL; Tcl_Obj **argArray; - int precompiled = 0; + int precompiled = 0, result; ProcGetIntRep(bodyPtr, procPtr); if (procPtr != NULL) { @@ -484,15 +484,15 @@ TclCreateProc( * in the Proc. */ - result = TclListObjGetElements_(interp , argsPtr ,&numArgs ,&argArray); + result = Tcl_ListObjGetElements(interp , argsPtr ,&numArgs ,&argArray); if (result != TCL_OK) { goto procError; } if (precompiled) { - if (numArgs > procPtr->numArgs) { + if (numArgs > (size_t)procPtr->numArgs) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "procedure \"%s\": arg list contains %d entries, " + "procedure \"%s\": arg list contains %" TCL_Z_MODIFIER "d entries, " "precompiled header expects %d", procName, numArgs, procPtr->numArgs)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC", @@ -507,15 +507,14 @@ TclCreateProc( for (i = 0; i < numArgs; i++) { const char *argname, *argnamei, *argnamelast; - int fieldCount; - size_t nameLength; + size_t fieldCount, nameLength; Tcl_Obj **fieldValues; /* * Now divide the specifier up into name and default. */ - result = TclListObjGetElements_(interp, argArray[i], &fieldCount, + result = Tcl_ListObjGetElements(interp, argArray[i], &fieldCount, &fieldValues); if (result != TCL_OK) { goto procError; @@ -583,12 +582,12 @@ TclCreateProc( if ((localPtr->nameLength != nameLength) || (memcmp(localPtr->name, argname, nameLength) != 0) - || (localPtr->frameIndex != i) + || ((size_t)localPtr->frameIndex != i) || !(localPtr->flags & VAR_ARGUMENT) || (localPtr->defValuePtr == NULL && fieldCount == 2) || (localPtr->defValuePtr != NULL && fieldCount != 2)) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "procedure \"%s\": formal parameter %d is " + "procedure \"%s\": formal parameter %" TCL_Z_MODIFIER "d is " "inconsistent with precompiled body", procName, i)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC", "BYTECODELIES", NULL); @@ -2383,7 +2382,8 @@ SetLambdaFromAny( Interp *iPtr = (Interp *) interp; const char *name; Tcl_Obj *argsPtr, *bodyPtr, *nsObjPtr, **objv; - int isNew, objc, result; + int isNew, result; + size_t objc; CmdFrame *cfPtr = NULL; Proc *procPtr; @@ -2396,7 +2396,7 @@ SetLambdaFromAny( * length is not 2, then it cannot be converted to lambdaType. */ - result = TclListObjGetElements_(NULL, objPtr, &objc, &objv); + result = Tcl_ListObjGetElements(NULL, objPtr, &objc, &objv); if ((result != TCL_OK) || ((objc != 2) && (objc != 3))) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "can't interpret \"%s\" as a lambda expression", diff --git a/generic/tclProcess.c b/generic/tclProcess.c index 31a17fa..49f9c9c 100644 --- a/generic/tclProcess.c +++ b/generic/tclProcess.c @@ -463,10 +463,9 @@ ProcessStatusObjCmd( Tcl_HashEntry *entry; Tcl_HashSearch search; ProcessInfo *info; - int numPids; + size_t i, numPids; Tcl_Obj **pidObjs; int result; - int i; int pid; Tcl_Obj *const *savedobjv = objv; static const char *const switches[] = { @@ -533,7 +532,7 @@ ProcessStatusObjCmd( * Only return statuses of provided processes. */ - result = TclListObjGetElements_(interp, objv[1], &numPids, &pidObjs); + result = Tcl_ListObjGetElements(interp, objv[1], &numPids, &pidObjs); if (result != TCL_OK) { return result; } @@ -609,11 +608,9 @@ ProcessPurgeObjCmd( Tcl_HashEntry *entry; Tcl_HashSearch search; ProcessInfo *info; - int numPids; + size_t i, numPids; Tcl_Obj **pidObjs; - int result; - int i; - int pid; + int result, pid; if (objc != 1 && objc != 2) { Tcl_WrongNumArgs(interp, 1, objv, "?pids?"); @@ -648,7 +645,7 @@ ProcessPurgeObjCmd( * Purge only provided processes. */ - result = TclListObjGetElements_(interp, objv[1], &numPids, &pidObjs); + result = Tcl_ListObjGetElements(interp, objv[1], &numPids, &pidObjs); if (result != TCL_OK) { return result; } diff --git a/generic/tclResult.c b/generic/tclResult.c index c0467d7..6286070 100644 --- a/generic/tclResult.c +++ b/generic/tclResult.c @@ -1100,11 +1100,12 @@ Tcl_SetReturnOptions( Tcl_Interp *interp, Tcl_Obj *options) { - int objc, level, code; + size_t objc; + int level, code; Tcl_Obj **objv, *mergedOpts; Tcl_IncrRefCount(options); - if (TCL_ERROR == TclListObjGetElements_(interp, options, &objc, &objv) + if (TCL_ERROR == Tcl_ListObjGetElements(interp, options, &objc, &objv) || (objc % 2)) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "expected dict but got \"%s\"", TclGetString(options))); diff --git a/generic/tclStringObj.c b/generic/tclStringObj.c index 65c9983..ee2cde9 100644 --- a/generic/tclStringObj.c +++ b/generic/tclStringObj.c @@ -1717,12 +1717,12 @@ Tcl_AppendFormatToObj( Tcl_Interp *interp, Tcl_Obj *appendObj, const char *format, - int objc, + size_t objc, Tcl_Obj *const objv[]) { const char *span = format, *msg, *errCode; - int objIndex = 0, gotXpg = 0, gotSequential = 0; - size_t originalLength, limit, numBytes = 0; + int gotXpg = 0, gotSequential = 0; + size_t objIndex = 0, originalLength, limit, numBytes = 0; Tcl_UniChar ch = 0; static const char *mixedXPG = "cannot mix \"%\" and \"%n$\" conversion specifiers"; @@ -1814,7 +1814,7 @@ Tcl_AppendFormatToObj( } gotSequential = 1; } - if ((objIndex < 0) || (objIndex >= objc)) { + if (objIndex >= objc) { msg = badIndex[gotXpg]; errCode = gotXpg ? "INDEXRANGE" : "FIELDVARMISMATCH"; goto errorMsg; @@ -2517,7 +2517,8 @@ AppendPrintfToObjVA( const char *format, va_list argList) { - int code, objc; + int code; + size_t objc; Tcl_Obj **objv, *list; const char *p; @@ -2678,7 +2679,7 @@ AppendPrintfToObjVA( } } while (seekingConversion); } - TclListObjGetElements_(NULL, list, &objc, &objv); + Tcl_ListObjGetElements(NULL, list, &objc, &objv); code = Tcl_AppendFormatToObj(NULL, objPtr, format, objc, objv); if (code != TCL_OK) { Tcl_AppendPrintfToObj(objPtr, diff --git a/generic/tclTrace.c b/generic/tclTrace.c index 1fae619..72bf4cd 100644 --- a/generic/tclTrace.c +++ b/generic/tclTrace.c @@ -419,8 +419,8 @@ TraceExecutionObjCmd( switch ((enum traceOptions) optionIndex) { case TRACE_ADD: case TRACE_REMOVE: { - int flags = 0; - int i, listLen, result; + int flags = 0, result; + size_t i, listLen; Tcl_Obj **elemPtrs; if (objc != 6) { @@ -433,7 +433,7 @@ TraceExecutionObjCmd( * pointer to its array of element pointers. */ - result = TclListObjGetElements_(interp, objv[4], &listLen, &elemPtrs); + result = Tcl_ListObjGetElements(interp, objv[4], &listLen, &elemPtrs); if (result != TCL_OK) { return result; } @@ -660,8 +660,8 @@ TraceCommandObjCmd( switch ((enum traceOptions) optionIndex) { case TRACE_ADD: case TRACE_REMOVE: { - int flags = 0; - int i, listLen, result; + int flags = 0, result; + size_t i, listLen; Tcl_Obj **elemPtrs; if (objc != 6) { @@ -674,7 +674,7 @@ TraceCommandObjCmd( * pointer to its array of element pointers. */ - result = TclListObjGetElements_(interp, objv[4], &listLen, &elemPtrs); + result = Tcl_ListObjGetElements(interp, objv[4], &listLen, &elemPtrs); if (result != TCL_OK) { return result; } @@ -859,8 +859,8 @@ TraceVariableObjCmd( switch ((enum traceOptions) optionIndex) { case TRACE_ADD: case TRACE_REMOVE: { - int flags = 0; - int i, listLen, result; + int flags = 0, result; + size_t i, listLen; Tcl_Obj **elemPtrs; if (objc != 6) { @@ -873,7 +873,7 @@ TraceVariableObjCmd( * pointer to its array of element pointers. */ - result = TclListObjGetElements_(interp, objv[4], &listLen, &elemPtrs); + result = Tcl_ListObjGetElements(interp, objv[4], &listLen, &elemPtrs); if (result != TCL_OK) { return result; } diff --git a/generic/tclUtil.c b/generic/tclUtil.c index 7ba2008..5ac7c2d 100644 --- a/generic/tclUtil.c +++ b/generic/tclUtil.c @@ -1935,11 +1935,11 @@ Tcl_Concat( Tcl_Obj * Tcl_ConcatObj( - int objc, /* Number of objects to concatenate. */ + size_t objc, /* Number of objects to concatenate. */ Tcl_Obj *const objv[]) /* Array of objects to concatenate. */ { - int i, needSpace = 0; - size_t bytesNeeded = 0, elemLength; + int needSpace = 0; + size_t i, bytesNeeded = 0, elemLength; const char *element; Tcl_Obj *objPtr, *resPtr; diff --git a/win/tclWinSerial.c b/win/tclWinSerial.c index 8384a43..b6abb50 100644 --- a/win/tclWinSerial.c +++ b/win/tclWinSerial.c @@ -1826,7 +1826,8 @@ SerialSetOptionProc( */ if ((len > 4) && (strncmp(optionName, "-ttycontrol", len) == 0)) { - int i, res = TCL_OK; + size_t i; + int res = TCL_OK; if (Tcl_SplitList(interp, value, &argc, &argv) == TCL_ERROR) { return TCL_ERROR; -- cgit v0.12 From c383a86b3c7a099fd021ae9497b409658792b4d6 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 26 Jan 2022 12:11:00 +0000 Subject: Change Tcl_Merge API too --- doc/ParseArgs.3 | 2 +- generic/tcl.decls | 2 +- generic/tclDecls.h | 4 ++-- generic/tclUtil.c | 5 ++--- 4 files changed, 6 insertions(+), 7 deletions(-) diff --git a/doc/ParseArgs.3 b/doc/ParseArgs.3 index 6c1dcbb..02b52d4 100644 --- a/doc/ParseArgs.3 +++ b/doc/ParseArgs.3 @@ -21,7 +21,7 @@ int Where to store error messages. .AP "const Tcl_ArgvInfo" *argTable in Pointer to array of option descriptors. -.AP int *objcPtr in/out +.AP size_t | int *objcPtr in/out A pointer to variable holding number of arguments in \fIobjv\fR. Will be modified to hold number of arguments left in the unprocessed argument list stored in \fIremObjv\fR. diff --git a/generic/tcl.decls b/generic/tcl.decls index 022fe1d..676373b 100644 --- a/generic/tcl.decls +++ b/generic/tcl.decls @@ -708,7 +708,7 @@ declare 191 { Tcl_Channel Tcl_MakeTcpClientChannel(void *tcpSocket) } declare 192 { - char *Tcl_Merge(int argc, const char *const *argv) + char *Tcl_Merge(size_t argc, const char *const *argv) } declare 193 { Tcl_HashEntry *Tcl_NextHashEntry(Tcl_HashSearch *searchPtr) diff --git a/generic/tclDecls.h b/generic/tclDecls.h index 7b91dc7..b1c3d10 100644 --- a/generic/tclDecls.h +++ b/generic/tclDecls.h @@ -530,7 +530,7 @@ EXTERN int Tcl_MakeSafe(Tcl_Interp *interp); /* 191 */ EXTERN Tcl_Channel Tcl_MakeTcpClientChannel(void *tcpSocket); /* 192 */ -EXTERN char * Tcl_Merge(int argc, const char *const *argv); +EXTERN char * Tcl_Merge(size_t argc, const char *const *argv); /* 193 */ EXTERN Tcl_HashEntry * Tcl_NextHashEntry(Tcl_HashSearch *searchPtr); /* 194 */ @@ -1979,7 +1979,7 @@ typedef struct TclStubs { Tcl_Channel (*tcl_MakeFileChannel) (void *handle, int mode); /* 189 */ int (*tcl_MakeSafe) (Tcl_Interp *interp); /* 190 */ Tcl_Channel (*tcl_MakeTcpClientChannel) (void *tcpSocket); /* 191 */ - char * (*tcl_Merge) (int argc, const char *const *argv); /* 192 */ + char * (*tcl_Merge) (size_t argc, const char *const *argv); /* 192 */ Tcl_HashEntry * (*tcl_NextHashEntry) (Tcl_HashSearch *searchPtr); /* 193 */ void (*tcl_NotifyChannel) (Tcl_Channel channel, int mask); /* 194 */ Tcl_Obj * (*tcl_ObjGetVar2) (Tcl_Interp *interp, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, int flags); /* 195 */ diff --git a/generic/tclUtil.c b/generic/tclUtil.c index 5ac7c2d..16fb278 100644 --- a/generic/tclUtil.c +++ b/generic/tclUtil.c @@ -1556,13 +1556,12 @@ TclConvertElement( char * Tcl_Merge( - int argc, /* How many strings to merge. */ + size_t argc, /* How many strings to merge. */ const char *const *argv) /* Array of string values. */ { #define LOCAL_SIZE 64 char localFlags[LOCAL_SIZE], *flagPtr = NULL; - int i; - size_t bytesNeeded = 0; + size_t i, bytesNeeded = 0; char *result, *dst; /* -- cgit v0.12 From b323b6696d5340e0202d6fc888c404cd232dceec Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 26 Jan 2022 13:33:49 +0000 Subject: Add TclParseArgsObjv_ --- generic/tcl.decls | 4 ++++ generic/tclDecls.h | 12 ++++++++++++ generic/tclStubInit.c | 17 +++++++++++++---- 3 files changed, 29 insertions(+), 4 deletions(-) diff --git a/generic/tcl.decls b/generic/tcl.decls index e59f841..ebdbac1 100644 --- a/generic/tcl.decls +++ b/generic/tcl.decls @@ -2464,6 +2464,10 @@ declare 665 { declare 666 { Tcl_Obj *TclFSSplitPath_(Tcl_Obj *pathPtr, size_t *lenPtr) } +declare 667 { + int TclParseArgsObjv_(Tcl_Interp *interp, const Tcl_ArgvInfo *argTable, + size_t *objcPtr, Tcl_Obj *const *objv, Tcl_Obj ***remObjv) +} # ----- BASELINE -- FOR -- 8.7.0 ----- # diff --git a/generic/tclDecls.h b/generic/tclDecls.h index d3728d2..909cb6e 100644 --- a/generic/tclDecls.h +++ b/generic/tclDecls.h @@ -1967,6 +1967,11 @@ EXTERN void TclSplitPath_(const char *path, size_t *argcPtr, const char ***argvPtr); /* 666 */ EXTERN Tcl_Obj * TclFSSplitPath_(Tcl_Obj *pathPtr, size_t *lenPtr); +/* 667 */ +EXTERN int TclParseArgsObjv_(Tcl_Interp *interp, + const Tcl_ArgvInfo *argTable, + size_t *objcPtr, Tcl_Obj *const *objv, + Tcl_Obj ***remObjv); typedef struct { const struct TclPlatStubs *tclPlatStubs; @@ -2669,6 +2674,7 @@ typedef struct TclStubs { int (*tclSplitList_) (Tcl_Interp *interp, const char *listStr, size_t *argcPtr, const char ***argvPtr); /* 664 */ void (*tclSplitPath_) (const char *path, size_t *argcPtr, const char ***argvPtr); /* 665 */ Tcl_Obj * (*tclFSSplitPath_) (Tcl_Obj *pathPtr, size_t *lenPtr); /* 666 */ + int (*tclParseArgsObjv_) (Tcl_Interp *interp, const Tcl_ArgvInfo *argTable, size_t *objcPtr, Tcl_Obj *const *objv, Tcl_Obj ***remObjv); /* 667 */ } TclStubs; extern const TclStubs *tclStubsPtr; @@ -4031,6 +4037,8 @@ extern const TclStubs *tclStubsPtr; (tclStubsPtr->tclSplitPath_) /* 665 */ #define TclFSSplitPath_ \ (tclStubsPtr->tclFSSplitPath_) /* 666 */ +#define TclParseArgsObjv_ \ + (tclStubsPtr->tclParseArgsObjv_) /* 667 */ #endif /* defined(USE_TCL_STUBS) */ @@ -4333,6 +4341,10 @@ extern const TclStubs *tclStubsPtr; # define Tcl_FSSplitPath(pathPtr, lenPtr) (sizeof(*lenPtr) == sizeof(int) \ ? tclStubsPtr->tcl_FSSplitPath((pathPtr), (int *)(void *)(lenPtr)) \ : tclStubsPtr->tclFSSplitPath_((pathPtr), (size_t *)(void *)(lenPtr))) +# undef Tcl_ParseArgsObjv +# define Tcl_ParseArgsObjv(interp, argTable, objcPtr, objv, remObjv) (sizeof(*objcPtr) == sizeof(int) \ + ? tclStubsPtr->tcl_ParseArgsObjv((interp), (argTable), (int *)(void *)(objcPtr), (objv), (remObjv)) \ + : tclStubsPtr->tclParseArgsObjv_((interp), (argTable), (size_t *)(void *)(objcPtr), (objv), (remObjv))) #endif /* TCL_NO_DEPRECATED */ #else # define Tcl_WCharToUtfDString (sizeof(wchar_t) != sizeof(short) \ diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c index 62d2fce..f9987cf 100644 --- a/generic/tclStubInit.c +++ b/generic/tclStubInit.c @@ -129,10 +129,10 @@ static const char *TclUtfPrev(const char *src, const char *start) { #define TclSplitList_ SplitList #define TclSplitPath_ SplitPath #define TclFSSplitPath_ FSSplitPath +#define TclParseArgsObjv_ ParseArgsObjv static int LOGetElements(Tcl_Interp *interp, Tcl_Obj *listPtr, size_t *objcPtr, Tcl_Obj ***objvPtr) { - int n; - int result = Tcl_ListObjGetElements(interp, listPtr, &n, objvPtr); + int n, result = Tcl_ListObjGetElements(interp, listPtr, &n, objvPtr); if (objcPtr) { *objcPtr = n; } @@ -149,8 +149,7 @@ static int LOLength(Tcl_Interp *interp, Tcl_Obj *listPtr, } static int DOSize(Tcl_Interp *interp, Tcl_Obj *dictPtr, size_t *sizePtr) { - int n; - int result = Tcl_DictObjSize(interp, dictPtr, &n); + int n, result = Tcl_DictObjSize(interp, dictPtr, &n); if (sizePtr) { *sizePtr = n; } @@ -180,6 +179,15 @@ static Tcl_Obj *FSSplitPath(Tcl_Obj *pathPtr, size_t *lenPtr) { } return result; } +static int ParseArgsObjv(Tcl_Interp *interp, + const Tcl_ArgvInfo *argTable, size_t *objcPtr, Tcl_Obj *const *objv, + Tcl_Obj ***remObjv) { + int n, result = Tcl_ParseArgsObjv(interp, argTable, &n, objv, remObjv); + if (objcPtr) { + *objcPtr = n; + } + return result; +} #define TclBN_mp_add mp_add #define TclBN_mp_and mp_and @@ -2008,6 +2016,7 @@ const TclStubs tclStubs = { TclSplitList_, /* 664 */ TclSplitPath_, /* 665 */ TclFSSplitPath_, /* 666 */ + TclParseArgsObjv_, /* 667 */ }; /* !END!: Do not edit above this line. */ -- cgit v0.12 From 15adceeead8ca31318befa55e31d2af69e34372c Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 26 Jan 2022 14:56:02 +0000 Subject: Add TclParseArgsObjv_ --- doc/ParseArgs.3 | 6 ++--- doc/SplitList.3 | 5 ++-- generic/tcl.decls | 6 ++++- generic/tcl.h | 4 +-- generic/tclDecls.h | 44 +++++++++++++++++++++------------ generic/tclIndexObj.c | 12 ++++----- generic/tclStubInit.c | 68 +++++++++++++++++++++++++++++++++++++++++++++------ generic/tclTest.c | 4 +-- 8 files changed, 110 insertions(+), 39 deletions(-) diff --git a/doc/ParseArgs.3 b/doc/ParseArgs.3 index 02b52d4..ec5a29e 100644 --- a/doc/ParseArgs.3 +++ b/doc/ParseArgs.3 @@ -142,16 +142,16 @@ there are no following arguments at all, and the \fIdstPtr\fR argument to the \fBTCL_ARGV_GENFUNC\fR . This argument takes zero or more following arguments; the handler callback -function passed in \fIsrcPtr\fR returns how many (or a negative number to +function passed in \fIsrcPtr\fR returns how many (or TCL_INDEX_NONE to signal an error, in which case it should also set the interpreter result). The function will have the following signature: .RS .PP .CS -typedef int (\fBTcl_ArgvGenFuncProc\fR)( +typedef size_t (\fBTcl_ArgvGenFuncProc\fR)( void *\fIclientData\fR, Tcl_Interp *\fIinterp\fR, - int \fIobjc\fR, + size_t \fIobjc\fR, Tcl_Obj *const *\fIobjv\fR, void *\fIdstPtr\fR); .CE diff --git a/doc/SplitList.3 b/doc/SplitList.3 index 49498e2..696906c 100644 --- a/doc/SplitList.3 +++ b/doc/SplitList.3 @@ -81,7 +81,8 @@ For example, suppose that you have called \fBTcl_SplitList\fR with the following code: .PP .CS -int argc, code; +size_t argc; +int code; char *string; char **argv; \&... @@ -92,7 +93,7 @@ Then you should eventually free the storage with a call like the following: .PP .CS -Tcl_Free((char *) argv); +Tcl_Free(argv); .CE .PP \fBTcl_SplitList\fR normally returns \fBTCL_OK\fR, which means the list was diff --git a/generic/tcl.decls b/generic/tcl.decls index 676373b..ebbc850 100644 --- a/generic/tcl.decls +++ b/generic/tcl.decls @@ -2269,7 +2269,7 @@ declare 603 { # TIP#265 (option parser) dkf for Sam Bromley declare 604 { - int Tcl_ParseArgsObjv(Tcl_Interp *interp, const Tcl_ArgvInfo *argTable, + int TclParseArgsObjv_(Tcl_Interp *interp, const Tcl_ArgvInfo *argTable, int *objcPtr, Tcl_Obj *const *objv, Tcl_Obj ***remObjv) } @@ -2527,6 +2527,10 @@ declare 665 { declare 666 { Tcl_Obj *Tcl_FSSplitPath(Tcl_Obj *pathPtr, size_t *lenPtr) } +declare 667 { + int Tcl_ParseArgsObjv(Tcl_Interp *interp, const Tcl_ArgvInfo *argTable, + size_t *objcPtr, Tcl_Obj *const *objv, Tcl_Obj ***remObjv) +} # ----- BASELINE -- FOR -- 8.7.0 ----- # diff --git a/generic/tcl.h b/generic/tcl.h index c3db670..0858f2e 100644 --- a/generic/tcl.h +++ b/generic/tcl.h @@ -2040,8 +2040,8 @@ typedef struct { typedef int (Tcl_ArgvFuncProc)(void *clientData, Tcl_Obj *objPtr, void *dstPtr); -typedef int (Tcl_ArgvGenFuncProc)(void *clientData, Tcl_Interp *interp, - int objc, Tcl_Obj *const *objv, void *dstPtr); +typedef size_t (Tcl_ArgvGenFuncProc)(void *clientData, Tcl_Interp *interp, + size_t objc, Tcl_Obj *const *objv, void *dstPtr); /* * Shorthand for commonly used argTable entries. diff --git a/generic/tclDecls.h b/generic/tclDecls.h index b1c3d10..1a792a8 100644 --- a/generic/tclDecls.h +++ b/generic/tclDecls.h @@ -1598,7 +1598,7 @@ EXTERN int Tcl_SetEnsembleParameterList(Tcl_Interp *interp, EXTERN int Tcl_GetEnsembleParameterList(Tcl_Interp *interp, Tcl_Command token, Tcl_Obj **paramListPtr); /* 604 */ -EXTERN int Tcl_ParseArgsObjv(Tcl_Interp *interp, +EXTERN int TclParseArgsObjv_(Tcl_Interp *interp, const Tcl_ArgvInfo *argTable, int *objcPtr, Tcl_Obj *const *objv, Tcl_Obj ***remObjv); /* 605 */ @@ -1776,6 +1776,11 @@ EXTERN void Tcl_SplitPath(const char *path, size_t *argcPtr, const char ***argvPtr); /* 666 */ EXTERN Tcl_Obj * Tcl_FSSplitPath(Tcl_Obj *pathPtr, size_t *lenPtr); +/* 667 */ +EXTERN int Tcl_ParseArgsObjv(Tcl_Interp *interp, + const Tcl_ArgvInfo *argTable, + size_t *objcPtr, Tcl_Obj *const *objv, + Tcl_Obj ***remObjv); typedef struct { const struct TclPlatStubs *tclPlatStubs; @@ -2391,7 +2396,7 @@ typedef struct TclStubs { unsigned (*tcl_GetBlockSizeFromStat) (const Tcl_StatBuf *statPtr); /* 601 */ int (*tcl_SetEnsembleParameterList) (Tcl_Interp *interp, Tcl_Command token, Tcl_Obj *paramList); /* 602 */ int (*tcl_GetEnsembleParameterList) (Tcl_Interp *interp, Tcl_Command token, Tcl_Obj **paramListPtr); /* 603 */ - int (*tcl_ParseArgsObjv) (Tcl_Interp *interp, const Tcl_ArgvInfo *argTable, int *objcPtr, Tcl_Obj *const *objv, Tcl_Obj ***remObjv); /* 604 */ + int (*tclParseArgsObjv_) (Tcl_Interp *interp, const Tcl_ArgvInfo *argTable, int *objcPtr, Tcl_Obj *const *objv, Tcl_Obj ***remObjv); /* 604 */ int (*tcl_GetErrorLine) (Tcl_Interp *interp); /* 605 */ void (*tcl_SetErrorLine) (Tcl_Interp *interp, int lineNum); /* 606 */ void (*tcl_TransferResult) (Tcl_Interp *sourceInterp, int code, Tcl_Interp *targetInterp); /* 607 */ @@ -2454,6 +2459,7 @@ typedef struct TclStubs { int (*tcl_SplitList) (Tcl_Interp *interp, const char *listStr, size_t *argcPtr, const char ***argvPtr); /* 664 */ void (*tcl_SplitPath) (const char *path, size_t *argcPtr, const char ***argvPtr); /* 665 */ Tcl_Obj * (*tcl_FSSplitPath) (Tcl_Obj *pathPtr, size_t *lenPtr); /* 666 */ + int (*tcl_ParseArgsObjv) (Tcl_Interp *interp, const Tcl_ArgvInfo *argTable, size_t *objcPtr, Tcl_Obj *const *objv, Tcl_Obj ***remObjv); /* 667 */ } TclStubs; extern const TclStubs *tclStubsPtr; @@ -3612,8 +3618,8 @@ extern const TclStubs *tclStubsPtr; (tclStubsPtr->tcl_SetEnsembleParameterList) /* 602 */ #define Tcl_GetEnsembleParameterList \ (tclStubsPtr->tcl_GetEnsembleParameterList) /* 603 */ -#define Tcl_ParseArgsObjv \ - (tclStubsPtr->tcl_ParseArgsObjv) /* 604 */ +#define TclParseArgsObjv_ \ + (tclStubsPtr->tclParseArgsObjv_) /* 604 */ #define Tcl_GetErrorLine \ (tclStubsPtr->tcl_GetErrorLine) /* 605 */ #define Tcl_SetErrorLine \ @@ -3736,6 +3742,8 @@ extern const TclStubs *tclStubsPtr; (tclStubsPtr->tcl_SplitPath) /* 665 */ #define Tcl_FSSplitPath \ (tclStubsPtr->tcl_FSSplitPath) /* 666 */ +#define Tcl_ParseArgsObjv \ + (tclStubsPtr->tcl_ParseArgsObjv) /* 667 */ #endif /* defined(USE_TCL_STUBS) */ @@ -3935,28 +3943,32 @@ extern const TclStubs *tclStubsPtr; #if 0 # undef Tcl_ListObjGetElements # define Tcl_ListObjGetElements(interp, listPtr, objcPtr, objvPtr) (sizeof(*objcPtr) != sizeof(int) \ - ? tclStubsPtr->tcl_ListObjGetElements((interp), (listPtr), (int *)(void *)(objcPtr), (objvPtr)) \ - : tclStubsPtr->tclListObjGetElements_((interp), (listPtr), (size_t *)(void *)(objcPtr), (objvPtr))) + ? tclStubsPtr->tcl_ListObjGetElements((interp), (listPtr), (size_t *)(void *)(objcPtr), (objvPtr)) \ + : tclStubsPtr->tclListObjGetElements_((interp), (listPtr), (int *)(void *)(objcPtr), (objvPtr))) # undef Tcl_ListObjLength # define Tcl_ListObjLength(interp, listPtr, lengthPtr) (sizeof(*lengthPtr) != sizeof(int) \ - ? tclStubsPtr->tcl_ListObjLength((interp), (listPtr), (int *)(void *)(lengthPtr)) \ - : tclStubsPtr->tclListObjLength_((interp), (listPtr), (size_t *)(void *)(lengthPtr))) + ? tclStubsPtr->tcl_ListObjLength((interp), (listPtr), (size_t *)(void *)(lengthPtr)) \ + : tclStubsPtr->tclListObjLength_((interp), (listPtr), (int *)(void *)(lengthPtr))) # undef Tcl_DictObjSize # define Tcl_DictObjSize(interp, dictPtr, sizePtr) (sizeof(*sizePtr) != sizeof(int) \ - ? tclStubsPtr->tcl_DictObjSize((interp), (dictPtr), (int *)(void *)(sizePtr)) \ - : tclStubsPtr->tclDictObjSize_((interp), (dictPtr), (size_t *)(void *)(sizePtr))) + ? tclStubsPtr->tcl_DictObjSize((interp), (dictPtr), (size_t *)(void *)(sizePtr)) \ + : tclStubsPtr->tclDictObjSize_((interp), (dictPtr), (int *)(void *)(sizePtr))) # undef Tcl_SplitList # define Tcl_SplitList(interp, listStr, argcPtr, argvPtr) (sizeof(*argcPtr) != sizeof(int) \ - ? tclStubsPtr->tcl_SplitList((interp), (listStr), (int *)(void *)(argcPtr), (argvPtr)) \ - : tclStubsPtr->tclSplitList_((interp), (listStr), (size_t *)(void *)(argcPtr), (argvPtr))) + ? tclStubsPtr->tcl_SplitList((interp), (listStr), (size_t *)(void *)(argcPtr), (argvPtr)) \ + : tclStubsPtr->tclSplitList_((interp), (listStr), (int *)(void *)(argcPtr), (argvPtr))) # undef Tcl_SplitPath # define Tcl_SplitPath(path, argcPtr, argvPtr) (sizeof(*argcPtr) != sizeof(int) \ - ? tclStubsPtr->tcl_SplitPath((path), (int *)(void *)(argcPtr), (argvPtr)) \ - : tclStubsPtr->tclSplitPath_((path), (size_t *)(void *)(argcPtr), (argvPtr))) + ? tclStubsPtr->tcl_SplitPath((path), (size_t *)(void *)(argcPtr), (argvPtr)) \ + : tclStubsPtr->tclSplitPath_((path), (int *)(void *)(argcPtr), (argvPtr))) # undef Tcl_FSSplitPath # define Tcl_FSSplitPath(pathPtr, lenPtr) (sizeof(*lenPtr) != sizeof(int) \ - ? tclStubsPtr->tcl_FSSplitPath((pathPtr), (int *)(void *)(lenPtr)) \ - : tclStubsPtr->tclFSSplitPath_((pathPtr), (size_t *)(void *)(lenPtr))) + ? tclStubsPtr->tcl_FSSplitPath((pathPtr), (size_t *)(void *)(lenPtr)) \ + : tclStubsPtr->tclFSSplitPath_((pathPtr), (int *)(void *)(lenPtr))) +# undef Tcl_ParseArgsObjv +# define Tcl_ParseArgsObjv(interp, argTable, objcPtr, objv, remObjv) (sizeof(*objcPtr) != sizeof(int) \ + ? tclStubsPtr->tcl_ParseArgsObjv((interp), (argTable), (size_t *)(void *)(objcPtr), (objv), (remObjv)) \ + : tclStubsPtr->tclParseArgsObjv_((interp), (argTable), (int *)(void *)(objcPtr), (objv), (remObjv))) #endif /* TCL_NO_DEPRECATED */ #else # define Tcl_WCharToUtfDString (sizeof(wchar_t) != sizeof(short) \ diff --git a/generic/tclIndexObj.c b/generic/tclIndexObj.c index 35d3977..cef774b 100644 --- a/generic/tclIndexObj.c +++ b/generic/tclIndexObj.c @@ -961,7 +961,7 @@ Tcl_ParseArgsObjv( Tcl_Interp *interp, /* Place to store error message. */ const Tcl_ArgvInfo *argTable, /* Array of option descriptions. */ - int *objcPtr, /* Number of arguments in objv. Modified to + size_t *objcPtr, /* Number of arguments in objv. Modified to * hold # args left in objv at end. */ Tcl_Obj *const *objv, /* Array of arguments to be parsed. */ Tcl_Obj ***remObjv) /* Pointer to array of arguments that were not @@ -971,7 +971,7 @@ Tcl_ParseArgsObjv( Tcl_Obj **leftovers; /* Array to write back to remObjv on * successful exit. Will include the name of * the command. */ - int nrem; /* Size of leftovers.*/ + size_t nrem; /* Size of leftovers.*/ const Tcl_ArgvInfo *infoPtr; /* Pointer to the current entry in the table * of argument descriptions. */ @@ -983,12 +983,12 @@ Tcl_ParseArgsObjv( * quick check for matching; use 2nd char. * because first char. will almost always be * '-'). */ - int srcIndex; /* Location from which to read next argument + size_t srcIndex; /* Location from which to read next argument * from objv. */ - int dstIndex; /* Used to keep track of current arguments + size_t dstIndex; /* Used to keep track of current arguments * being processed, primarily for error * reporting. */ - int objc; /* # arguments in objv still to process. */ + size_t objc; /* # arguments in objv still to process. */ size_t length; /* Number of characters in current argument */ if (remObjv != NULL) { @@ -1147,7 +1147,7 @@ Tcl_ParseArgsObjv( objc = handlerProc(infoPtr->clientData, interp, objc, &objv[srcIndex], infoPtr->dstPtr); - if (objc < 0) { + if ((int)objc < 0) { goto error; } break; diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c index 1b1ad89..e080d44 100644 --- a/generic/tclStubInit.c +++ b/generic/tclStubInit.c @@ -92,57 +92,110 @@ static void uniCodePanic() { #define TclSplitList_ SplitList #define TclSplitPath_ SplitPath #define TclFSSplitPath_ FSSplitPath +#define TclParseArgsObjv_ ParseArgsObjv int LOGetElements(Tcl_Interp *interp, Tcl_Obj *listPtr, int *objcPtr, Tcl_Obj ***objvPtr) { - size_t n; + size_t n = TCL_INDEX_NONE; int result = Tcl_ListObjGetElements(interp, listPtr, &n, objvPtr); if (objcPtr) { + if ((result == TCL_OK) && (n > INT_MAX)) { + if (interp) { + Tcl_AppendResult(interp, "List too large to be processed", NULL); + } + return TCL_ERROR; + } *objcPtr = n; } return result; } int LOLength(Tcl_Interp *interp, Tcl_Obj *listPtr, int *lengthPtr) { - size_t n; + size_t n = TCL_INDEX_NONE; int result = Tcl_ListObjLength(interp, listPtr, &n); if (lengthPtr) { + if ((result == TCL_OK) && (n > INT_MAX)) { + if (interp) { + Tcl_AppendResult(interp, "List too large to be processed", NULL); + } + return TCL_ERROR; + } *lengthPtr = n; } return result; } static int DOSize(Tcl_Interp *interp, Tcl_Obj *dictPtr, int *sizePtr) { - size_t n; + size_t n = TCL_INDEX_NONE; int result = Tcl_DictObjSize(interp, dictPtr, &n); if (sizePtr) { + if ((result == TCL_OK) && (n > INT_MAX)) { + if (interp) { + Tcl_AppendResult(interp, "Dict too large to be processed", NULL); + } + return TCL_ERROR; + } *sizePtr = n; } return result; } static int SplitList(Tcl_Interp *interp, const char *listStr, int *argcPtr, const char ***argvPtr) { - size_t n; + size_t n = TCL_INDEX_NONE; int result = Tcl_SplitList(interp, listStr, &n, argvPtr); if (argcPtr) { + if ((result == TCL_OK) && (n > INT_MAX)) { + if (interp) { + Tcl_AppendResult(interp, "List too large to be processed", NULL); + } + Tcl_Free(*argvPtr); + return TCL_ERROR; + } *argcPtr = n; } return result; } static void SplitPath(const char *path, int *argcPtr, const char ***argvPtr) { - size_t n; + size_t n = TCL_INDEX_NONE; Tcl_SplitPath(path, &n, argvPtr); if (argcPtr) { + if (n > INT_MAX) { + n = TCL_INDEX_NONE; /* No other way to return an error-situation */ + Tcl_Free(*argvPtr); + *argvPtr = NULL; + } *argcPtr = n; } } static Tcl_Obj *FSSplitPath(Tcl_Obj *pathPtr, int *lenPtr) { - size_t n; + size_t n = TCL_INDEX_NONE; Tcl_Obj *result = Tcl_FSSplitPath(pathPtr, &n); if (lenPtr) { + if (result && (n > INT_MAX)) { + Tcl_DecrRefCount(result); + return NULL; + } *lenPtr = n; } return result; } +static int ParseArgsObjv(Tcl_Interp *interp, + const Tcl_ArgvInfo *argTable, int *objcPtr, Tcl_Obj *const *objv, + Tcl_Obj ***remObjv) { + size_t n = TCL_INDEX_NONE; + int result = Tcl_ParseArgsObjv(interp, argTable, &n, objv, remObjv); + if (objcPtr) { + if ((result == TCL_OK) && (n > INT_MAX)) { + if (interp) { + Tcl_AppendResult(interp, "Too many args to be processed", NULL); + } + Tcl_Free(*remObjv); + *remObjv = NULL; + return TCL_ERROR; + } + *objcPtr = n; + } + return result; +} #define TclBN_mp_add mp_add #define TclBN_mp_add_d mp_add_d @@ -1352,7 +1405,7 @@ const TclStubs tclStubs = { Tcl_GetBlockSizeFromStat, /* 601 */ Tcl_SetEnsembleParameterList, /* 602 */ Tcl_GetEnsembleParameterList, /* 603 */ - Tcl_ParseArgsObjv, /* 604 */ + TclParseArgsObjv_, /* 604 */ Tcl_GetErrorLine, /* 605 */ Tcl_SetErrorLine, /* 606 */ Tcl_TransferResult, /* 607 */ @@ -1415,6 +1468,7 @@ const TclStubs tclStubs = { Tcl_SplitList, /* 664 */ Tcl_SplitPath, /* 665 */ Tcl_FSSplitPath, /* 666 */ + Tcl_ParseArgsObjv, /* 667 */ }; /* !END!: Do not edit above this line. */ diff --git a/generic/tclTest.c b/generic/tclTest.c index fc14e1d..7a066fd 100644 --- a/generic/tclTest.c +++ b/generic/tclTest.c @@ -7714,7 +7714,7 @@ TestparseargsCmd( Tcl_Obj *const objv[]) /* Arguments. */ { static int foo = 0; - int count = objc; + size_t count = objc; Tcl_Obj **remObjv, *result[3]; Tcl_ArgvInfo argTable[] = { {TCL_ARGV_CONSTANT, "-bool", INT2PTR(1), &foo, "booltest", NULL}, @@ -7726,7 +7726,7 @@ TestparseargsCmd( return TCL_ERROR; } result[0] = Tcl_NewIntObj(foo); - result[1] = Tcl_NewIntObj(count); + result[1] = Tcl_NewWideIntObj((Tcl_WideUInt)(count + 1) - 1); result[2] = Tcl_NewListObj(count, remObjv); Tcl_SetObjResult(interp, Tcl_NewListObj(3, result)); Tcl_Free(remObjv); -- cgit v0.12 From 5c2bc08ea4edc13e386422d6c6f86bb65014a0a3 Mon Sep 17 00:00:00 2001 From: pooryorick Date: Wed, 26 Jan 2022 17:48:34 +0000 Subject: Add back a clarification to the documentation for [expr] that an operand is interpreted as a number wherever possible, and rework text to be more compact. --- doc/expr.n | 137 +++++++++++++++++++++++++++++++------------------------------ 1 file changed, 69 insertions(+), 68 deletions(-) diff --git a/doc/expr.n b/doc/expr.n index 43ad26f..490217c 100644 --- a/doc/expr.n +++ b/doc/expr.n @@ -17,7 +17,7 @@ expr \- Evaluate an expression .BE .SH DESCRIPTION .PP -The \fIexpr\fR command concatenates \fIarg\fRs, separated by a space, into an expression, and evaluates +Concatenates \fIarg\fRs, separated by a space, into an expression, and evaluates that expression, returning its value. The operators permitted in an expression include a subset of the operators permitted in C expressions. For those operators @@ -37,76 +37,36 @@ operands are specified. Expressions also support non-numeric operands, string comparisons, and some additional operators not found in C. .PP -When an expression evaluates to an integer, the value is the decimal form of -the integer, and when an expression evaluates to a floating-point number, the -value is the form produced by the \fB%g\fR format specifier of Tcl's -\fBformat\fR command. +When the result of expression is an integer, it is in decimal form, and when +the result is a floating-point number, it is in the form produced by the +\fB%g\fR format specifier of \fBformat\fR. .PP .VS "TIP 582" -You can use \fB#\fR at any point in the expression (except inside double -quotes or braces) to start a comment. Comments last to the end of the line or +At any point in the expression except within double quotes or braces, \fB#\fR +is the beginning of a comment, which lasts to the end of the line or the end of the expression, whichever comes first. .VE "TIP 582" .SS OPERANDS .PP An expression consists of a combination of operands, operators, parentheses and commas, possibly with whitespace between any of these elements, which is -ignored. +ignored. Each operand is intepreted as a numeric value if at all possible. .PP -An operand may be specified in any of the following ways: -.IP [1] -As a numeric value, either integer or floating-point. -.IP [2] -As a boolean value, using any form understood by \fBstring is\fR -\fBboolean\fR. -.IP [3] -As a variable, using standard \fB$\fR notation. -The value of the variable is then the value of the operand. -.IP [4] -As a string enclosed in double-quotes. -Backslash, variable, and command substitution are performed as described in -\fBTcl\fR. -.IP [5] -As a string enclosed in braces. -The operand is treated as a braced value as described in \fBTcl\fR. -.IP [6] -As a Tcl command enclosed in brackets. -Command substitution is performed as described in \fBTcl\fR. -.IP [7] -As a mathematical function such as \fBsin($x)\fR, whose arguments have any of the above -forms for operands. See \fBMATH FUNCTIONS\fR below for -a discussion of how mathematical functions are handled. -.PP -Because \fBexpr\fR parses and performs substitutions on values that have -already been parsed and substituted by \fBTcl\fR, it is usually best to enclose -expressions in braces to avoid the first round of substitutions by -\fBTcl\fR. -.PP -Below are some examples of simple expressions where the value of \fBa\fR is 3 -and the value of \fBb\fR is 6. The command on the left side of each line -produces the value on the right side. -.PP -.CS -.ta 9c -\fBexpr\fR {3.1 + $a} \fI6.1\fR -\fBexpr\fR {2 + "$a.$b"} \fI5.6\fR -\fBexpr\fR {4*[llength "6 2"]} \fI8\fR -\fBexpr\fR {{word one} < "word $a"} \fI0\fR -.CE -.PP -\fBInteger value\fR +Each operand has one of the following forms: +.RS .PP -An integer operand may be specified in decimal (the normal case, the optional -first two characters are \fB0d\fR), binary -(the first two characters are \fB0b\fR), octal -(the first two characters are \fB0o\fR), or hexadecimal -(the first two characters are \fB0x\fR) form. For -compatibility with older Tcl releases, an operand that begins with \fB0\fR is -interpreted as an octal integer even if the second character is not \fBo\fR. +.TP +A \fBnumeric value\fR .PP -\fBFloating-point value\fR +.RS +. +Either integer or floating-point. The first two characters of an integer may +also be \fB0d\fR for decimal, \fB0b\fR for binary, \fB0o\fR for octal or +\fB0x\fR for hexadicimal. For compatibility with older Tcl releases, an +operand that begins with \fB0\fR is interpreted as an octal integer even if the +second character is not \fBo\fR. .PP -A floating-point number may be specified in any of several +A floating-point number may be take any of several common decimal formats, and may use the decimal point \fB.\fR, \fBe\fR or \fBE\fR for scientific notation, and the sign characters \fB+\fR and \fB\-\fR. The @@ -116,16 +76,9 @@ and \fBNaN\fR, in any combination of case, are also recognized as floating point values. An operand that doesn't have a numeric interpretation must be quoted with either braces or with double quotes. .PP -\fBBoolean value\fR -.PP -A boolean value may be represented by any of the values \fB0\fR, \fBfalse\fR, \fBno\fR, -or \fBoff\fR and any of the values \fB1\fR, \fBtrue\fR, \fByes\fR, or \fBon\fR. -.PP -\fBDigit Separator\fR -.PP Digits in any numeric value may be separated with one or more underscore -characters, "\fB_\fR", to improve readability. These separators may only -appear between digits. The separator may not appear at the start of a +characters, "\fB_\fR". A separator may only +appear between digits, not appear at the start of a numeric value, between the leading 0 and radix specifier, or at the end of a numeric value. Here are some examples: .PP @@ -135,6 +88,54 @@ end of a numeric value. Here are some examples: \fBexpr\fR 0xffff_ffff \fI4294967295\fR \fBformat\fR 0x%x 0b1111_1110_1101_1011 \fI0xfedb\fR .CE +.RE + +.TP +A \fBboolean value\fR +. +Using any form understood by \fBstring is\fR +\fBboolean\fR. +.TP +A \fBvariable\fR +. +Using standard \fB$\fR notation. +The value of the variable is the value of the operand. +.TP +A string enclosed in \fBdouble-quotes\fR +. +Backslash, variable, and command substitution are performed according to the +rules for \fBTcl\fR. +.TP +A string enclosed in \fBbraces\fR. +The operand is treated as a braced value according to the rule for braces in +\fBTcl\fR. +.TP +A Tcl command enclosed in \fBbrackets\fR +. +Command substitution is performed as according to the command substitution rule +for \fBTcl\fR. +.TP +A mathematical function such as \fBsin($x)\fR, whose arguments have any of the above +forms for operands. See \fBMATH FUNCTIONS\fR below for +a discussion of how mathematical functions are handled. +.RE +.PP +Because \fBexpr\fR parses and performs substitutions on values that have +already been parsed and substituted by \fBTcl\fR, it is usually best to enclose +expressions in braces to avoid the first round of substitutions by +\fBTcl\fR. +.PP +Below are some examples of simple expressions where the value of \fBa\fR is 3 +and the value of \fBb\fR is 6. The command on the left side of each line +produces the value on the right side. +.PP +.CS +.ta 9c +\fBexpr\fR {3.1 + $a} \fI6.1\fR +\fBexpr\fR {2 + "$a.$b"} \fI5.6\fR +\fBexpr\fR {4*[llength {6 2}]} \fI8\fR +\fBexpr\fR {{word one} < "word $a"} \fI0\fR +.CE .PP .SS OPERATORS .PP -- cgit v0.12 From 9afc3ff81d99b4207da8b35d411a83f043b0a4f8 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 26 Jan 2022 23:05:50 +0000 Subject: more progress --- doc/Method.3 | 2 +- doc/WrongNumArgs.3 | 2 +- generic/tcl.decls | 2 +- generic/tclDecls.h | 4 ++-- generic/tclIndexObj.c | 11 +++++------ generic/tclInt.decls | 4 ++-- generic/tclIntDecls.h | 8 ++++---- generic/tclListObj.c | 14 +++++++------- generic/tclOO.c | 2 +- generic/tclOO.decls | 2 +- generic/tclOOBasic.c | 8 ++++---- generic/tclOODecls.h | 4 ++-- generic/tclOODefineCmds.c | 28 ++++++++++++++-------------- generic/tclProc.c | 2 +- 14 files changed, 46 insertions(+), 47 deletions(-) diff --git a/doc/Method.3 b/doc/Method.3 index ac71890..8409b97 100644 --- a/doc/Method.3 +++ b/doc/Method.3 @@ -58,7 +58,7 @@ Tcl_Method Tcl_Object \fBTcl_ObjectContextObject\fR(\fIcontext\fR) .sp -int +size_t \fBTcl_ObjectContextSkippedArgs\fR(\fIcontext\fR) .SH ARGUMENTS .AS void *clientData in diff --git a/doc/WrongNumArgs.3 b/doc/WrongNumArgs.3 index 533cb4f..b501d36 100644 --- a/doc/WrongNumArgs.3 +++ b/doc/WrongNumArgs.3 @@ -19,7 +19,7 @@ Tcl_WrongNumArgs \- generate standard error message for wrong number of argument .AP Tcl_Interp interp in Interpreter in which error will be reported: error message gets stored in its result value. -.AP int objc in +.AP size_t objc in Number of leading arguments from \fIobjv\fR to include in error message. .AP "Tcl_Obj *const" objv[] in diff --git a/generic/tcl.decls b/generic/tcl.decls index ebbc850..33f0321 100644 --- a/generic/tcl.decls +++ b/generic/tcl.decls @@ -968,7 +968,7 @@ declare 263 { size_t Tcl_Write(Tcl_Channel chan, const char *s, size_t slen) } declare 264 { - void Tcl_WrongNumArgs(Tcl_Interp *interp, int objc, + void Tcl_WrongNumArgs(Tcl_Interp *interp, size_t objc, Tcl_Obj *const objv[], const char *message) } declare 265 { diff --git a/generic/tclDecls.h b/generic/tclDecls.h index 1a792a8..7e665ef 100644 --- a/generic/tclDecls.h +++ b/generic/tclDecls.h @@ -714,7 +714,7 @@ EXTERN void * Tcl_VarTraceInfo2(Tcl_Interp *interp, EXTERN size_t Tcl_Write(Tcl_Channel chan, const char *s, size_t slen); /* 264 */ -EXTERN void Tcl_WrongNumArgs(Tcl_Interp *interp, int objc, +EXTERN void Tcl_WrongNumArgs(Tcl_Interp *interp, size_t objc, Tcl_Obj *const objv[], const char *message); /* 265 */ EXTERN int Tcl_DumpActiveMemory(const char *fileName); @@ -2056,7 +2056,7 @@ typedef struct TclStubs { void (*reserved261)(void); void * (*tcl_VarTraceInfo2) (Tcl_Interp *interp, const char *part1, const char *part2, int flags, Tcl_VarTraceProc *procPtr, void *prevClientData); /* 262 */ size_t (*tcl_Write) (Tcl_Channel chan, const char *s, size_t slen); /* 263 */ - void (*tcl_WrongNumArgs) (Tcl_Interp *interp, int objc, Tcl_Obj *const objv[], const char *message); /* 264 */ + void (*tcl_WrongNumArgs) (Tcl_Interp *interp, size_t objc, Tcl_Obj *const objv[], const char *message); /* 264 */ int (*tcl_DumpActiveMemory) (const char *fileName); /* 265 */ void (*tcl_ValidateAllMemory) (const char *file, int line); /* 266 */ void (*reserved267)(void); diff --git a/generic/tclIndexObj.c b/generic/tclIndexObj.c index cef774b..1655fa5 100644 --- a/generic/tclIndexObj.c +++ b/generic/tclIndexObj.c @@ -776,7 +776,7 @@ PrefixLongestObjCmd( void Tcl_WrongNumArgs( Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments to print from objv. */ + size_t objc, /* Number of arguments to print from objv. */ Tcl_Obj *const objv[], /* Initial argument objects, which should be * included in the error message. */ const char *message) /* Error message to print after the leading @@ -784,8 +784,7 @@ Tcl_WrongNumArgs( * NULL. */ { Tcl_Obj *objPtr; - int i; - size_t len, elemLen; + size_t i, len, elemLen; char flags; Interp *iPtr = (Interp *)interp; const char *elementStr; @@ -805,8 +804,8 @@ Tcl_WrongNumArgs( */ if (iPtr->ensembleRewrite.sourceObjs != NULL) { - int toSkip = iPtr->ensembleRewrite.numInsertedObjs; - int toPrint = iPtr->ensembleRewrite.numRemovedObjs; + size_t toSkip = iPtr->ensembleRewrite.numInsertedObjs; + size_t toPrint = iPtr->ensembleRewrite.numRemovedObjs; Tcl_Obj *const *origObjv = TclEnsembleGetRewriteValues(interp); /* @@ -864,7 +863,7 @@ Tcl_WrongNumArgs( * moderately complex condition here). */ - if (i=elemCount) { + if (index>=elemCount) { if (interp != NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "index \"%d\" out of range", index)); + "index \"%" TCL_Z_MODIFIER "d\" out of range", index)); Tcl_SetErrorCode(interp, "TCL", "VALUE", "INDEX", "OUTOFRANGE", NULL); } @@ -1994,7 +1994,7 @@ SetListFromAny( Tcl_DictObjNext(&search, &keyPtr, &valuePtr, &done); } } else { - int estCount; + size_t estCount; size_t length; const char *limit, *nextElem = Tcl_GetStringFromObj(objPtr, &length); @@ -2093,7 +2093,7 @@ UpdateStringOfList( { # define LOCAL_SIZE 64 char localFlags[LOCAL_SIZE], *flagPtr = NULL; - int numElems, i; + size_t numElems, i; size_t length, bytesNeeded = 0; const char *elem, *start; char *dst; diff --git a/generic/tclOO.c b/generic/tclOO.c index b9c976e..00caacd 100644 --- a/generic/tclOO.c +++ b/generic/tclOO.c @@ -3088,7 +3088,7 @@ Tcl_ObjectContextObject( return (Tcl_Object) ((CallContext *)context)->oPtr; } -int +size_t Tcl_ObjectContextSkippedArgs( Tcl_ObjectContext context) { diff --git a/generic/tclOO.decls b/generic/tclOO.decls index c6ffccd..ddccef7 100644 --- a/generic/tclOO.decls +++ b/generic/tclOO.decls @@ -84,7 +84,7 @@ declare 17 { Tcl_Object Tcl_ObjectContextObject(Tcl_ObjectContext context) } declare 18 { - int Tcl_ObjectContextSkippedArgs(Tcl_ObjectContext context) + size_t Tcl_ObjectContextSkippedArgs(Tcl_ObjectContext context) } declare 19 { void *Tcl_ClassGetMetadata(Tcl_Class clazz, diff --git a/generic/tclOOBasic.c b/generic/tclOOBasic.c index eb929c8..ef17896 100644 --- a/generic/tclOOBasic.c +++ b/generic/tclOOBasic.c @@ -85,11 +85,11 @@ TclOO_Class_Constructor( Object *oPtr = (Object *) Tcl_ObjectContextObject(context); Tcl_Obj **invoke, *nameObj; - if (objc-1 > Tcl_ObjectContextSkippedArgs(context)) { + if (objc-1 > (int)Tcl_ObjectContextSkippedArgs(context)) { Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv, "?definitionScript?"); return TCL_ERROR; - } else if (objc == Tcl_ObjectContextSkippedArgs(context)) { + } else if (objc == (int)Tcl_ObjectContextSkippedArgs(context)) { return TCL_OK; } @@ -366,7 +366,7 @@ TclOO_Object_Destroy( Object *oPtr = (Object *) Tcl_ObjectContextObject(context); CallContext *contextPtr; - if (objc != Tcl_ObjectContextSkippedArgs(context)) { + if (objc != (int)Tcl_ObjectContextSkippedArgs(context)) { Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv, NULL); return TCL_ERROR; @@ -738,7 +738,7 @@ TclOO_Object_VarName( CallFrame *framePtr = ((Interp *) interp)->varFramePtr; const char *arg; - if (Tcl_ObjectContextSkippedArgs(context)+1 != objc) { + if ((int)Tcl_ObjectContextSkippedArgs(context)+1 != objc) { Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv, "varName"); return TCL_ERROR; diff --git a/generic/tclOODecls.h b/generic/tclOODecls.h index 6ba5d14..90bd546 100644 --- a/generic/tclOODecls.h +++ b/generic/tclOODecls.h @@ -81,7 +81,7 @@ TCLAPI Tcl_Method Tcl_ObjectContextMethod(Tcl_ObjectContext context); /* 17 */ TCLAPI Tcl_Object Tcl_ObjectContextObject(Tcl_ObjectContext context); /* 18 */ -TCLAPI int Tcl_ObjectContextSkippedArgs( +TCLAPI size_t Tcl_ObjectContextSkippedArgs( Tcl_ObjectContext context); /* 19 */ TCLAPI void * Tcl_ClassGetMetadata(Tcl_Class clazz, @@ -150,7 +150,7 @@ typedef struct TclOOStubs { int (*tcl_ObjectContextIsFiltering) (Tcl_ObjectContext context); /* 15 */ Tcl_Method (*tcl_ObjectContextMethod) (Tcl_ObjectContext context); /* 16 */ Tcl_Object (*tcl_ObjectContextObject) (Tcl_ObjectContext context); /* 17 */ - int (*tcl_ObjectContextSkippedArgs) (Tcl_ObjectContext context); /* 18 */ + size_t (*tcl_ObjectContextSkippedArgs) (Tcl_ObjectContext context); /* 18 */ void * (*tcl_ClassGetMetadata) (Tcl_Class clazz, const Tcl_ObjectMetadataType *typePtr); /* 19 */ void (*tcl_ClassSetMetadata) (Tcl_Class clazz, const Tcl_ObjectMetadataType *typePtr, void *metadata); /* 20 */ void * (*tcl_ObjectGetMetadata) (Tcl_Object object, const Tcl_ObjectMetadataType *typePtr); /* 21 */ diff --git a/generic/tclOODefineCmds.c b/generic/tclOODefineCmds.c index 4676599..4b4f7f2 100644 --- a/generic/tclOODefineCmds.c +++ b/generic/tclOODefineCmds.c @@ -2324,7 +2324,7 @@ ClassFilterGet( Tcl_Obj *resultObj, *filterObj; int i; - if (Tcl_ObjectContextSkippedArgs(context) != objc) { + if ((int)Tcl_ObjectContextSkippedArgs(context) != objc) { Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv, NULL); return TCL_ERROR; @@ -2358,7 +2358,7 @@ ClassFilterSet( int filterc; Tcl_Obj **filterv; - if (Tcl_ObjectContextSkippedArgs(context) + 1 != objc) { + if ((int)Tcl_ObjectContextSkippedArgs(context) + 1 != objc) { Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv, "filterList"); return TCL_ERROR; @@ -2405,7 +2405,7 @@ ClassMixinGet( Class *mixinPtr; int i; - if (Tcl_ObjectContextSkippedArgs(context) != objc) { + if ((int)Tcl_ObjectContextSkippedArgs(context) != objc) { Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv, NULL); return TCL_ERROR; @@ -2442,7 +2442,7 @@ ClassMixinSet( Tcl_Obj **mixinv; Class **mixins; - if (Tcl_ObjectContextSkippedArgs(context) + 1 != objc) { + if ((int)Tcl_ObjectContextSkippedArgs(context) + 1 != objc) { Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv, "mixinList"); return TCL_ERROR; @@ -2511,7 +2511,7 @@ ClassSuperGet( Class *superPtr; int i; - if (Tcl_ObjectContextSkippedArgs(context) != objc) { + if ((int)Tcl_ObjectContextSkippedArgs(context) != objc) { Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv, NULL); return TCL_ERROR; @@ -2547,7 +2547,7 @@ ClassSuperSet( Tcl_Obj **superv; Class **superclasses, *superPtr; - if (Tcl_ObjectContextSkippedArgs(context) + 1 != objc) { + if ((int)Tcl_ObjectContextSkippedArgs(context) + 1 != objc) { Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv, "superclassList"); return TCL_ERROR; @@ -2677,7 +2677,7 @@ ClassVarsGet( Tcl_Obj *resultObj; int i; - if (Tcl_ObjectContextSkippedArgs(context) != objc) { + if ((int)Tcl_ObjectContextSkippedArgs(context) != objc) { Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv, NULL); return TCL_ERROR; @@ -2722,7 +2722,7 @@ ClassVarsSet( Tcl_Obj **varv; int i; - if (Tcl_ObjectContextSkippedArgs(context) + 1 != objc) { + if ((int)Tcl_ObjectContextSkippedArgs(context) + 1 != objc) { Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv, "filterList"); return TCL_ERROR; @@ -2792,7 +2792,7 @@ ObjFilterGet( Tcl_Obj *resultObj, *filterObj; int i; - if (Tcl_ObjectContextSkippedArgs(context) != objc) { + if ((int)Tcl_ObjectContextSkippedArgs(context) != objc) { Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv, NULL); return TCL_ERROR; @@ -2820,7 +2820,7 @@ ObjFilterSet( int filterc; Tcl_Obj **filterv; - if (Tcl_ObjectContextSkippedArgs(context) + 1 != objc) { + if ((int)Tcl_ObjectContextSkippedArgs(context) + 1 != objc) { Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv, "filterList"); return TCL_ERROR; @@ -2861,7 +2861,7 @@ ObjMixinGet( Class *mixinPtr; int i; - if (Tcl_ObjectContextSkippedArgs(context) != objc) { + if ((int)Tcl_ObjectContextSkippedArgs(context) != objc) { Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv, NULL); return TCL_ERROR; @@ -2894,7 +2894,7 @@ ObjMixinSet( Class **mixins; int i; - if (Tcl_ObjectContextSkippedArgs(context) + 1 != objc) { + if ((int)Tcl_ObjectContextSkippedArgs(context) + 1 != objc) { Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv, "mixinList"); return TCL_ERROR; @@ -2946,7 +2946,7 @@ ObjVarsGet( Tcl_Obj *resultObj; int i; - if (Tcl_ObjectContextSkippedArgs(context) != objc) { + if ((int)Tcl_ObjectContextSkippedArgs(context) != objc) { Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv, NULL); return TCL_ERROR; @@ -2984,7 +2984,7 @@ ObjVarsSet( int varc, i; Tcl_Obj **varv; - if (Tcl_ObjectContextSkippedArgs(context) + 1 != objc) { + if ((int)Tcl_ObjectContextSkippedArgs(context) + 1 != objc) { Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv, "variableList"); return TCL_ERROR; diff --git a/generic/tclProc.c b/generic/tclProc.c index 0162def..5f4d884 100644 --- a/generic/tclProc.c +++ b/generic/tclProc.c @@ -1649,7 +1649,7 @@ TclNRInterpProcCore( Tcl_Interp *interp,/* Interpreter in which procedure was * invoked. */ Tcl_Obj *procNameObj, /* Procedure name for error reporting. */ - int skip, /* Number of initial arguments to be skipped, + size_t skip, /* Number of initial arguments to be skipped, * i.e., words in the "command name". */ ProcErrorProc *errorProc) /* How to convert results from the script into * results of the overall procedure. */ -- cgit v0.12 From 1ed443d5c08e7a7cb65c6dabcd959c8b4f3cb51d Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 27 Jan 2022 15:15:33 +0000 Subject: More progress --- generic/tcl.decls | 2 +- generic/tclBasic.c | 34 +++++++++++++++--------------- generic/tclClock.c | 32 ++++++++++++++-------------- generic/tclCmdIL.c | 50 +++++++++++++++++++++++--------------------- generic/tclCmdMZ.c | 18 ++++++++-------- generic/tclCompCmds.c | 12 ++++++----- generic/tclCompCmdsSZ.c | 28 ++++++++++++------------- generic/tclCompExpr.c | 6 +++--- generic/tclDecls.h | 4 ++-- generic/tclDictObj.c | 4 ++-- generic/tclDisassemble.c | 8 +++---- generic/tclEncoding.c | 26 +++++++++++------------ generic/tclEvent.c | 5 +++-- generic/tclExecute.c | 54 ++++++++++++++++++++++++------------------------ generic/tclIndexObj.c | 17 ++++++++------- generic/tclInt.decls | 2 +- generic/tclInt.h | 2 +- generic/tclIntDecls.h | 4 ++-- generic/tclInterp.c | 9 ++++---- generic/tclStubInit.c | 4 ++-- 20 files changed, 164 insertions(+), 157 deletions(-) diff --git a/generic/tcl.decls b/generic/tcl.decls index 33f0321..ff2460f 100644 --- a/generic/tcl.decls +++ b/generic/tcl.decls @@ -1093,7 +1093,7 @@ declare 291 { int flags) } declare 292 { - int Tcl_EvalObjv(Tcl_Interp *interp, int objc, Tcl_Obj *const objv[], + int Tcl_EvalObjv(Tcl_Interp *interp, size_t objc, Tcl_Obj *const objv[], int flags) } declare 293 { diff --git a/generic/tclBasic.c b/generic/tclBasic.c index e7380d9..cbf613b 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -4226,7 +4226,7 @@ int Tcl_EvalObjv( Tcl_Interp *interp, /* Interpreter in which to evaluate the * command. Also used for error reporting. */ - int objc, /* Number of words in command. */ + size_t objc, /* Number of words in command. */ Tcl_Obj *const objv[], /* An array of pointers to objects that are * the words that make up the command. */ int flags) /* Collection of OR-ed bits that control the @@ -4245,7 +4245,7 @@ int TclNREvalObjv( Tcl_Interp *interp, /* Interpreter in which to evaluate the * command. Also used for error reporting. */ - int objc, /* Number of words in command. */ + size_t objc, /* Number of words in command. */ Tcl_Obj *const objv[], /* An array of pointers to objects that are * the words that make up the command. */ int flags, /* Collection of OR-ed bits that control the @@ -4682,7 +4682,7 @@ TEOV_NotFound( { Command * cmdPtr; Interp *iPtr = (Interp *) interp; - int i, newObjc, handlerObjc; + size_t i, newObjc, handlerObjc; Tcl_Obj **newObjv, **handlerObjv; CallFrame *varFramePtr = iPtr->varFramePtr; Namespace *currNsPtr = NULL;/* Used to check for and invoke any registered @@ -4714,7 +4714,7 @@ TEOV_NotFound( * itself. */ - TclListObjGetElements_(NULL, currNsPtr->unknownHandlerPtr, + Tcl_ListObjGetElements(NULL, currNsPtr->unknownHandlerPtr, &handlerObjc, &handlerObjv); newObjc = objc + handlerObjc; newObjv = (Tcl_Obj **)TclStackAlloc(interp, sizeof(Tcl_Obj *) * newObjc); @@ -5220,9 +5220,9 @@ TclEvalEx( objv[objectsUsed] = Tcl_GetObjResult(interp); Tcl_IncrRefCount(objv[objectsUsed]); if (tokenPtr->type == TCL_TOKEN_EXPAND_WORD) { - int numElements; + size_t numElements; - code = TclListObjLength_(interp, objv[objectsUsed], + code = Tcl_ListObjLength(interp, objv[objectsUsed], &numElements); if (code == TCL_ERROR) { /* @@ -5271,10 +5271,10 @@ TclEvalEx( objectsUsed = 0; while (wordIdx--) { if (expand[wordIdx]) { - int numElements; + size_t numElements; Tcl_Obj **elements, *temp = copy[wordIdx]; - TclListObjGetElements_(NULL, temp, &numElements, + Tcl_ListObjGetElements(NULL, temp, &numElements, &elements); objectsUsed += numElements; while (numElements--) { @@ -5968,7 +5968,7 @@ TclNREvalObjEx( if (TclListObjIsCanonical(objPtr)) { CmdFrame *eoFramePtr = NULL; - int objc; + size_t objc; Tcl_Obj *listPtr, **objv; /* @@ -6037,7 +6037,7 @@ TclNREvalObjEx( TclNRAddCallback(interp, TEOEx_ListCallback, listPtr, eoFramePtr, objPtr, NULL); - TclListObjGetElements_(NULL, listPtr, &objc, &objv); + Tcl_ListObjGetElements(NULL, listPtr, &objc, &objv); return TclNREvalObjv(interp, objc, objv, flags, NULL); } @@ -8637,10 +8637,10 @@ TclNRTailcallEval( Interp *iPtr = (Interp *) interp; Tcl_Obj *listPtr = (Tcl_Obj *)data[0], *nsObjPtr; Tcl_Namespace *nsPtr; - int objc; + size_t objc; Tcl_Obj **objv; - TclListObjGetElements_(interp, listPtr, &objc, &objv); + Tcl_ListObjGetElements(interp, listPtr, &objc, &objv); nsObjPtr = objv[0]; if (result == TCL_OK) { @@ -9062,7 +9062,7 @@ TclNREvalList( Tcl_Interp *interp, TCL_UNUSED(int) /*result*/) { - int objc; + size_t objc; Tcl_Obj **objv; Tcl_Obj *listPtr = (Tcl_Obj *)data[0]; @@ -9070,7 +9070,7 @@ TclNREvalList( TclMarkTailcall(interp); TclNRAddCallback(interp, TclNRReleaseValues, listPtr, NULL, NULL,NULL); - TclListObjGetElements_(NULL, listPtr, &objc, &objv); + Tcl_ListObjGetElements(NULL, listPtr, &objc, &objv); return TclNREvalObjv(interp, objc, objv, 0, NULL); } @@ -9326,7 +9326,7 @@ InjectHandler( Tcl_Obj *listPtr = (Tcl_Obj *)data[1]; int nargs = PTR2INT(data[2]); void *isProbe = data[3]; - int objc; + size_t objc; Tcl_Obj **objv; if (!isProbe) { @@ -9345,7 +9345,7 @@ InjectHandler( * I don't think this is reachable... */ - Tcl_ListObjAppendElement(NULL, listPtr, Tcl_NewIntObj(nargs)); + Tcl_ListObjAppendElement(NULL, listPtr, Tcl_NewWideIntObj(nargs)); } Tcl_ListObjAppendElement(NULL, listPtr, Tcl_GetObjResult(interp)); } @@ -9358,7 +9358,7 @@ InjectHandler( TclMarkTailcall(interp); TclNRAddCallback(interp, InjectHandlerPostCall, corPtr, listPtr, INT2PTR(nargs), isProbe); - TclListObjGetElements_(NULL, listPtr, &objc, &objv); + Tcl_ListObjGetElements(NULL, listPtr, &objc, &objv); return TclNREvalObjv(interp, objc, objv, 0, NULL); } diff --git a/generic/tclClock.c b/generic/tclClock.c index f2b6f86..85274e6 100644 --- a/generic/tclClock.c +++ b/generic/tclClock.c @@ -142,17 +142,17 @@ TCL_DECLARE_MUTEX(clockMutex) static int ConvertUTCToLocal(Tcl_Interp *, TclDateFields *, Tcl_Obj *, int); static int ConvertUTCToLocalUsingTable(Tcl_Interp *, - TclDateFields *, int, Tcl_Obj *const[]); + TclDateFields *, size_t, Tcl_Obj *const[]); static int ConvertUTCToLocalUsingC(Tcl_Interp *, TclDateFields *, int); static int ConvertLocalToUTC(Tcl_Interp *, TclDateFields *, Tcl_Obj *, int); static int ConvertLocalToUTCUsingTable(Tcl_Interp *, - TclDateFields *, int, Tcl_Obj *const[]); + TclDateFields *, size_t, Tcl_Obj *const[]); static int ConvertLocalToUTCUsingC(Tcl_Interp *, TclDateFields *, int); static Tcl_Obj * LookupLastTransition(Tcl_Interp *, Tcl_WideInt, - int, Tcl_Obj *const *); + size_t, Tcl_Obj *const *); static void GetYearWeekDay(TclDateFields *, int); static void GetGregorianEraYearDay(TclDateFields *, int); static void GetMonthDay(TclDateFields *); @@ -747,14 +747,14 @@ ConvertLocalToUTC( Tcl_Obj *tzdata, /* Time zone data */ int changeover) /* Julian Day of the Gregorian transition */ { - int rowc; /* Number of rows in tzdata */ + size_t rowc; /* Number of rows in tzdata */ Tcl_Obj **rowv; /* Pointers to the rows */ /* * Unpack the tz data. */ - if (TclListObjGetElements_(interp, tzdata, &rowc, &rowv) != TCL_OK) { + if (Tcl_ListObjGetElements(interp, tzdata, &rowc, &rowv) != TCL_OK) { return TCL_ERROR; } @@ -792,11 +792,11 @@ static int ConvertLocalToUTCUsingTable( Tcl_Interp *interp, /* Tcl interpreter */ TclDateFields *fields, /* Time to convert, with 'seconds' filled in */ - int rowc, /* Number of points at which time changes */ + size_t rowc, /* Number of points at which time changes */ Tcl_Obj *const rowv[]) /* Points at which time changes */ { Tcl_Obj *row; - int cellc; + size_t cellc; Tcl_Obj **cellv; int have[8]; int nHave = 0; @@ -819,7 +819,7 @@ ConvertLocalToUTCUsingTable( while (!found) { row = LookupLastTransition(interp, fields->seconds, rowc, rowv); if ((row == NULL) - || TclListObjGetElements_(interp, row, &cellc, + || Tcl_ListObjGetElements(interp, row, &cellc, &cellv) != TCL_OK || TclGetIntFromObj(interp, cellv[1], &fields->tzOffset) != TCL_OK) { @@ -950,14 +950,14 @@ ConvertUTCToLocal( Tcl_Obj *tzdata, /* Time zone data */ int changeover) /* Julian Day of the Gregorian transition */ { - int rowc; /* Number of rows in tzdata */ + size_t rowc; /* Number of rows in tzdata */ Tcl_Obj **rowv; /* Pointers to the rows */ /* * Unpack the tz data. */ - if (TclListObjGetElements_(interp, tzdata, &rowc, &rowv) != TCL_OK) { + if (Tcl_ListObjGetElements(interp, tzdata, &rowc, &rowv) != TCL_OK) { return TCL_ERROR; } @@ -995,12 +995,12 @@ static int ConvertUTCToLocalUsingTable( Tcl_Interp *interp, /* Tcl interpreter */ TclDateFields *fields, /* Fields of the date */ - int rowc, /* Number of rows in the conversion table + size_t rowc, /* Number of rows in the conversion table * (>= 1) */ Tcl_Obj *const rowv[]) /* Rows of the conversion table */ { Tcl_Obj *row; /* Row containing the current information */ - int cellc; /* Count of cells in the row (must be 4) */ + size_t cellc; /* Count of cells in the row (must be 4) */ Tcl_Obj **cellv; /* Pointers to the cells */ /* @@ -1009,7 +1009,7 @@ ConvertUTCToLocalUsingTable( row = LookupLastTransition(interp, fields->seconds, rowc, rowv); if (row == NULL || - TclListObjGetElements_(interp, row, &cellc, &cellv) != TCL_OK || + Tcl_ListObjGetElements(interp, row, &cellc, &cellv) != TCL_OK || TclGetIntFromObj(interp, cellv[1], &fields->tzOffset) != TCL_OK) { return TCL_ERROR; } @@ -1135,11 +1135,11 @@ static Tcl_Obj * LookupLastTransition( Tcl_Interp *interp, /* Interpreter for error messages */ Tcl_WideInt tick, /* Time from the epoch */ - int rowc, /* Number of rows of tzdata */ + size_t rowc, /* Number of rows of tzdata */ Tcl_Obj *const *rowv) /* Rows in tzdata */ { - int l; - int u; + size_t l; + size_t u; Tcl_Obj *compObj; Tcl_WideInt compVal; diff --git a/generic/tclCmdIL.c b/generic/tclCmdIL.c index 8cb6b08..e430d99 100644 --- a/generic/tclCmdIL.c +++ b/generic/tclCmdIL.c @@ -2399,15 +2399,15 @@ Tcl_LinsertObjCmd( Tcl_Obj *const objv[]) /* Argument objects. */ { Tcl_Obj *listPtr; - size_t index; - int len, result; + size_t len, index; + int result; if (objc < 3) { Tcl_WrongNumArgs(interp, 1, objv, "list index ?element ...?"); return TCL_ERROR; } - result = TclListObjLength_(interp, objv[1], &len); + result = Tcl_ListObjLength(interp, objv[1], &len); if (result != TCL_OK) { return result; } @@ -2422,7 +2422,7 @@ Tcl_LinsertObjCmd( if (result != TCL_OK) { return result; } - if (index + 1 > (size_t)len + 1) { + if (index + 1 > len + 1) { index = len; } @@ -2436,7 +2436,7 @@ Tcl_LinsertObjCmd( listPtr = TclListObjCopy(NULL, listPtr); } - if ((objc == 4) && (index == (size_t)len)) { + if ((objc == 4) && (index == len)) { /* * Special case: insert one element at the end of the list. */ @@ -2518,14 +2518,15 @@ Tcl_LlengthObjCmd( Tcl_Obj *const objv[]) /* Argument objects. */ { - int listLen, result; + size_t listLen; + int result; if (objc != 2) { Tcl_WrongNumArgs(interp, 1, objv, "list"); return TCL_ERROR; } - result = TclListObjLength_(interp, objv[1], &listLen); + result = Tcl_ListObjLength(interp, objv[1], &listLen); if (result != TCL_OK) { return result; } @@ -2665,15 +2666,15 @@ Tcl_LrangeObjCmd( Tcl_Obj *const objv[]) /* Argument objects. */ { - int listLen, result; - size_t first, last; + int result; + size_t listLen, first, last; if (objc != 4) { Tcl_WrongNumArgs(interp, 1, objv, "list first last"); return TCL_ERROR; } - result = TclListObjLength_(interp, objv[1], &listLen); + result = Tcl_ListObjLength(interp, objv[1], &listLen); if (result != TCL_OK) { return result; } @@ -2733,8 +2734,8 @@ Tcl_LremoveObjCmd( int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - int i, idxc, listLen, prevIdx, first, num; - size_t *idxv; + int i, idxc, prevIdx, first, num; + size_t *idxv, listLen; Tcl_Obj *listObj; /* @@ -2747,7 +2748,7 @@ Tcl_LremoveObjCmd( } listObj = objv[1]; - if (TclListObjLength_(interp, listObj, &listLen) != TCL_OK) { + if (Tcl_ListObjLength(interp, listObj, &listLen) != TCL_OK) { return TCL_ERROR; } @@ -2794,7 +2795,7 @@ Tcl_LremoveObjCmd( continue; } prevIdx = idx; - if (idx < 0 || idx >= listLen) { + if (idx < 0 || idx >= (int)listLen) { continue; } @@ -2962,8 +2963,8 @@ Tcl_LreplaceObjCmd( Tcl_Obj *const objv[]) /* Argument objects. */ { Tcl_Obj *listPtr; - size_t first, last; - int listLen, numToDelete, result; + size_t numToDelete, listLen, first, last; + int result; if (objc < 4) { Tcl_WrongNumArgs(interp, 1, objv, @@ -2971,7 +2972,7 @@ Tcl_LreplaceObjCmd( return TCL_ERROR; } - result = TclListObjLength_(interp, objv[1], &listLen); + result = Tcl_ListObjLength(interp, objv[1], &listLen); if (result != TCL_OK) { return result; } @@ -2994,11 +2995,11 @@ Tcl_LreplaceObjCmd( if (first == TCL_INDEX_NONE) { first = 0; - } else if (first > (size_t)listLen) { + } else if (first > listLen) { first = listLen; } - if (last + 1 > (size_t)listLen) { + if (last + 1 > listLen) { last = listLen - 1; } if (first + 1 <= last + 1) { @@ -4626,7 +4627,7 @@ SortCompare( order = ((a >= b) - (a <= b)); } else { Tcl_Obj **objv, *paramObjv[2]; - int objc; + size_t objc; Tcl_Obj *objPtr1, *objPtr2; if (infoPtr->resultCode != TCL_OK) { @@ -4650,10 +4651,10 @@ SortCompare( * Replace them and evaluate the result. */ - TclListObjLength_(infoPtr->interp, infoPtr->compareCmdPtr, &objc); + Tcl_ListObjLength(infoPtr->interp, infoPtr->compareCmdPtr, &objc); Tcl_ListObjReplace(infoPtr->interp, infoPtr->compareCmdPtr, objc - 2, 2, 2, paramObjv); - TclListObjGetElements_(infoPtr->interp, infoPtr->compareCmdPtr, + Tcl_ListObjGetElements(infoPtr->interp, infoPtr->compareCmdPtr, &objc, &objv); infoPtr->resultCode = Tcl_EvalObjv(infoPtr->interp, objc, objv, 0); @@ -4860,10 +4861,11 @@ SelectObjFromSublist( */ for (i=0 ; iindexc ; i++) { - int listLen, index; + size_t listLen; + int index; Tcl_Obj *currentObj; - if (TclListObjLength_(infoPtr->interp, objPtr, &listLen) != TCL_OK) { + if (Tcl_ListObjLength(infoPtr->interp, objPtr, &listLen) != TCL_OK) { infoPtr->resultCode = TCL_ERROR; return NULL; } diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c index 6ef3220..3d2cda3 100644 --- a/generic/tclCmdMZ.c +++ b/generic/tclCmdMZ.c @@ -1525,9 +1525,8 @@ StringIsCmd( { const char *string1, *end, *stop; int (*chcomp)(int) = NULL; /* The UniChar comparison function. */ - int i, result = 1, strict = 0, index, length3; - size_t failat = 0; - size_t length1, length2; + int i, result = 1, strict = 0, index; + size_t failat = 0, length1, length2, length3; Tcl_Obj *objPtr, *failVarObj = NULL; Tcl_WideInt w; @@ -1814,7 +1813,7 @@ StringIsCmd( * well-formed lists. */ - if (TCL_OK == TclListObjLength_(NULL, objPtr, &length3)) { + if (TCL_OK == Tcl_ListObjLength(NULL, objPtr, &length3)) { break; } @@ -3956,7 +3955,7 @@ Tcl_ThrowObjCmd( Tcl_Obj *const objv[]) /* Argument objects. */ { Tcl_Obj *options; - int len; + size_t len; if (objc != 3) { Tcl_WrongNumArgs(interp, 1, objv, "type message"); @@ -3967,7 +3966,7 @@ Tcl_ThrowObjCmd( * The type must be a list of at least length 1. */ - if (TclListObjLength_(interp, objv[1], &len) != TCL_OK) { + if (Tcl_ListObjLength(interp, objv[1], &len) != TCL_OK) { return TCL_ERROR; } else if (len < 1) { Tcl_SetObjResult(interp, Tcl_NewStringObj( @@ -4672,7 +4671,8 @@ TclNRTryObjCmd( Tcl_Obj *const objv[]) /* Argument objects. */ { Tcl_Obj *bodyObj, *handlersObj, *finallyObj = NULL; - int i, bodyShared, haveHandlers, dummy, code; + int i, bodyShared, haveHandlers, code; + size_t dummy; static const char *const handlerNames[] = { "finally", "on", "trap", NULL }; @@ -4755,7 +4755,7 @@ TclNRTryObjCmd( return TCL_ERROR; } code = 1; - if (TclListObjLength_(NULL, objv[i+1], &dummy) != TCL_OK) { + if (Tcl_ListObjLength(NULL, objv[i+1], &dummy) != TCL_OK) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "bad prefix '%s': must be a list", TclGetString(objv[i+1]))); @@ -4767,7 +4767,7 @@ TclNRTryObjCmd( info[2] = objv[i+1]; commonHandler: - if (TclListObjLength_(interp, objv[i+2], &dummy) != TCL_OK) { + if (Tcl_ListObjLength(interp, objv[i+2], &dummy) != TCL_OK) { Tcl_DecrRefCount(handlersObj); return TCL_ERROR; } diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c index b1f5fe5..c7da104 100644 --- a/generic/tclCompCmds.c +++ b/generic/tclCompCmds.c @@ -286,7 +286,8 @@ TclCompileArraySetCmd( DefineLineInformation; /* TIP #280 */ Tcl_Token *varTokenPtr, *dataTokenPtr; int isScalar, localIndex, code = TCL_OK; - int isDataLiteral, isDataValid, isDataEven, len; + int isDataLiteral, isDataValid, isDataEven; + size_t len; int keyVar, valVar, infoIndex; int fwd, offsetBack, offsetFwd; Tcl_Obj *literalObj; @@ -301,7 +302,7 @@ TclCompileArraySetCmd( TclNewObj(literalObj); isDataLiteral = TclWordKnownAtCompileTime(dataTokenPtr, literalObj); isDataValid = (isDataLiteral - && TclListObjLength_(NULL, literalObj, &len) == TCL_OK); + && Tcl_ListObjLength(NULL, literalObj, &len) == TCL_OK); isDataEven = (isDataValid && (len & 1) == 0); /* @@ -2688,7 +2689,8 @@ CompileEachloopCmd( Tcl_Token *tokenPtr, *bodyTokenPtr; int jumpBackOffset, infoIndex, range; - int numWords, numLists, i, j, code = TCL_OK; + int numWords, numLists, i, code = TCL_OK; + size_t j; Tcl_Obj *varListObj = NULL; /* @@ -2740,7 +2742,7 @@ CompileEachloopCmd( i < numWords-1; i++, tokenPtr = TokenAfter(tokenPtr)) { ForeachVarList *varListPtr; - int numVars; + size_t numVars; if (i%2 != 1) { continue; @@ -2753,7 +2755,7 @@ CompileEachloopCmd( */ if (!TclWordKnownAtCompileTime(tokenPtr, varListObj) || - TCL_OK != TclListObjLength_(NULL, varListObj, &numVars) || + TCL_OK != Tcl_ListObjLength(NULL, varListObj, &numVars) || numVars == 0) { code = TCL_ERROR; goto done; diff --git a/generic/tclCompCmdsSZ.c b/generic/tclCompCmdsSZ.c index 960e85a..4d9e0dc 100644 --- a/generic/tclCompCmdsSZ.c +++ b/generic/tclCompCmdsSZ.c @@ -917,8 +917,7 @@ TclCompileStringMapCmd( Tcl_Token *mapTokenPtr, *stringTokenPtr; Tcl_Obj *mapObj, **objv; const char *bytes; - int len; - size_t slen; + size_t len, slen; /* * We only handle the case: @@ -940,7 +939,7 @@ TclCompileStringMapCmd( if (!TclWordKnownAtCompileTime(mapTokenPtr, mapObj)) { Tcl_DecrRefCount(mapObj); return TclCompileBasic2ArgCmd(interp, parsePtr, cmdPtr, envPtr); - } else if (TclListObjGetElements_(NULL, mapObj, &len, &objv) != TCL_OK) { + } else if (Tcl_ListObjGetElements(NULL, mapObj, &len, &objv) != TCL_OK) { Tcl_DecrRefCount(mapObj); return TclCompileBasic2ArgCmd(interp, parsePtr, cmdPtr, envPtr); } else if (len != 2) { @@ -2711,7 +2710,8 @@ TclCompileThrowCmd( int numWords = parsePtr->numWords; Tcl_Token *codeToken, *msgToken; Tcl_Obj *objPtr; - int codeKnown, codeIsList, codeIsValid, len; + int codeKnown, codeIsList, codeIsValid; + size_t len; if (numWords != 3) { return TCL_ERROR; @@ -2735,7 +2735,7 @@ TclCompileThrowCmd( CompileWord(envPtr, msgToken, interp, 2); codeIsList = codeKnown && (TCL_OK == - TclListObjLength_(interp, objPtr, &len)); + Tcl_ListObjLength(interp, objPtr, &len)); codeIsValid = codeIsList && (len != 0); if (codeIsValid) { @@ -2852,7 +2852,7 @@ TclCompileTryCmd( for (i=0 ; itype != TCL_TOKEN_SIMPLE_WORD) { goto failedToCompile; @@ -2868,7 +2868,7 @@ TclCompileTryCmd( TclNewObj(tmpObj); Tcl_IncrRefCount(tmpObj); if (!TclWordKnownAtCompileTime(tokenPtr, tmpObj) - || TclListObjLength_(NULL, tmpObj, &objc) != TCL_OK + || Tcl_ListObjLength(NULL, tmpObj, &objc) != TCL_OK || (objc == 0)) { TclDecrRefCount(tmpObj); goto failedToCompile; @@ -2911,7 +2911,7 @@ TclCompileTryCmd( TclDecrRefCount(tmpObj); goto failedToCompile; } - if (TclListObjGetElements_(NULL, tmpObj, &objc, &objv) != TCL_OK + if (Tcl_ListObjGetElements(NULL, tmpObj, &objc, &objv) != TCL_OK || (objc > 2)) { TclDecrRefCount(tmpObj); goto failedToCompile; @@ -3047,8 +3047,8 @@ IssueTryClausesInstructions( { DefineLineInformation; /* TIP #280 */ int range, resultVar, optionsVar; - int i, j, len, forwardsNeedFixing = 0, trapZero = 0, afterBody = 0; - size_t slen; + int i, j, forwardsNeedFixing = 0, trapZero = 0, afterBody = 0; + size_t slen, len; int *addrsToFix, *forwardsToFix, notCodeJumpSource, notECJumpSource; int *noError; char buf[TCL_INTEGER_SPACE]; @@ -3123,7 +3123,7 @@ IssueTryClausesInstructions( JUMP4( JUMP_FALSE, notCodeJumpSource); if (matchClauses[i]) { const char *p; - TclListObjLength_(NULL, matchClauses[i], &len); + Tcl_ListObjLength(NULL, matchClauses[i], &len); /* * Match the errorcode according to try/trap rules. @@ -3258,11 +3258,11 @@ IssueTryClausesFinallyInstructions( Tcl_Token *finallyToken) /* Not NULL */ { DefineLineInformation; /* TIP #280 */ - int range, resultVar, optionsVar, i, j, len, forwardsNeedFixing = 0; + int range, resultVar, optionsVar, i, j, forwardsNeedFixing = 0; int trapZero = 0, afterBody = 0, finalOK, finalError, noFinalError; int *addrsToFix, *forwardsToFix, notCodeJumpSource, notECJumpSource; char buf[TCL_INTEGER_SPACE]; - size_t slen; + size_t slen, len; resultVar = AnonymousLocal(envPtr); optionsVar = AnonymousLocal(envPtr); @@ -3335,7 +3335,7 @@ IssueTryClausesFinallyInstructions( OP( EQ); JUMP4( JUMP_FALSE, notCodeJumpSource); if (matchClauses[i]) { - TclListObjLength_(NULL, matchClauses[i], &len); + Tcl_ListObjLength(NULL, matchClauses[i], &len); /* * Match the errorcode according to try/trap rules. diff --git a/generic/tclCompExpr.c b/generic/tclCompExpr.c index 7be349b..6e36c28 100644 --- a/generic/tclCompExpr.c +++ b/generic/tclCompExpr.c @@ -2218,7 +2218,7 @@ TclCompileExpr( * Valid parse; compile the tree. */ - int objc; + size_t objc; Tcl_Obj *const *litObjv; Tcl_Obj **funcObjv; @@ -2226,8 +2226,8 @@ TclCompileExpr( TclAdvanceLines(&envPtr->line, script, script + TclParseAllWhiteSpace(script, numBytes)); - TclListObjGetElements_(NULL, litList, &objc, (Tcl_Obj ***)&litObjv); - TclListObjGetElements_(NULL, funcList, &objc, &funcObjv); + Tcl_ListObjGetElements(NULL, litList, &objc, (Tcl_Obj ***)&litObjv); + Tcl_ListObjGetElements(NULL, funcList, &objc, &funcObjv); CompileExprTree(interp, opTree, 0, &litObjv, funcObjv, parsePtr->tokenPtr, envPtr, optimize); } else { diff --git a/generic/tclDecls.h b/generic/tclDecls.h index 7e665ef..aefe43f 100644 --- a/generic/tclDecls.h +++ b/generic/tclDecls.h @@ -773,7 +773,7 @@ EXTERN void Tcl_DeleteThreadExitHandler(Tcl_ExitProc *proc, EXTERN int Tcl_EvalEx(Tcl_Interp *interp, const char *script, size_t numBytes, int flags); /* 292 */ -EXTERN int Tcl_EvalObjv(Tcl_Interp *interp, int objc, +EXTERN int Tcl_EvalObjv(Tcl_Interp *interp, size_t objc, Tcl_Obj *const objv[], int flags); /* 293 */ EXTERN int Tcl_EvalObjEx(Tcl_Interp *interp, Tcl_Obj *objPtr, @@ -2084,7 +2084,7 @@ typedef struct TclStubs { void (*tcl_DeleteThreadExitHandler) (Tcl_ExitProc *proc, void *clientData); /* 289 */ void (*reserved290)(void); int (*tcl_EvalEx) (Tcl_Interp *interp, const char *script, size_t numBytes, int flags); /* 291 */ - int (*tcl_EvalObjv) (Tcl_Interp *interp, int objc, Tcl_Obj *const objv[], int flags); /* 292 */ + int (*tcl_EvalObjv) (Tcl_Interp *interp, size_t objc, Tcl_Obj *const objv[], int flags); /* 292 */ int (*tcl_EvalObjEx) (Tcl_Interp *interp, Tcl_Obj *objPtr, int flags); /* 293 */ TCL_NORETURN1 void (*tcl_ExitThread) (int status); /* 294 */ int (*tcl_ExternalToUtf) (Tcl_Interp *interp, Tcl_Encoding encoding, const char *src, size_t srcLen, int flags, Tcl_EncodingState *statePtr, char *dst, size_t dstLen, int *srcReadPtr, int *dstWrotePtr, int *dstCharsPtr); /* 295 */ diff --git a/generic/tclDictObj.c b/generic/tclDictObj.c index 1e1d1eb..b3db861 100644 --- a/generic/tclDictObj.c +++ b/generic/tclDictObj.c @@ -3553,14 +3553,14 @@ Tcl_Obj * TclDictWithInit( Tcl_Interp *interp, Tcl_Obj *dictPtr, - int pathc, + size_t pathc, Tcl_Obj *const pathv[]) { Tcl_DictSearch s; Tcl_Obj *keyPtr, *valPtr, *keysPtr; int done; - if (pathc > 0) { + if (pathc + 1 > 1) { dictPtr = TclTraceDictPath(interp, dictPtr, pathc, pathv, DICT_PATH_READ); if (dictPtr == NULL) { diff --git a/generic/tclDisassemble.c b/generic/tclDisassemble.c index 5396ffe..b056381 100644 --- a/generic/tclDisassemble.c +++ b/generic/tclDisassemble.c @@ -688,7 +688,7 @@ TclGetInnerContext( const unsigned char *pc, Tcl_Obj **tosPtr) { - int objc = 0, off = 0; + size_t objc = 0; Tcl_Obj *result; Interp *iPtr = (Interp *) interp; @@ -757,13 +757,13 @@ TclGetInnerContext( iPtr->innerContext = result = Tcl_NewListObj(objc + 1, NULL); Tcl_IncrRefCount(result); } else { - int len; + size_t len; /* * Reset while keeping the list internalrep as much as possible. */ - TclListObjLength_(interp, result, &len); + Tcl_ListObjLength(interp, result, &len); Tcl_ListObjReplace(interp, result, 0, len, 0, NULL); } Tcl_ListObjAppendElement(NULL, result, TclNewInstNameObj(*pc)); @@ -771,7 +771,7 @@ TclGetInnerContext( for (; objc>0 ; objc--) { Tcl_Obj *objPtr; - objPtr = tosPtr[1 - objc + off]; + objPtr = tosPtr[1 - objc]; if (!objPtr) { Tcl_Panic("InnerContext: bad tos -- appending null object"); } diff --git a/generic/tclEncoding.c b/generic/tclEncoding.c index f1d5aba..bab6376 100644 --- a/generic/tclEncoding.c +++ b/generic/tclEncoding.c @@ -368,9 +368,9 @@ int Tcl_SetEncodingSearchPath( Tcl_Obj *searchPath) { - int dummy; + size_t dummy; - if (TCL_ERROR == TclListObjLength_(NULL, searchPath, &dummy)) { + if (TCL_ERROR == Tcl_ListObjLength(NULL, searchPath, &dummy)) { return TCL_ERROR; } TclSetProcessGlobalValue(&encodingSearchPath, searchPath, NULL); @@ -415,9 +415,9 @@ void TclSetLibraryPath( Tcl_Obj *path) { - int dummy; + size_t dummy; - if (TCL_ERROR == TclListObjLength_(NULL, path, &dummy)) { + if (TCL_ERROR == Tcl_ListObjLength(NULL, path, &dummy)) { return; } TclSetProcessGlobalValue(&libraryPath, path, NULL); @@ -451,22 +451,22 @@ TclSetLibraryPath( static void FillEncodingFileMap(void) { - int i, numDirs = 0; + size_t i, numDirs = 0; Tcl_Obj *map, *searchPath; searchPath = Tcl_GetEncodingSearchPath(); Tcl_IncrRefCount(searchPath); - TclListObjLength_(NULL, searchPath, &numDirs); + Tcl_ListObjLength(NULL, searchPath, &numDirs); map = Tcl_NewDictObj(); Tcl_IncrRefCount(map); - for (i = numDirs-1; i >= 0; i--) { + for (i = numDirs-1; i != TCL_INDEX_NONE; i--) { /* * Iterate backwards through the search path so as we overwrite * entries found, we favor files earlier on the search path. */ - int j, numFiles; + size_t j, numFiles; Tcl_Obj *directory, *matchFileList; Tcl_Obj **filev; Tcl_GlobTypeData readableFiles = { @@ -480,7 +480,7 @@ FillEncodingFileMap(void) Tcl_FSMatchInDirectory(NULL, matchFileList, directory, "*.enc", &readableFiles); - TclListObjGetElements_(NULL, matchFileList, &numFiles, &filev); + Tcl_ListObjGetElements(NULL, matchFileList, &numFiles, &filev); for (j=0; jfirstBgPtr != NULL) { - int code, prefixObjc; + int code; + size_t prefixObjc; Tcl_Obj **prefixObjv, **tempObjv; /* @@ -219,7 +220,7 @@ HandleBgErrors( errPtr = assocPtr->firstBgPtr; - TclListObjGetElements_(NULL, copyObj, &prefixObjc, &prefixObjv); + Tcl_ListObjGetElements(NULL, copyObj, &prefixObjc, &prefixObjv); tempObjv = (Tcl_Obj**)Tcl_Alloc((prefixObjc+2) * sizeof(Tcl_Obj *)); memcpy(tempObjv, prefixObjv, prefixObjc*sizeof(Tcl_Obj *)); tempObjv[prefixObjc] = errPtr->errorMsg; diff --git a/generic/tclExecute.c b/generic/tclExecute.c index e0ac6336..80044a4 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -2048,7 +2048,7 @@ TEBCresume( Tcl_Obj *objPtr, *valuePtr, *value2Ptr, *part1Ptr, *part2Ptr, *tmpPtr; Tcl_Obj **objv = NULL; - int objc = 0; + size_t objc = 0; int opnd, pcAdjustment; size_t length; Var *varPtr, *arrayPtr; @@ -2658,11 +2658,11 @@ TEBCresume( /* Ugly abuse! */ starting = 1; #endif - TRACE(("=> drop %d items\n", objc)); + TRACE(("=> drop %" TCL_Z_MODIFIER "d items\n", objc)); NEXT_INST_V(1, objc, 0); case INST_EXPAND_STKTOP: { - int i; + size_t i; ptrdiff_t moved; /* @@ -2673,7 +2673,7 @@ TEBCresume( objPtr = OBJ_AT_TOS; TRACE(("\"%.30s\" => ", O2S(objPtr))); - if (TclListObjGetElements_(interp, objPtr, &objc, &objv) != TCL_OK) { + if (Tcl_ListObjGetElements(interp, objPtr, &objc, &objv) != TCL_OK) { TRACE_ERROR(interp); goto gotError; } @@ -2786,11 +2786,11 @@ TEBCresume( #ifdef TCL_COMPILE_DEBUG if (tclTraceExec >= 2) { - int i; + size_t i; if (traceInstructions) { strncpy(cmdNameBuf, TclGetString(objv[0]), 20); - TRACE(("%u => call ", objc)); + TRACE(("%" TCL_Z_MODIFIER "u => call ", objc)); } else { fprintf(stdout, "%d: (%u) invoking ", iPtr->numLevels, (unsigned)(pc - codePtr->codeStart)); @@ -2833,11 +2833,11 @@ TEBCresume( cleanup = objc; #ifdef TCL_COMPILE_DEBUG if (tclTraceExec >= 2) { - int i; + size_t i; if (traceInstructions) { strncpy(cmdNameBuf, TclGetString(objv[0]), 20); - TRACE(("%u => call (implementation %s) ", objc, O2S(objPtr))); + TRACE(("%" TCL_Z_MODIFIER "u => call (implementation %s) ", objc, O2S(objPtr))); } else { fprintf(stdout, "%d: (%u) invoking (using implementation %s) ", @@ -2883,7 +2883,7 @@ TEBCresume( TclMarkTailcall(interp); TclNRAddCallback(interp, TclClearRootEnsemble, NULL, NULL, NULL, NULL); - TclListObjGetElements_(NULL, objPtr, &objc, &objv); + Tcl_ListObjGetElements(NULL, objPtr, &objc, &objv); TclNRAddCallback(interp, TclNRReleaseValues, objPtr, NULL, NULL, NULL); return TclNREvalObjv(interp, objc, objv, TCL_EVAL_INVOKE, NULL); @@ -3043,7 +3043,8 @@ TEBCresume( */ { - int storeFlags, len; + int storeFlags; + size_t len; case INST_STORE_ARRAY4: opnd = TclGetUInt4AtPtr(pc+1); @@ -3294,7 +3295,7 @@ TEBCresume( varPtr = varPtr->value.linkPtr; } TRACE(("%u <- \"%.30s\" => ", opnd, O2S(valuePtr))); - if (TclListObjGetElements_(interp, valuePtr, &objc, &objv) + if (Tcl_ListObjGetElements(interp, valuePtr, &objc, &objv) != TCL_OK) { TRACE_ERROR(interp); goto gotError; @@ -3320,7 +3321,7 @@ TEBCresume( } TRACE(("%u \"%.30s\" \"%.30s\" => ", opnd, O2S(part2Ptr), O2S(valuePtr))); - if (TclListObjGetElements_(interp, valuePtr, &objc, &objv) + if (Tcl_ListObjGetElements(interp, valuePtr, &objc, &objv) != TCL_OK) { TRACE_ERROR(interp); goto gotError; @@ -3362,7 +3363,7 @@ TEBCresume( lappendListDirect: objResultPtr = varPtr->value.objPtr; - if (TclListObjLength_(interp, objResultPtr, &len) != TCL_OK) { + if (Tcl_ListObjLength(interp, objResultPtr, &len) != TCL_OK) { TRACE_ERROR(interp); goto gotError; } @@ -3383,7 +3384,7 @@ TEBCresume( lappendList: opnd = -1; - if (TclListObjGetElements_(interp, valuePtr, &objc, &objv) + if (Tcl_ListObjGetElements(interp, valuePtr, &objc, &objv) != TCL_OK) { TRACE_ERROR(interp); goto gotError; @@ -3421,7 +3422,7 @@ TEBCresume( if (!objResultPtr) { valueToAssign = valuePtr; - } else if (TclListObjLength_(interp, objResultPtr, &len)!=TCL_OK) { + } else if (Tcl_ListObjLength(interp, objResultPtr, &len)!=TCL_OK) { TRACE_ERROR(interp); goto gotError; } else { @@ -4654,7 +4655,7 @@ TEBCresume( * Extract the desired list element. */ - if ((TclListObjGetElements_(interp, valuePtr, &objc, &objv) == TCL_OK) + if ((Tcl_ListObjGetElements(interp, valuePtr, &objc, &objv) == TCL_OK) && !TclHasInternalRep(value2Ptr, &tclListType)) { int code; @@ -4699,7 +4700,7 @@ TEBCresume( * in the process. */ - if (TclListObjGetElements_(interp, valuePtr, &objc, &objv) != TCL_OK) { + if (Tcl_ListObjGetElements(interp, valuePtr, &objc, &objv) != TCL_OK) { TRACE_ERROR(interp); goto gotError; } @@ -4838,7 +4839,7 @@ TEBCresume( * in the process. */ - if (TclListObjLength_(interp, valuePtr, &objc) != TCL_OK) { + if (Tcl_ListObjLength(interp, valuePtr, &objc) != TCL_OK) { TRACE_ERROR(interp); goto gotError; } @@ -6218,10 +6219,9 @@ TEBCresume( ForeachInfo *infoPtr; Tcl_Obj *listPtr, **elements; ForeachVarList *varListPtr; - int numLists, listLen, numVars; - int listTmpDepth; - size_t iterNum, iterMax, iterTmp; - int varIndex, valIndex, j; + int numLists, numVars, listTmpDepth; + size_t iterNum, iterMax, iterTmp, listLen, valIndex; + int varIndex, j; long i; case INST_FOREACH_START: @@ -6245,7 +6245,7 @@ TEBCresume( varListPtr = infoPtr->varLists[i]; numVars = varListPtr->numVars; listPtr = OBJ_AT_DEPTH(listTmpDepth); - if (TclListObjLength_(interp, listPtr, &listLen) != TCL_OK) { + if (Tcl_ListObjLength(interp, listPtr, &listLen) != TCL_OK) { TRACE_APPEND(("ERROR converting list %ld, \"%s\": %s", i, O2S(listPtr), O2S(Tcl_GetObjResult(interp)))); goto gotError; @@ -6326,7 +6326,7 @@ TEBCresume( numVars = varListPtr->numVars; listPtr = OBJ_AT_DEPTH(listTmpDepth); - TclListObjGetElements_(interp, listPtr, &listLen, &elements); + Tcl_ListObjGetElements(interp, listPtr, &listLen, &elements); valIndex = (iterNum * numVars); for (j = 0; j < numVars; j++) { @@ -7060,7 +7060,7 @@ TEBCresume( dictPtr = OBJ_UNDER_TOS; listPtr = OBJ_AT_TOS; TRACE(("\"%.30s\" \"%.30s\" =>", O2S(dictPtr), O2S(listPtr))); - if (TclListObjGetElements_(interp, listPtr, &objc, &objv) != TCL_OK) { + if (Tcl_ListObjGetElements(interp, listPtr, &objc, &objv) != TCL_OK) { TRACE_ERROR(interp); goto gotError; } @@ -7078,7 +7078,7 @@ TEBCresume( listPtr = OBJ_AT_TOS; TRACE(("\"%.30s\" \"%.30s\" \"%.30s\" => ", O2S(varNamePtr), O2S(valuePtr), O2S(keysPtr))); - if (TclListObjGetElements_(interp, listPtr, &objc, &objv) != TCL_OK) { + if (Tcl_ListObjGetElements(interp, listPtr, &objc, &objv) != TCL_OK) { TRACE_ERROR(interp); TclDecrRefCount(keysPtr); goto gotError; @@ -7109,7 +7109,7 @@ TEBCresume( varPtr = LOCAL(opnd); TRACE(("%u <- \"%.30s\" \"%.30s\" => ", opnd, O2S(valuePtr), O2S(keysPtr))); - if (TclListObjGetElements_(interp, listPtr, &objc, &objv) != TCL_OK) { + if (Tcl_ListObjGetElements(interp, listPtr, &objc, &objv) != TCL_OK) { TRACE_ERROR(interp); goto gotError; } diff --git a/generic/tclIndexObj.c b/generic/tclIndexObj.c index 1655fa5..8a630d7 100644 --- a/generic/tclIndexObj.c +++ b/generic/tclIndexObj.c @@ -112,7 +112,8 @@ GetIndexFromObjList( int *indexPtr) /* Place to store resulting integer index. */ { - int objc, result, t; + size_t objc, t; + int result; Tcl_Obj **objv; const char **tablePtr; @@ -121,7 +122,7 @@ GetIndexFromObjList( * of the code there. This is a bit ineffiecient but simpler. */ - result = TclListObjGetElements_(interp, tableObjPtr, &objc, &objv); + result = Tcl_ListObjGetElements(interp, tableObjPtr, &objc, &objv); if (result != TCL_OK) { return result; } @@ -602,8 +603,8 @@ PrefixAllObjCmd( int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - int tableObjc, result, t; - size_t length, elemLength; + int result; + size_t length, elemLength, tableObjc, t; const char *string, *elemString; Tcl_Obj **tableObjv, *resultPtr; @@ -612,7 +613,7 @@ PrefixAllObjCmd( return TCL_ERROR; } - result = TclListObjGetElements_(interp, objv[1], &tableObjc, &tableObjv); + result = Tcl_ListObjGetElements(interp, objv[1], &tableObjc, &tableObjv); if (result != TCL_OK) { return result; } @@ -660,8 +661,8 @@ PrefixLongestObjCmd( int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - int tableObjc, result, t; - size_t i, length, elemLength, resultLength; + int result; + size_t i, length, elemLength, resultLength, tableObjc, t; const char *string, *elemString, *resultString; Tcl_Obj **tableObjv; @@ -670,7 +671,7 @@ PrefixLongestObjCmd( return TCL_ERROR; } - result = TclListObjGetElements_(interp, objv[1], &tableObjc, &tableObjv); + result = Tcl_ListObjGetElements(interp, objv[1], &tableObjc, &tableObjv); if (result != TCL_OK) { return result; } diff --git a/generic/tclInt.decls b/generic/tclInt.decls index 8af12cf..aa2bd2f 100644 --- a/generic/tclInt.decls +++ b/generic/tclInt.decls @@ -508,7 +508,7 @@ declare 241 { const CmdFrame *invoker, int word) } declare 242 { - int TclNREvalObjv(Tcl_Interp *interp, int objc, + int TclNREvalObjv(Tcl_Interp *interp, size_t objc, Tcl_Obj *const objv[], int flags, Command *cmdPtr) } diff --git a/generic/tclInt.h b/generic/tclInt.h index f4d1b25..c598a81 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -3322,7 +3322,7 @@ MODULE_SCOPE int TclDictWithFinish(Tcl_Interp *interp, Var *varPtr, Tcl_Obj *part2Ptr, int index, int pathc, Tcl_Obj *const pathv[], Tcl_Obj *keysPtr); MODULE_SCOPE Tcl_Obj * TclDictWithInit(Tcl_Interp *interp, Tcl_Obj *dictPtr, - int pathc, Tcl_Obj *const pathv[]); + size_t pathc, Tcl_Obj *const pathv[]); MODULE_SCOPE int Tcl_DisassembleObjCmd(void *clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); diff --git a/generic/tclIntDecls.h b/generic/tclIntDecls.h index 80d9f64..9022412 100644 --- a/generic/tclIntDecls.h +++ b/generic/tclIntDecls.h @@ -519,7 +519,7 @@ EXTERN int TclNRRunCallbacks(Tcl_Interp *interp, int result, EXTERN int TclNREvalObjEx(Tcl_Interp *interp, Tcl_Obj *objPtr, int flags, const CmdFrame *invoker, int word); /* 242 */ -EXTERN int TclNREvalObjv(Tcl_Interp *interp, int objc, +EXTERN int TclNREvalObjv(Tcl_Interp *interp, size_t objc, Tcl_Obj *const objv[], int flags, Command *cmdPtr); /* 243 */ @@ -825,7 +825,7 @@ typedef struct TclIntStubs { int (*tclNRInterpProcCore) (Tcl_Interp *interp, Tcl_Obj *procNameObj, size_t skip, ProcErrorProc *errorProc); /* 239 */ int (*tclNRRunCallbacks) (Tcl_Interp *interp, int result, struct NRE_callback *rootPtr); /* 240 */ int (*tclNREvalObjEx) (Tcl_Interp *interp, Tcl_Obj *objPtr, int flags, const CmdFrame *invoker, int word); /* 241 */ - int (*tclNREvalObjv) (Tcl_Interp *interp, int objc, Tcl_Obj *const objv[], int flags, Command *cmdPtr); /* 242 */ + int (*tclNREvalObjv) (Tcl_Interp *interp, size_t objc, Tcl_Obj *const objv[], int flags, Command *cmdPtr); /* 242 */ void (*tclDbDumpActiveObjects) (FILE *outFile); /* 243 */ Tcl_HashTable * (*tclGetNamespaceChildTable) (Tcl_Namespace *nsPtr); /* 244 */ Tcl_HashTable * (*tclGetNamespaceCommandTable) (Tcl_Namespace *nsPtr); /* 245 */ diff --git a/generic/tclInterp.c b/generic/tclInterp.c index 0b2e7f7..8458915 100644 --- a/generic/tclInterp.c +++ b/generic/tclInterp.c @@ -2320,11 +2320,11 @@ GetInterp( Tcl_HashEntry *hPtr; /* Search element. */ Child *childPtr; /* Interim child record. */ Tcl_Obj **objv; - int objc, i; + size_t objc, i; Tcl_Interp *searchInterp; /* Interim storage for interp. to find. */ InterpInfo *parentInfoPtr; - if (TclListObjGetElements_(interp, pathPtr, &objc, &objv) != TCL_OK) { + if (Tcl_ListObjGetElements(interp, pathPtr, &objc, &objv) != TCL_OK) { return NULL; } @@ -2424,10 +2424,11 @@ ChildCreate( InterpInfo *parentInfoPtr; Tcl_HashEntry *hPtr; const char *path; - int isNew, objc; + int isNew; + size_t objc; Tcl_Obj **objv; - if (TclListObjGetElements_(interp, pathPtr, &objc, &objv) != TCL_OK) { + if (Tcl_ListObjGetElements(interp, pathPtr, &objc, &objv) != TCL_OK) { return NULL; } if (objc < 2) { diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c index e080d44..94402d8 100644 --- a/generic/tclStubInit.c +++ b/generic/tclStubInit.c @@ -147,7 +147,7 @@ static int SplitList(Tcl_Interp *interp, const char *listStr, int *argcPtr, if (interp) { Tcl_AppendResult(interp, "List too large to be processed", NULL); } - Tcl_Free(*argvPtr); + Tcl_Free((void *)*argvPtr); return TCL_ERROR; } *argcPtr = n; @@ -160,7 +160,7 @@ static void SplitPath(const char *path, int *argcPtr, const char ***argvPtr) { if (argcPtr) { if (n > INT_MAX) { n = TCL_INDEX_NONE; /* No other way to return an error-situation */ - Tcl_Free(*argvPtr); + Tcl_Free((void *)*argvPtr); *argvPtr = NULL; } *argcPtr = n; -- cgit v0.12 From 75cb3e25d6840c30ddc08ac50b61e772d236f857 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 27 Jan 2022 16:53:35 +0000 Subject: Almost complete (at least the API) --- generic/tclCmdAH.c | 19 +++++------ generic/tclCmdIL.c | 80 +++++++++++++++++++++++------------------------ generic/tclEnsemble.c | 66 ++++++++++++++++++++------------------ generic/tclFileName.c | 35 +++++++++++---------- generic/tclIORChan.c | 27 ++++++++-------- generic/tclIORTrans.c | 15 +++++---- generic/tclInt.h | 2 +- generic/tclListObj.c | 6 ++-- generic/tclOO.decls | 2 +- generic/tclOODefineCmds.c | 50 +++++++++++++++-------------- generic/tclOOIntDecls.h | 4 +-- generic/tclStubInit.c | 4 +-- 12 files changed, 159 insertions(+), 151 deletions(-) diff --git a/generic/tclCmdAH.c b/generic/tclCmdAH.c index 5f4729c..e124d66 100644 --- a/generic/tclCmdAH.c +++ b/generic/tclCmdAH.c @@ -27,11 +27,11 @@ struct ForeachState { int bodyIdx; /* The argument index of the body. */ int j, maxj; /* Number of loop iterations. */ int numLists; /* Count of value lists. */ - int *index; /* Array of value list indices. */ - int *varcList; /* # loop variables per list. */ + size_t *index; /* Array of value list indices. */ + size_t *varcList; /* # loop variables per list. */ Tcl_Obj ***varvList; /* Array of var name lists. */ Tcl_Obj **vCopyList; /* Copies of var name list arguments. */ - int *argcList; /* Array of value list sizes. */ + size_t *argcList; /* Array of value list sizes. */ Tcl_Obj ***argvList; /* Array of value lists. */ Tcl_Obj **aCopyList; /* Copies of value list arguments. */ Tcl_Obj *resultList; /* List of result values from the loop body, @@ -2500,16 +2500,16 @@ EachloopCmd( */ statePtr = (struct ForeachState *)TclStackAlloc(interp, - sizeof(struct ForeachState) + 3 * numLists * sizeof(int) + sizeof(struct ForeachState) + 3 * numLists * sizeof(size_t) + 2 * numLists * (sizeof(Tcl_Obj **) + sizeof(Tcl_Obj *))); memset(statePtr, 0, - sizeof(struct ForeachState) + 3 * numLists * sizeof(int) + sizeof(struct ForeachState) + 3 * numLists * sizeof(size_t) + 2 * numLists * (sizeof(Tcl_Obj **) + sizeof(Tcl_Obj *))); statePtr->varvList = (Tcl_Obj ***) (statePtr + 1); statePtr->argvList = statePtr->varvList + numLists; statePtr->vCopyList = (Tcl_Obj **) (statePtr->argvList + numLists); statePtr->aCopyList = statePtr->vCopyList + numLists; - statePtr->index = (int *) (statePtr->aCopyList + numLists); + statePtr->index = (size_t *) (statePtr->aCopyList + numLists); statePtr->varcList = statePtr->index + numLists; statePtr->argcList = statePtr->varcList + numLists; @@ -2533,7 +2533,7 @@ EachloopCmd( result = TCL_ERROR; goto done; } - TclListObjGetElements_(NULL, statePtr->vCopyList[i], + Tcl_ListObjGetElements(NULL, statePtr->vCopyList[i], &statePtr->varcList[i], &statePtr->varvList[i]); if (statePtr->varcList[i] < 1) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( @@ -2551,7 +2551,7 @@ EachloopCmd( result = TCL_ERROR; goto done; } - TclListObjGetElements_(NULL, statePtr->aCopyList[i], + Tcl_ListObjGetElements(NULL, statePtr->aCopyList[i], &statePtr->argcList[i], &statePtr->argvList[i]); j = statePtr->argcList[i] / statePtr->varcList[i]; @@ -2671,7 +2671,8 @@ ForeachAssignments( Tcl_Interp *interp, struct ForeachState *statePtr) { - int i, v, k; + int i; + size_t v, k; Tcl_Obj *valuePtr, *varValuePtr; for (i=0 ; inumLists ; i++) { diff --git a/generic/tclCmdIL.c b/generic/tclCmdIL.c index e430d99..d43c0f3 100644 --- a/generic/tclCmdIL.c +++ b/generic/tclCmdIL.c @@ -70,7 +70,7 @@ typedef struct { * NULL if no indexes supplied, and points to * singleIndex field when only one * supplied. */ - int indexc; /* Number of indexes in indexv array. */ + size_t indexc; /* Number of indexes in indexv array. */ int singleIndex; /* Static space for common index case. */ int unique; int numElements; @@ -2180,8 +2180,7 @@ Tcl_JoinObjCmd( int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* The argument objects. */ { - size_t length; - int listLen; + size_t length, listLen; Tcl_Obj *resObjPtr = NULL, *joinObjPtr, **elemPtrs; if ((objc < 2) || (objc > 3)) { @@ -2194,7 +2193,7 @@ Tcl_JoinObjCmd( * pointer to its array of element pointers. */ - if (TclListObjGetElements_(interp, objv[1], &listLen, + if (Tcl_ListObjGetElements(interp, objv[1], &listLen, &elemPtrs) != TCL_OK) { return TCL_ERROR; } @@ -2216,7 +2215,7 @@ Tcl_JoinObjCmd( if (length == 0) { resObjPtr = TclStringCat(interp, listLen, elemPtrs, 0); } else { - int i; + size_t i; resObjPtr = Tcl_NewObj(); for (i = 0; i < listLen; i++) { @@ -2268,7 +2267,7 @@ Tcl_LassignObjCmd( { Tcl_Obj *listCopyPtr; Tcl_Obj **listObjv; /* The contents of the list. */ - int listObjc; /* The length of the list. */ + size_t listObjc; /* The length of the list. */ int code = TCL_OK; if (objc < 2) { @@ -2281,7 +2280,7 @@ Tcl_LassignObjCmd( return TCL_ERROR; } - TclListObjGetElements_(NULL, listCopyPtr, &listObjc, &listObjv); + Tcl_ListObjGetElements(NULL, listCopyPtr, &listObjc, &listObjv); objc -= 2; objv += 2; @@ -2565,7 +2564,8 @@ Tcl_LpopObjCmd( Tcl_Obj *const objv[]) /* Argument objects. */ { - int listLen, result; + size_t listLen; + int result; Tcl_Obj *elemPtr, *stored; Tcl_Obj *listPtr, **elemPtrs; @@ -2579,7 +2579,7 @@ Tcl_LpopObjCmd( return TCL_ERROR; } - result = TclListObjGetElements_(interp, listPtr, &listLen, &elemPtrs); + result = Tcl_ListObjGetElements(interp, listPtr, &listLen, &elemPtrs); if (result != TCL_OK) { return result; } @@ -3064,13 +3064,13 @@ Tcl_LreverseObjCmd( Tcl_Obj *const objv[]) /* Argument values. */ { Tcl_Obj **elemv; - int elemc, i, j; + size_t elemc, i, j; if (objc != 2) { Tcl_WrongNumArgs(interp, 1, objv, "list"); return TCL_ERROR; } - if (TclListObjGetElements_(interp, objv[1], &elemc, &elemv) != TCL_OK) { + if (Tcl_ListObjGetElements(interp, objv[1], &elemc, &elemv) != TCL_OK) { return TCL_ERROR; } @@ -3143,8 +3143,8 @@ Tcl_LsearchObjCmd( Tcl_Obj *const objv[]) /* Argument values. */ { const char *bytes, *patternBytes; - int i, match, index, result=TCL_OK, listc, bisect; - size_t length = 0, elemLen, start, groupSize, groupOffset, lower, upper; + int match, index, result=TCL_OK, bisect; + size_t i, length = 0, listc, elemLen, start, groupSize, groupOffset, lower, upper; int allocatedIndexVector = 0; int dataType, isIncreasing; Tcl_WideInt patWide, objWide, wide; @@ -3203,7 +3203,7 @@ Tcl_LsearchObjCmd( return TCL_ERROR; } - for (i = 1; i < objc-2; i++) { + for (i = 1; i < (size_t)objc-2; i++) { if (Tcl_GetIndexFromObj(interp, objv[i], options, "option", 0, &index) != TCL_OK) { result = TCL_ERROR; @@ -3272,7 +3272,7 @@ Tcl_LsearchObjCmd( Tcl_DecrRefCount(startPtr); startPtr = NULL; } - if (i > objc-4) { + if (i + 4 > (size_t)objc) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "missing starting index", -1)); Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "MISSING", NULL); @@ -3295,7 +3295,7 @@ Tcl_LsearchObjCmd( Tcl_IncrRefCount(startPtr); break; case LSEARCH_STRIDE: /* -stride */ - if (i > objc-4) { + if (i + 4 > (size_t)objc) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "\"-stride\" option must be " "followed by stride length", -1)); @@ -3320,13 +3320,13 @@ Tcl_LsearchObjCmd( break; case LSEARCH_INDEX: { /* -index */ Tcl_Obj **indices; - int j; + size_t j; if (allocatedIndexVector) { TclStackFree(interp, sortInfo.indexv); allocatedIndexVector = 0; } - if (i > objc-4) { + if (i + 4 > (size_t)objc) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "\"-index\" option must be followed by list index", -1)); @@ -3342,7 +3342,7 @@ Tcl_LsearchObjCmd( */ i++; - if (TclListObjGetElements_(interp, objv[i], + if (Tcl_ListObjGetElements(interp, objv[i], &sortInfo.indexc, &indices) != TCL_OK) { result = TCL_ERROR; goto done; @@ -3383,7 +3383,7 @@ Tcl_LsearchObjCmd( } if (result == TCL_ERROR) { Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( - "\n (-index option item number %d)", j)); + "\n (-index option item number %" TCL_Z_MODIFIER "d)", j)); goto done; } sortInfo.indexv[j] = encoded; @@ -3448,7 +3448,7 @@ Tcl_LsearchObjCmd( * pointer to its array of element pointers. */ - result = TclListObjGetElements_(interp, objv[objc - 2], &listc, &listv); + result = Tcl_ListObjGetElements(interp, objv[objc - 2], &listc, &listv); if (result != TCL_OK) { goto done; } @@ -3553,7 +3553,7 @@ Tcl_LsearchObjCmd( * 1844789] */ - TclListObjGetElements_(NULL, objv[objc - 2], &listc, &listv); + Tcl_ListObjGetElements(NULL, objv[objc - 2], &listc, &listv); break; case REAL: result = Tcl_GetDoubleFromObj(interp, patObj, &patDouble); @@ -3566,7 +3566,7 @@ Tcl_LsearchObjCmd( * 1844789] */ - TclListObjGetElements_(NULL, objv[objc - 2], &listc, &listv); + Tcl_ListObjGetElements(NULL, objv[objc - 2], &listc, &listv); break; } } else { @@ -3694,7 +3694,7 @@ Tcl_LsearchObjCmd( if (allMatches) { listPtr = Tcl_NewListObj(0, NULL); } - for (i = start; i < listc; i += groupSize) { + for (i = start; i < (size_t)listc; i += groupSize) { match = 0; if (sortInfo.indexc != 0) { itemPtr = SelectObjFromSublist(listv[i+groupOffset], &sortInfo); @@ -3806,7 +3806,7 @@ Tcl_LsearchObjCmd( Tcl_ListObjAppendElement(interp, listPtr, itemPtr); } } else if (returnSubindices) { - int j; + size_t j; TclNewIndexObj(itemPtr, i+groupOffset); for (j=0 ; j 0 ? objv[1] : NULL); continue; case CRT_PARAM: - if (TclListObjLength_(interp, objv[1], &len) != TCL_OK) { + if (Tcl_ListObjLength(interp, objv[1], &len) != TCL_OK) { if (allocatedMapFlag) { Tcl_DecrRefCount(mapObj); } @@ -271,7 +272,7 @@ TclNamespaceEnsembleCmd( Tcl_Obj **listv; const char *cmd; - if (TclListObjGetElements_(interp, listObj, &len, + if (Tcl_ListObjGetElements(interp, listObj, &len, &listv) != TCL_OK) { Tcl_DictObjDone(&search); if (patchedDict) { @@ -336,7 +337,7 @@ TclNamespaceEnsembleCmd( } continue; case CRT_UNKNOWN: - if (TclListObjLength_(interp, objv[1], &len) != TCL_OK) { + if (Tcl_ListObjLength(interp, objv[1], &len) != TCL_OK) { if (allocatedMapFlag) { Tcl_DecrRefCount(mapObj); } @@ -498,7 +499,8 @@ TclNamespaceEnsembleCmd( Tcl_SetObjResult(interp, resultObj); } else { - int len, allocatedMapFlag = 0; + size_t len; + int allocatedMapFlag = 0; Tcl_Obj *subcmdObj = NULL, *mapObj = NULL, *paramObj = NULL, *unknownObj = NULL; /* Defaults, silence gcc 4 warnings */ int permitPrefix, flags = 0; /* silence gcc 4 warning */ @@ -531,13 +533,13 @@ TclNamespaceEnsembleCmd( } switch ((enum EnsConfigOpts) index) { case CONF_SUBCMDS: - if (TclListObjLength_(interp, objv[1], &len) != TCL_OK) { + if (Tcl_ListObjLength(interp, objv[1], &len) != TCL_OK) { goto freeMapAndError; } subcmdObj = (len > 0 ? objv[1] : NULL); continue; case CONF_PARAM: - if (TclListObjLength_(interp, objv[1], &len) != TCL_OK) { + if (Tcl_ListObjLength(interp, objv[1], &len) != TCL_OK) { goto freeMapAndError; } paramObj = (len > 0 ? objv[1] : NULL); @@ -559,7 +561,7 @@ TclNamespaceEnsembleCmd( continue; } do { - if (TclListObjGetElements_(interp, listObj, &len, + if (Tcl_ListObjGetElements(interp, listObj, &len, &listv) != TCL_OK) { Tcl_DictObjDone(&search); if (patchedDict) { @@ -621,7 +623,7 @@ TclNamespaceEnsembleCmd( } continue; case CONF_UNKNOWN: - if (TclListObjLength_(interp, objv[1], &len) != TCL_OK) { + if (Tcl_ListObjLength(interp, objv[1], &len) != TCL_OK) { goto freeMapAndError; } unknownObj = (len > 0 ? objv[1] : NULL); @@ -788,9 +790,9 @@ Tcl_SetEnsembleSubcommandList( return TCL_ERROR; } if (subcmdList != NULL) { - int length; + size_t length; - if (TclListObjLength_(interp, subcmdList, &length) != TCL_OK) { + if (Tcl_ListObjLength(interp, subcmdList, &length) != TCL_OK) { return TCL_ERROR; } if (length < 1) { @@ -855,7 +857,7 @@ Tcl_SetEnsembleParameterList( Command *cmdPtr = (Command *) token; EnsembleConfig *ensemblePtr; Tcl_Obj *oldList; - int length; + size_t length; if (cmdPtr->objProc != TclEnsembleImplementationCmd) { Tcl_SetObjResult(interp, Tcl_NewStringObj( @@ -866,7 +868,7 @@ Tcl_SetEnsembleParameterList( if (paramList == NULL) { length = 0; } else { - if (TclListObjLength_(interp, paramList, &length) != TCL_OK) { + if (Tcl_ListObjLength(interp, paramList, &length) != TCL_OK) { return TCL_ERROR; } if (length < 1) { @@ -1040,9 +1042,9 @@ Tcl_SetEnsembleUnknownHandler( return TCL_ERROR; } if (unknownList != NULL) { - int length; + size_t length; - if (TclListObjLength_(interp, unknownList, &length) != TCL_OK) { + if (Tcl_ListObjLength(interp, unknownList, &length) != TCL_OK) { return TCL_ERROR; } if (length < 1) { @@ -1884,9 +1886,9 @@ NsEnsembleImplementationCmdNR( Tcl_Obj *copyPtr; /* The list of words to dispatch on. * Will be freed by the dispatch engine. */ Tcl_Obj **copyObjv; - int copyObjc, prefixObjc; + size_t copyObjc, prefixObjc; - TclListObjLength_(NULL, prefixObj, &prefixObjc); + Tcl_ListObjLength(NULL, prefixObj, &prefixObjc); if (objc == 2) { copyPtr = TclListObjCopy(NULL, prefixObj); @@ -1920,7 +1922,7 @@ NsEnsembleImplementationCmdNR( */ TclSkipTailcall(interp); - TclListObjGetElements_(NULL, copyPtr, ©Objc, ©Objv); + Tcl_ListObjGetElements(NULL, copyPtr, ©Objc, ©Objv); ((Interp *)interp)->lookupNsPtr = ensemblePtr->nsPtr; return TclNREvalObjv(interp, copyObjc, copyObjv, TCL_EVAL_INVOKE, NULL); } @@ -2280,7 +2282,9 @@ EnsembleUnknownCallback( Tcl_Obj *const objv[], Tcl_Obj **prefixObjPtr) { - int paramc, i, result, prefixObjc; + size_t paramc; + int result; + size_t i, prefixObjc; Tcl_Obj **paramv, *unknownCmd, *ensObj; /* @@ -2291,10 +2295,10 @@ EnsembleUnknownCallback( TclNewObj(ensObj); Tcl_GetCommandFullName(interp, ensemblePtr->token, ensObj); Tcl_ListObjAppendElement(NULL, unknownCmd, ensObj); - for (i=1 ; imacType = NULL; globTypes->macCreator = NULL; - while (--length >= 0) { + while (length-- > 0) { size_t len; const char *str; @@ -1524,9 +1525,9 @@ Tcl_GlobObjCmd( } else { Tcl_Obj *item; - int llen; + size_t llen; - if ((TclListObjLength_(NULL, look, &llen) == TCL_OK) + if ((Tcl_ListObjLength(NULL, look, &llen) == TCL_OK) && (llen == 3)) { Tcl_ListObjIndex(interp, look, 0, &item); if (!strcmp("macintosh", TclGetString(item))) { @@ -1633,7 +1634,7 @@ Tcl_GlobObjCmd( } if ((globFlags & TCL_GLOBMODE_NO_COMPLAIN) == 0) { - if (TclListObjLength_(interp, Tcl_GetObjResult(interp), + if (Tcl_ListObjLength(interp, Tcl_GetObjResult(interp), &length) != TCL_OK) { /* * This should never happen. Maybe we should be more dramatic. @@ -1988,7 +1989,7 @@ TclGlob( */ if (globFlags & TCL_GLOBMODE_TAILS) { - int objc, i; + size_t objc, i; Tcl_Obj **objv; size_t prefixLen; const char *pre; @@ -2016,7 +2017,7 @@ TclGlob( } } - TclListObjGetElements_(NULL, filenamesObj, &objc, &objv); + Tcl_ListObjGetElements(NULL, filenamesObj, &objc, &objv); for (i = 0; i< objc; i++) { size_t len; const char *oldStr = Tcl_GetStringFromObj(objv[i], &len); @@ -2342,16 +2343,16 @@ DoGlob( pattern, &dirOnly); *p = save; if (result == TCL_OK) { - int subdirc, i, repair = -1; + size_t i, subdirc, repair = TCL_INDEX_NONE; Tcl_Obj **subdirv; - result = TclListObjGetElements_(interp, subdirsPtr, + result = Tcl_ListObjGetElements(interp, subdirsPtr, &subdirc, &subdirv); for (i=0; result==TCL_OK && i (size_t)elemCount - || (valuePtr == NULL && index >= (size_t)elemCount)) { + if (index > elemCount + || (valuePtr == NULL && index >= elemCount)) { /* ...the index points outside the sublist. */ if (interp != NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( diff --git a/generic/tclOO.decls b/generic/tclOO.decls index ddccef7..980aeb0 100644 --- a/generic/tclOO.decls +++ b/generic/tclOO.decls @@ -209,7 +209,7 @@ declare 12 { } declare 13 { void TclOOClassSetFilters(Tcl_Interp *interp, Class *classPtr, - int numFilters, Tcl_Obj *const *filters) + size_t numFilters, Tcl_Obj *const *filters) } declare 14 { void TclOOObjectSetMixins(Object *oPtr, int numMixins, diff --git a/generic/tclOODefineCmds.c b/generic/tclOODefineCmds.c index 4b4f7f2..2a04d37 100644 --- a/generic/tclOODefineCmds.c +++ b/generic/tclOODefineCmds.c @@ -309,7 +309,7 @@ void TclOOClassSetFilters( Tcl_Interp *interp, Class *classPtr, - int numFilters, + size_t numFilters, Tcl_Obj *const *filters) { int i; @@ -343,7 +343,7 @@ TclOOClassSetFilters( } else { filtersList = (Tcl_Obj **)Tcl_Realloc(classPtr->filters.list, size); } - for (i = 0 ; i < numFilters ; i++) { + for (i = 0 ; i < (int)numFilters ; i++) { filtersList[i] = filters[i]; Tcl_IncrRefCount(filters[i]); } @@ -1032,7 +1032,8 @@ MagicDefinitionInvoke( { Tcl_Obj *objPtr, *obj2Ptr, **objs; Tcl_Command cmd; - int isRoot, dummy, result, offset = cmdIndex + 1; + int isRoot, result, offset = cmdIndex + 1; + size_t dummy; /* * More than one argument: fire them through the ensemble processing @@ -1065,7 +1066,7 @@ MagicDefinitionInvoke( Tcl_ListObjAppendElement(NULL, objPtr, obj2Ptr); /* TODO: overflow? */ Tcl_ListObjReplace(NULL, objPtr, 1, 0, objc - offset, objv + offset); - TclListObjGetElements_(NULL, objPtr, &dummy, &objs); + Tcl_ListObjGetElements(NULL, objPtr, &dummy, &objs); result = Tcl_EvalObjv(interp, objc - cmdIndex, objs, TCL_EVAL_INVOKE); if (isRoot) { @@ -2355,7 +2356,7 @@ ClassFilterSet( Tcl_Obj *const *objv) { Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp); - int filterc; + size_t filterc; Tcl_Obj **filterv; if ((int)Tcl_ObjectContextSkippedArgs(context) + 1 != objc) { @@ -2372,7 +2373,7 @@ ClassFilterSet( "attempt to misuse API", -1)); Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL); return TCL_ERROR; - } else if (TclListObjGetElements_(interp, objv[0], &filterc, + } else if (Tcl_ListObjGetElements(interp, objv[0], &filterc, &filterv) != TCL_OK) { return TCL_ERROR; } @@ -2438,7 +2439,7 @@ ClassMixinSet( Tcl_Obj *const *objv) { Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp); - int mixinc, i; + size_t mixinc, i; Tcl_Obj **mixinv; Class **mixins; @@ -2456,7 +2457,7 @@ ClassMixinSet( "attempt to misuse API", -1)); Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL); return TCL_ERROR; - } else if (TclListObjGetElements_(interp, objv[0], &mixinc, + } else if (Tcl_ListObjGetElements(interp, objv[0], &mixinc, &mixinv) != TCL_OK) { return TCL_ERROR; } @@ -2543,7 +2544,8 @@ ClassSuperSet( Tcl_Obj *const *objv) { Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp); - int superc, i, j; + size_t superc, j; + int i; Tcl_Obj **superv; Class **superclasses, *superPtr; @@ -2566,7 +2568,7 @@ ClassSuperSet( "may not modify the superclass of the root object", -1)); Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL); return TCL_ERROR; - } else if (TclListObjGetElements_(interp, objv[0], &superc, + } else if (Tcl_ListObjGetElements(interp, objv[0], &superc, &superv) != TCL_OK) { return TCL_ERROR; } @@ -2594,13 +2596,13 @@ ClassSuperSet( superc = 1; AddRef(superclasses[0]->thisPtr); } else { - for (i = 0; i < superc; i++) { + for (i = 0; i < (int)superc; i++) { superclasses[i] = GetClassInOuterContext(interp, superv[i], "only a class can be a superclass"); if (superclasses[i] == NULL) { goto failedAfterAlloc; } - for (j = 0; j < i; j++) { + for (j = 0; (int)j < i; j++) { if (superclasses[j] == superclasses[i]) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "class should only be a direct superclass once", @@ -2718,9 +2720,9 @@ ClassVarsSet( Tcl_Obj *const *objv) { Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp); - int varc; - Tcl_Obj **varv; int i; + size_t varc; + Tcl_Obj **varv; if ((int)Tcl_ObjectContextSkippedArgs(context) + 1 != objc) { Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv, @@ -2736,12 +2738,12 @@ ClassVarsSet( "attempt to misuse API", -1)); Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL); return TCL_ERROR; - } else if (TclListObjGetElements_(interp, objv[0], &varc, + } else if (Tcl_ListObjGetElements(interp, objv[0], &varc, &varv) != TCL_OK) { return TCL_ERROR; } - for (i = 0; i < varc; i++) { + for (i = 0; i < (int)varc; i++) { const char *varName = TclGetString(varv[i]); if (strstr(varName, "::") != NULL) { @@ -2817,7 +2819,7 @@ ObjFilterSet( Tcl_Obj *const *objv) { Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp); - int filterc; + size_t filterc; Tcl_Obj **filterv; if ((int)Tcl_ObjectContextSkippedArgs(context) + 1 != objc) { @@ -2828,7 +2830,7 @@ ObjFilterSet( return TCL_ERROR; } objv += Tcl_ObjectContextSkippedArgs(context); - if (TclListObjGetElements_(interp, objv[0], &filterc, + if (Tcl_ListObjGetElements(interp, objv[0], &filterc, &filterv) != TCL_OK) { return TCL_ERROR; } @@ -2889,10 +2891,10 @@ ObjMixinSet( Tcl_Obj *const *objv) { Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp); - int mixinc; + int i; + size_t mixinc; Tcl_Obj **mixinv; Class **mixins; - int i; if ((int)Tcl_ObjectContextSkippedArgs(context) + 1 != objc) { Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv, @@ -2902,14 +2904,14 @@ ObjMixinSet( return TCL_ERROR; } objv += Tcl_ObjectContextSkippedArgs(context); - if (TclListObjGetElements_(interp, objv[0], &mixinc, + if (Tcl_ListObjGetElements(interp, objv[0], &mixinc, &mixinv) != TCL_OK) { return TCL_ERROR; } mixins = (Class **)TclStackAlloc(interp, sizeof(Class *) * mixinc); - for (i = 0; i < mixinc; i++) { + for (i = 0; i < (int)mixinc; i++) { mixins[i] = GetClassInOuterContext(interp, mixinv[i], "may only mix in classes"); if (mixins[i] == NULL) { @@ -2981,7 +2983,7 @@ ObjVarsSet( Tcl_Obj *const *objv) { Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp); - int varc, i; + size_t varc, i; Tcl_Obj **varv; if ((int)Tcl_ObjectContextSkippedArgs(context) + 1 != objc) { @@ -2992,7 +2994,7 @@ ObjVarsSet( return TCL_ERROR; } objv += Tcl_ObjectContextSkippedArgs(context); - if (TclListObjGetElements_(interp, objv[0], &varc, + if (Tcl_ListObjGetElements(interp, objv[0], &varc, &varv) != TCL_OK) { return TCL_ERROR; } diff --git a/generic/tclOOIntDecls.h b/generic/tclOOIntDecls.h index 6a5cfd3..65c33d1 100644 --- a/generic/tclOOIntDecls.h +++ b/generic/tclOOIntDecls.h @@ -82,7 +82,7 @@ TCLAPI void TclOOObjectSetFilters(Object *oPtr, int numFilters, Tcl_Obj *const *filters); /* 13 */ TCLAPI void TclOOClassSetFilters(Tcl_Interp *interp, - Class *classPtr, int numFilters, + Class *classPtr, size_t numFilters, Tcl_Obj *const *filters); /* 14 */ TCLAPI void TclOOObjectSetMixins(Object *oPtr, int numMixins, @@ -109,7 +109,7 @@ typedef struct TclOOIntStubs { Tcl_Method (*tclOONewProcMethodEx) (Tcl_Interp *interp, Tcl_Class clsPtr, TclOO_PreCallProc *preCallPtr, TclOO_PostCallProc *postCallPtr, ProcErrorProc *errProc, void *clientData, Tcl_Obj *nameObj, Tcl_Obj *argsObj, Tcl_Obj *bodyObj, int flags, void **internalTokenPtr); /* 10 */ int (*tclOOInvokeObject) (Tcl_Interp *interp, Tcl_Object object, Tcl_Class startCls, int publicPrivate, int objc, Tcl_Obj *const *objv); /* 11 */ void (*tclOOObjectSetFilters) (Object *oPtr, int numFilters, Tcl_Obj *const *filters); /* 12 */ - void (*tclOOClassSetFilters) (Tcl_Interp *interp, Class *classPtr, int numFilters, Tcl_Obj *const *filters); /* 13 */ + void (*tclOOClassSetFilters) (Tcl_Interp *interp, Class *classPtr, size_t numFilters, Tcl_Obj *const *filters); /* 13 */ void (*tclOOObjectSetMixins) (Object *oPtr, int numMixins, Class *const *mixins); /* 14 */ void (*tclOOClassSetMixins) (Tcl_Interp *interp, Class *classPtr, int numMixins, Class *const *mixins); /* 15 */ } TclOOIntStubs; diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c index 94402d8..16d81fe 100644 --- a/generic/tclStubInit.c +++ b/generic/tclStubInit.c @@ -86,8 +86,8 @@ static void uniCodePanic() { #define TclUtfNext Tcl_UtfNext #define TclUtfPrev Tcl_UtfPrev -#define LOGetElements TclListObjGetElements_ -#define LOLength TclListObjLength_ +#define TclListObjGetElements_ LOGetElements +#define TclListObjLength_ LOLength #define TclDictObjSize_ DOSize #define TclSplitList_ SplitList #define TclSplitPath_ SplitPath -- cgit v0.12 From 77d4b65664ad50b899d6bbb2abd4e81275027900 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 27 Jan 2022 17:27:19 +0000 Subject: More int -> size_t, especially TclOO --- generic/tclOO.c | 23 ++++++++++++++--------- generic/tclOO.decls | 2 +- generic/tclOOBasic.c | 2 +- generic/tclOOCall.c | 43 ++++++++++++++++++++++++------------------- generic/tclOODefineCmds.c | 42 ++++++++++++++++++++++-------------------- generic/tclOOInfo.c | 27 +++++++++++++++------------ generic/tclOOInt.h | 6 +++--- generic/tclOOIntDecls.h | 6 +++--- generic/tclOOMethod.c | 4 ++-- generic/tclVar.c | 3 ++- 10 files changed, 87 insertions(+), 71 deletions(-) diff --git a/generic/tclOO.c b/generic/tclOO.c index 00caacd..2d741ba 100644 --- a/generic/tclOO.c +++ b/generic/tclOO.c @@ -308,7 +308,7 @@ InitFoundation( Tcl_Obj *namePtr; Tcl_DString buffer; Command *cmdPtr; - int i; + size_t i; /* * Initialize the structure that holds the OO system core. This is @@ -960,7 +960,7 @@ TclOOReleaseClassContents( Object *oPtr) /* The object representing the class. */ { FOREACH_HASH_DECLS; - int i; + size_t i; Class *clsPtr = oPtr->classPtr, *tmpClsPtr; Method *mPtr; Foundation *fPtr = oPtr->fPtr; @@ -1121,7 +1121,7 @@ ObjectNamespaceDeleted( Tcl_Obj *filterObj, *variableObj; PrivateVariableMapping *privateVariable; Tcl_Interp *interp = oPtr->fPtr->interp; - int i; + size_t i; if (Destructing(oPtr)) { /* @@ -1362,7 +1362,8 @@ TclOORemoveFromInstances( Class *clsPtr) /* The class (possibly) containing the * reference to the instance. */ { - int i, res = 0; + size_t i; + int res = 0; Object *instPtr; FOREACH(instPtr, clsPtr->instances) { @@ -1424,7 +1425,8 @@ TclOORemoveFromMixins( Object *oPtr) /* The object (possibly) containing the * reference to the mixin. */ { - int i, res = 0; + size_t i; + int res = 0; Class *mixPtr; FOREACH(mixPtr, oPtr->mixins) { @@ -1459,7 +1461,8 @@ TclOORemoveFromSubclasses( Class *superPtr) /* The superclass to possibly remove the * subclass reference from. */ { - int i, res = 0; + size_t i; + int res = 0; Class *subclsPtr; FOREACH(subclsPtr, superPtr->subclasses) { @@ -1523,7 +1526,8 @@ TclOORemoveFromMixinSubs( Class *superPtr) /* The superclass to possibly remove the * subclass reference from. */ { - int i, res = 0; + size_t i; + int res = 0; Class *subclsPtr; FOREACH(subclsPtr, superPtr->mixinSubs) { @@ -1928,7 +1932,8 @@ Tcl_CopyObjectInstance( CallContext *contextPtr; Tcl_Obj *keyPtr, *filterObj, *variableObj, *args[3]; PrivateVariableMapping *privateVariable; - int i, result; + size_t i; + int result; /* * Sanity check. @@ -2995,7 +3000,7 @@ TclOOIsReachable( Class *targetPtr, Class *startPtr) { - int i; + size_t i; Class *superPtr; tailRecurse: diff --git a/generic/tclOO.decls b/generic/tclOO.decls index 980aeb0..d0751bc 100644 --- a/generic/tclOO.decls +++ b/generic/tclOO.decls @@ -204,7 +204,7 @@ declare 11 { Tcl_Obj *const *objv) } declare 12 { - void TclOOObjectSetFilters(Object *oPtr, int numFilters, + void TclOOObjectSetFilters(Object *oPtr, size_t numFilters, Tcl_Obj *const *filters) } declare 13 { diff --git a/generic/tclOOBasic.c b/generic/tclOOBasic.c index ef17896..753474a 100644 --- a/generic/tclOOBasic.c +++ b/generic/tclOOBasic.c @@ -777,7 +777,7 @@ TclOO_Object_VarName( Method *mPtr = callerContext->callPtr->chain[ callerContext->index].mPtr; PrivateVariableMapping *pvPtr; - int i; + size_t i; if (mPtr->declaringObjectPtr == oPtr) { FOREACH_STRUCT(pvPtr, oPtr->privateVariables) { diff --git a/generic/tclOOCall.c b/generic/tclOOCall.c index 60666f4..c25d951 100644 --- a/generic/tclOOCall.c +++ b/generic/tclOOCall.c @@ -137,7 +137,7 @@ static inline int IsStillValid(CallChain *callPtr, Object *oPtr, int flags, int reuseMask); static Tcl_NRPostProc ResetFilterFlags; static Tcl_NRPostProc SetFilterFlags; -static int SortMethodNames(Tcl_HashTable *namesPtr, int flags, +static size_t SortMethodNames(Tcl_HashTable *namesPtr, int flags, const char ***stringsPtr); static inline void StashCallChain(Tcl_Obj *objPtr, CallChain *callPtr); @@ -445,7 +445,7 @@ TclOOGetSortedMethodList( * at. Is set-like in nature and keyed by * pointer to class. */ FOREACH_HASH_DECLS; - int i, numStrings; + size_t i, numStrings; Class *mixinPtr; Tcl_Obj *namePtr; Method *mPtr; @@ -521,7 +521,7 @@ TclOOGetSortedMethodList( return numStrings; } -int +size_t TclOOGetSortedClassMethodList( Class *clsPtr, /* The class to get the method names for. */ int flags, /* Whether we just want the public method @@ -535,7 +535,7 @@ TclOOGetSortedClassMethodList( /* Used to track what classes have been looked * at. Is set-like in nature and keyed by * pointer to class. */ - int numStrings; + size_t numStrings; Tcl_InitObjHashTable(&names); Tcl_InitHashTable(&examinedClasses, TCL_ONE_WORD_KEYS); @@ -580,7 +580,7 @@ TclOOGetSortedClassMethodList( * ---------------------------------------------------------------------- */ -static int +static size_t SortMethodNames( Tcl_HashTable *namesPtr, /* The table of names; unsorted, but contains * whether the names are wanted and under what @@ -686,7 +686,7 @@ AddClassMethodNames( * pointers to the classes, and the values are * immaterial. */ { - int i; + size_t i; /* * If we've already started looking at this class, stop working on it now @@ -877,7 +877,8 @@ AddSimpleChainToCallContext( * NULL, either the filter was declared by the * object or this isn't a filter. */ { - int i, foundPrivate = 0, blockedUnexported = 0; + size_t i; + int foundPrivate = 0, blockedUnexported = 0; Tcl_HashEntry *hPtr; Method *mPtr; @@ -1149,7 +1150,8 @@ TclOOGetCallContext( CallContext *contextPtr; CallChain *callPtr; struct ChainBuilder cb; - int i, count, doFilters, donePrivate = 0; + size_t i, count; + int doFilters, donePrivate = 0; Tcl_HashEntry *hPtr; Tcl_HashTable doneFilters; @@ -1309,7 +1311,7 @@ TclOOGetCallContext( * cacheing of the method implementation (if relevant). */ - if (count == callPtr->numChain) { + if ((int)count == callPtr->numChain) { /* * Method does not actually exist. If we're dealing with constructors * or destructors, this isn't a problem. @@ -1326,12 +1328,13 @@ TclOOGetCallContext( oPtr->fPtr->unknownMethodNameObj, &cb, NULL, 0, NULL); callPtr->flags |= OO_UNKNOWN_METHOD; callPtr->epoch = 0; - if (count == callPtr->numChain) { + if ((int)count == callPtr->numChain) { TclOODeleteChain(callPtr); return NULL; } } else if (doFilters && !donePrivate) { if (hPtr == NULL) { + int isNew; if (oPtr->flags & USE_CLASS_CACHE) { if (oPtr->selfCls->classChainCache == NULL) { oPtr->selfCls->classChainCache = @@ -1340,7 +1343,7 @@ TclOOGetCallContext( Tcl_InitObjHashTable(oPtr->selfCls->classChainCache); } hPtr = Tcl_CreateHashEntry(oPtr->selfCls->classChainCache, - (char *) methodNameObj, &i); + (char *) methodNameObj, &isNew); } else { if (oPtr->chainCache == NULL) { oPtr->chainCache = (Tcl_HashTable *)Tcl_Alloc(sizeof(Tcl_HashTable)); @@ -1348,7 +1351,7 @@ TclOOGetCallContext( Tcl_InitObjHashTable(oPtr->chainCache); } hPtr = Tcl_CreateHashEntry(oPtr->chainCache, - (char *) methodNameObj, &i); + (char *) methodNameObj, &isNew); } } callPtr->refCount++; @@ -1542,7 +1545,8 @@ AddClassFiltersToCallContext( int flags) /* Whether we've gone along a mixin link * yet. */ { - int i, clearedFlags = + size_t i; + int clearedFlags = flags & ~(TRAVERSED_MIXIN|OBJECT_MIXIN|BUILDING_MIXINS); Class *superPtr, *mixinPtr; Tcl_Obj *filterObj; @@ -1631,7 +1635,7 @@ AddPrivatesFromClassChainToCallContext( * NULL, either the filter was declared by the * object or this isn't a filter. */ { - int i; + size_t i; Class *superPtr; /* @@ -1709,7 +1713,8 @@ AddSimpleClassChainToCallContext( * NULL, either the filter was declared by the * object or this isn't a filter. */ { - int i, privateDanger = 0; + size_t i; + int privateDanger = 0; Class *superPtr; /* @@ -1794,7 +1799,7 @@ TclOORenderCallChain( Tcl_Obj *filterLiteral, *methodLiteral, *objectLiteral, *privateLiteral; Tcl_Obj *resultObj, *descObjs[4], **objv; Foundation *fPtr = TclOOGetFoundation(interp); - int i; + size_t i; /* * Allocate the literals (potentially) used in our description. @@ -1822,7 +1827,7 @@ TclOORenderCallChain( */ objv = (Tcl_Obj **)TclStackAlloc(interp, callPtr->numChain * sizeof(Tcl_Obj *)); - for (i = 0 ; i < callPtr->numChain ; i++) { + for (i = 0 ; i < (size_t)callPtr->numChain ; i++) { struct MInvoke *miPtr = &callPtr->chain[i]; descObjs[0] = @@ -1950,7 +1955,7 @@ AddSimpleDefineNamespaces( * building. */ { Class *mixinPtr; - int i; + size_t i; FOREACH(mixinPtr, oPtr->mixins) { AddSimpleClassDefineNamespaces(mixinPtr, definePtr, @@ -1979,7 +1984,7 @@ AddSimpleClassDefineNamespaces( int flags) /* What sort of define chain are we * building. */ { - int i; + size_t i; Class *superPtr; /* diff --git a/generic/tclOODefineCmds.c b/generic/tclOODefineCmds.c index 2a04d37..e589b24 100644 --- a/generic/tclOODefineCmds.c +++ b/generic/tclOODefineCmds.c @@ -249,10 +249,10 @@ RecomputeClassCacheFlag( void TclOOObjectSetFilters( Object *oPtr, - int numFilters, + size_t numFilters, Tcl_Obj *const *filters) { - int i; + size_t i; if (oPtr->filters.num) { Tcl_Obj *filterObj; @@ -312,7 +312,7 @@ TclOOClassSetFilters( size_t numFilters, Tcl_Obj *const *filters) { - int i; + size_t i; if (classPtr->filters.num) { Tcl_Obj *filterObj; @@ -343,7 +343,7 @@ TclOOClassSetFilters( } else { filtersList = (Tcl_Obj **)Tcl_Realloc(classPtr->filters.list, size); } - for (i = 0 ; i < (int)numFilters ; i++) { + for (i = 0 ; i < numFilters ; i++) { filtersList[i] = filters[i]; Tcl_IncrRefCount(filters[i]); } @@ -375,7 +375,7 @@ TclOOObjectSetMixins( Class *const *mixins) { Class *mixinPtr; - int i; + size_t i; if (numMixins == 0) { if (oPtr->mixins.num != 0) { @@ -436,7 +436,7 @@ TclOOClassSetMixins( Class *const *mixins) { Class *mixinPtr; - int i; + size_t i; if (numMixins == 0) { if (classPtr->mixins.num != 0) { @@ -485,11 +485,12 @@ TclOOClassSetMixins( static inline void InstallStandardVariableMapping( VariableNameList *vnlPtr, - int varc, + size_t varc, Tcl_Obj *const *varv) { Tcl_Obj *variableObj; - int i, n, created; + size_t i, n; + int created; Tcl_HashTable uniqueTable; for (i=0 ; ithisPtr); } else { - for (i = 0; i < (int)superc; i++) { + for (i = 0; i < superc; i++) { superclasses[i] = GetClassInOuterContext(interp, superv[i], "only a class can be a superclass"); if (superclasses[i] == NULL) { goto failedAfterAlloc; } - for (j = 0; (int)j < i; j++) { + for (j = 0; j < i; j++) { if (superclasses[j] == superclasses[i]) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "class should only be a direct superclass once", @@ -2677,7 +2679,7 @@ ClassVarsGet( { Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp); Tcl_Obj *resultObj; - int i; + size_t i; if ((int)Tcl_ObjectContextSkippedArgs(context) != objc) { Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv, @@ -2792,7 +2794,7 @@ ObjFilterGet( { Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp); Tcl_Obj *resultObj, *filterObj; - int i; + size_t i; if ((int)Tcl_ObjectContextSkippedArgs(context) != objc) { Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv, @@ -2861,7 +2863,7 @@ ObjMixinGet( Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp); Tcl_Obj *resultObj; Class *mixinPtr; - int i; + size_t i; if ((int)Tcl_ObjectContextSkippedArgs(context) != objc) { Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv, @@ -2946,7 +2948,7 @@ ObjVarsGet( { Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp); Tcl_Obj *resultObj; - int i; + size_t i; if ((int)Tcl_ObjectContextSkippedArgs(context) != objc) { Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv, diff --git a/generic/tclOOInfo.c b/generic/tclOOInfo.c index ede00b8..8123cd2 100644 --- a/generic/tclOOInfo.c +++ b/generic/tclOOInfo.c @@ -194,7 +194,7 @@ InfoObjectClassCmd( return TCL_OK; } else { Class *mixinPtr, *o2clsPtr; - int i; + size_t i; o2clsPtr = GetClassFromObj(interp, objv[2]); if (o2clsPtr == NULL) { @@ -307,7 +307,7 @@ InfoObjectFiltersCmd( int objc, Tcl_Obj *const objv[]) { - int i; + size_t i; Tcl_Obj *filterObj, *resultObj; Object *oPtr; @@ -410,7 +410,8 @@ InfoObjectIsACmd( IsClass, IsMetaclass, IsMixin, IsObject, IsType }; Object *oPtr, *o2Ptr; - int idx, i, result = 0; + int idx, result = 0; + size_t i; if (objc < 3) { Tcl_WrongNumArgs(interp, 1, objv, "category objName ?arg ...?"); @@ -702,7 +703,7 @@ InfoObjectMixinsCmd( Class *mixinPtr; Object *oPtr; Tcl_Obj *resultObj; - int i; + size_t i; if (objc != 2) { Tcl_WrongNumArgs(interp, 1, objv, "objName"); @@ -809,7 +810,8 @@ InfoObjectVariablesCmd( { Object *oPtr; Tcl_Obj *resultObj; - int i, isPrivate = 0; + size_t i; + int isPrivate = 0; if (objc != 2 && objc != 3) { Tcl_WrongNumArgs(interp, 1, objv, "objName ?-private?"); @@ -1145,7 +1147,7 @@ InfoClassFiltersCmd( int objc, Tcl_Obj *const objv[]) { - int i; + size_t i; Tcl_Obj *filterObj, *resultObj; Class *clsPtr; @@ -1236,7 +1238,7 @@ InfoClassInstancesCmd( { Object *oPtr; Class *clsPtr; - int i; + size_t i; const char *pattern = NULL; Tcl_Obj *resultObj; @@ -1359,7 +1361,7 @@ InfoClassMethodsCmd( TclNewObj(resultObj); if (recurse) { const char **names; - int i, numNames = TclOOGetSortedClassMethodList(clsPtr, flag, &names); + size_t i, numNames = TclOOGetSortedClassMethodList(clsPtr, flag, &names); for (i=0 ; i Date: Thu, 27 Jan 2022 22:26:05 +0000 Subject: 3 more API's --- generic/tcl.decls | 6 +++--- generic/tclDecls.h | 12 ++++++------ generic/tclFileName.c | 5 ++--- generic/tclInt.decls | 10 +++++----- generic/tclIntDecls.h | 23 +++++++++++------------ generic/tclStringObj.c | 2 +- generic/tclUtil.c | 5 ++--- 7 files changed, 30 insertions(+), 33 deletions(-) diff --git a/generic/tcl.decls b/generic/tcl.decls index ff2460f..6428101 100644 --- a/generic/tcl.decls +++ b/generic/tcl.decls @@ -320,7 +320,7 @@ declare 82 { int Tcl_CommandComplete(const char *cmd) } declare 83 { - char *Tcl_Concat(int argc, const char *const *argv) + char *Tcl_Concat(size_t argc, const char *const *argv) } declare 84 { size_t Tcl_ConvertElement(const char *src, char *dst, int flags) @@ -685,7 +685,7 @@ declare 185 { } # Obsolete, use Tcl_FSJoinPath declare 186 { - char *Tcl_JoinPath(int argc, const char *const *argv, + char *Tcl_JoinPath(size_t argc, const char *const *argv, Tcl_DString *resultPtr) } declare 187 { @@ -2155,7 +2155,7 @@ declare 575 { size_t length, size_t limit, const char *ellipsis) } declare 576 { - Tcl_Obj *Tcl_Format(Tcl_Interp *interp, const char *format, int objc, + Tcl_Obj *Tcl_Format(Tcl_Interp *interp, const char *format, size_t objc, Tcl_Obj *const objv[]) } declare 577 { diff --git a/generic/tclDecls.h b/generic/tclDecls.h index aefe43f..92efa47 100644 --- a/generic/tclDecls.h +++ b/generic/tclDecls.h @@ -246,7 +246,7 @@ EXTERN void Tcl_CancelIdleCall(Tcl_IdleProc *idleProc, /* 82 */ EXTERN int Tcl_CommandComplete(const char *cmd); /* 83 */ -EXTERN char * Tcl_Concat(int argc, const char *const *argv); +EXTERN char * Tcl_Concat(size_t argc, const char *const *argv); /* 84 */ EXTERN size_t Tcl_ConvertElement(const char *src, char *dst, int flags); @@ -517,7 +517,7 @@ EXTERN int Tcl_InterpDeleted(Tcl_Interp *interp); /* 185 */ EXTERN int Tcl_IsSafe(Tcl_Interp *interp); /* 186 */ -EXTERN char * Tcl_JoinPath(int argc, const char *const *argv, +EXTERN char * Tcl_JoinPath(size_t argc, const char *const *argv, Tcl_DString *resultPtr); /* 187 */ EXTERN int Tcl_LinkVar(Tcl_Interp *interp, const char *varName, @@ -1522,7 +1522,7 @@ EXTERN void Tcl_AppendLimitedToObj(Tcl_Obj *objPtr, size_t limit, const char *ellipsis); /* 576 */ EXTERN Tcl_Obj * Tcl_Format(Tcl_Interp *interp, const char *format, - int objc, Tcl_Obj *const objv[]); + size_t objc, Tcl_Obj *const objv[]); /* 577 */ EXTERN int Tcl_AppendFormatToObj(Tcl_Interp *interp, Tcl_Obj *objPtr, const char *format, @@ -1875,7 +1875,7 @@ typedef struct TclStubs { void (*tcl_CancelIdleCall) (Tcl_IdleProc *idleProc, void *clientData); /* 80 */ void (*reserved81)(void); int (*tcl_CommandComplete) (const char *cmd); /* 82 */ - char * (*tcl_Concat) (int argc, const char *const *argv); /* 83 */ + char * (*tcl_Concat) (size_t argc, const char *const *argv); /* 83 */ size_t (*tcl_ConvertElement) (const char *src, char *dst, int flags); /* 84 */ size_t (*tcl_ConvertCountedElement) (const char *src, size_t length, char *dst, int flags); /* 85 */ int (*tcl_CreateAlias) (Tcl_Interp *childInterp, const char *childCmd, Tcl_Interp *target, const char *targetCmd, int argc, const char *const *argv); /* 86 */ @@ -1978,7 +1978,7 @@ typedef struct TclStubs { int (*tcl_InputBuffered) (Tcl_Channel chan); /* 183 */ int (*tcl_InterpDeleted) (Tcl_Interp *interp); /* 184 */ int (*tcl_IsSafe) (Tcl_Interp *interp); /* 185 */ - char * (*tcl_JoinPath) (int argc, const char *const *argv, Tcl_DString *resultPtr); /* 186 */ + char * (*tcl_JoinPath) (size_t argc, const char *const *argv, Tcl_DString *resultPtr); /* 186 */ int (*tcl_LinkVar) (Tcl_Interp *interp, const char *varName, void *addr, int type); /* 187 */ void (*reserved188)(void); Tcl_Channel (*tcl_MakeFileChannel) (void *handle, int mode); /* 189 */ @@ -2368,7 +2368,7 @@ typedef struct TclStubs { int (*tcl_PkgRequireProc) (Tcl_Interp *interp, const char *name, int objc, Tcl_Obj *const objv[], void *clientDataPtr); /* 573 */ void (*tcl_AppendObjToErrorInfo) (Tcl_Interp *interp, Tcl_Obj *objPtr); /* 574 */ void (*tcl_AppendLimitedToObj) (Tcl_Obj *objPtr, const char *bytes, size_t length, size_t limit, const char *ellipsis); /* 575 */ - Tcl_Obj * (*tcl_Format) (Tcl_Interp *interp, const char *format, int objc, Tcl_Obj *const objv[]); /* 576 */ + Tcl_Obj * (*tcl_Format) (Tcl_Interp *interp, const char *format, size_t objc, Tcl_Obj *const objv[]); /* 576 */ int (*tcl_AppendFormatToObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, const char *format, size_t objc, Tcl_Obj *const objv[]); /* 577 */ Tcl_Obj * (*tcl_ObjPrintf) (const char *format, ...) TCL_FORMAT_PRINTF(1, 2); /* 578 */ void (*tcl_AppendPrintfToObj) (Tcl_Obj *objPtr, const char *format, ...) TCL_FORMAT_PRINTF(2, 3); /* 579 */ diff --git a/generic/tclFileName.c b/generic/tclFileName.c index 5a731eb..fd86209 100644 --- a/generic/tclFileName.c +++ b/generic/tclFileName.c @@ -975,12 +975,11 @@ TclpNativeJoinPath( char * Tcl_JoinPath( - int argc, + size_t argc, const char *const *argv, Tcl_DString *resultPtr) /* Pointer to previously initialized DString */ { - int i; - size_t len; + size_t i, len; Tcl_Obj *listObj; Tcl_Obj *resultObj; const char *resultStr; diff --git a/generic/tclInt.decls b/generic/tclInt.decls index aa2bd2f..633233b 100644 --- a/generic/tclInt.decls +++ b/generic/tclInt.decls @@ -454,7 +454,7 @@ declare 229 { declare 230 { Var *TclObjLookupVar(Tcl_Interp *interp, Tcl_Obj *part1Ptr, const char *part2, int flags, const char *msg, - const int createPart1, const int createPart2, Var **arrayPtrPtr) + int createPart1, int createPart2, Var **arrayPtrPtr) } declare 231 { int TclGetNamespaceFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr, @@ -557,17 +557,17 @@ declare 251 { declare 252 { Tcl_Obj *TclPtrGetVar(Tcl_Interp *interp, Tcl_Var varPtr, Tcl_Var arrayPtr, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, - const int flags) + int flags) } declare 253 { Tcl_Obj *TclPtrSetVar(Tcl_Interp *interp, Tcl_Var varPtr, Tcl_Var arrayPtr, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, - Tcl_Obj *newValuePtr, const int flags) + Tcl_Obj *newValuePtr, int flags) } declare 254 { Tcl_Obj *TclPtrIncrObjVar(Tcl_Interp *interp, Tcl_Var varPtr, Tcl_Var arrayPtr, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, - Tcl_Obj *incrPtr, const int flags) + Tcl_Obj *incrPtr, int flags) } declare 255 { int TclPtrObjMakeUpvar(Tcl_Interp *interp, Tcl_Var otherPtr, @@ -575,7 +575,7 @@ declare 255 { } declare 256 { int TclPtrUnsetVar(Tcl_Interp *interp, Tcl_Var varPtr, Tcl_Var arrayPtr, - Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, const int flags) + Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, int flags) } declare 257 { void TclStaticLibrary(Tcl_Interp *interp, const char *prefix, diff --git a/generic/tclIntDecls.h b/generic/tclIntDecls.h index 9022412..679ae7f 100644 --- a/generic/tclIntDecls.h +++ b/generic/tclIntDecls.h @@ -483,9 +483,8 @@ EXTERN int TclPtrMakeUpvar(Tcl_Interp *interp, Var *otherP1Ptr, /* 230 */ EXTERN Var * TclObjLookupVar(Tcl_Interp *interp, Tcl_Obj *part1Ptr, const char *part2, - int flags, const char *msg, - const int createPart1, const int createPart2, - Var **arrayPtrPtr); + int flags, const char *msg, int createPart1, + int createPart2, Var **arrayPtrPtr); /* 231 */ EXTERN int TclGetNamespaceFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr, Tcl_Namespace **nsPtrPtr); @@ -551,17 +550,17 @@ EXTERN int TclRegisterLiteral(void *envPtr, const char *bytes, /* 252 */ EXTERN Tcl_Obj * TclPtrGetVar(Tcl_Interp *interp, Tcl_Var varPtr, Tcl_Var arrayPtr, Tcl_Obj *part1Ptr, - Tcl_Obj *part2Ptr, const int flags); + Tcl_Obj *part2Ptr, int flags); /* 253 */ EXTERN Tcl_Obj * TclPtrSetVar(Tcl_Interp *interp, Tcl_Var varPtr, Tcl_Var arrayPtr, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, Tcl_Obj *newValuePtr, - const int flags); + int flags); /* 254 */ EXTERN Tcl_Obj * TclPtrIncrObjVar(Tcl_Interp *interp, Tcl_Var varPtr, Tcl_Var arrayPtr, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, Tcl_Obj *incrPtr, - const int flags); + int flags); /* 255 */ EXTERN int TclPtrObjMakeUpvar(Tcl_Interp *interp, Tcl_Var otherPtr, Tcl_Obj *myNamePtr, @@ -569,7 +568,7 @@ EXTERN int TclPtrObjMakeUpvar(Tcl_Interp *interp, /* 256 */ EXTERN int TclPtrUnsetVar(Tcl_Interp *interp, Tcl_Var varPtr, Tcl_Var arrayPtr, Tcl_Obj *part1Ptr, - Tcl_Obj *part2Ptr, const int flags); + Tcl_Obj *part2Ptr, int flags); /* 257 */ EXTERN void TclStaticLibrary(Tcl_Interp *interp, const char *prefix, @@ -813,7 +812,7 @@ typedef struct TclIntStubs { void (*tclSetNsPath) (Namespace *nsPtr, size_t pathLength, Tcl_Namespace *pathAry[]); /* 227 */ void (*reserved228)(void); int (*tclPtrMakeUpvar) (Tcl_Interp *interp, Var *otherP1Ptr, const char *myName, int myFlags, int index); /* 229 */ - Var * (*tclObjLookupVar) (Tcl_Interp *interp, Tcl_Obj *part1Ptr, const char *part2, int flags, const char *msg, const int createPart1, const int createPart2, Var **arrayPtrPtr); /* 230 */ + Var * (*tclObjLookupVar) (Tcl_Interp *interp, Tcl_Obj *part1Ptr, const char *part2, int flags, const char *msg, int createPart1, int createPart2, Var **arrayPtrPtr); /* 230 */ int (*tclGetNamespaceFromObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, Tcl_Namespace **nsPtrPtr); /* 231 */ int (*tclEvalObjEx) (Tcl_Interp *interp, Tcl_Obj *objPtr, int flags, const CmdFrame *invoker, int word); /* 232 */ void (*tclGetSrcInfoForPc) (CmdFrame *contextPtr); /* 233 */ @@ -835,11 +834,11 @@ typedef struct TclIntStubs { char * (*tclDoubleDigits) (double dv, int ndigits, int flags, int *decpt, int *signum, char **endPtr); /* 249 */ void (*tclSetChildCancelFlags) (Tcl_Interp *interp, int flags, int force); /* 250 */ int (*tclRegisterLiteral) (void *envPtr, const char *bytes, size_t length, int flags); /* 251 */ - Tcl_Obj * (*tclPtrGetVar) (Tcl_Interp *interp, Tcl_Var varPtr, Tcl_Var arrayPtr, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, const int flags); /* 252 */ - Tcl_Obj * (*tclPtrSetVar) (Tcl_Interp *interp, Tcl_Var varPtr, Tcl_Var arrayPtr, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, Tcl_Obj *newValuePtr, const int flags); /* 253 */ - Tcl_Obj * (*tclPtrIncrObjVar) (Tcl_Interp *interp, Tcl_Var varPtr, Tcl_Var arrayPtr, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, Tcl_Obj *incrPtr, const int flags); /* 254 */ + Tcl_Obj * (*tclPtrGetVar) (Tcl_Interp *interp, Tcl_Var varPtr, Tcl_Var arrayPtr, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, int flags); /* 252 */ + Tcl_Obj * (*tclPtrSetVar) (Tcl_Interp *interp, Tcl_Var varPtr, Tcl_Var arrayPtr, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, Tcl_Obj *newValuePtr, int flags); /* 253 */ + Tcl_Obj * (*tclPtrIncrObjVar) (Tcl_Interp *interp, Tcl_Var varPtr, Tcl_Var arrayPtr, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, Tcl_Obj *incrPtr, int flags); /* 254 */ int (*tclPtrObjMakeUpvar) (Tcl_Interp *interp, Tcl_Var otherPtr, Tcl_Obj *myNamePtr, int myFlags); /* 255 */ - int (*tclPtrUnsetVar) (Tcl_Interp *interp, Tcl_Var varPtr, Tcl_Var arrayPtr, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, const int flags); /* 256 */ + int (*tclPtrUnsetVar) (Tcl_Interp *interp, Tcl_Var varPtr, Tcl_Var arrayPtr, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, int flags); /* 256 */ void (*tclStaticLibrary) (Tcl_Interp *interp, const char *prefix, Tcl_LibraryInitProc *initProc, Tcl_LibraryInitProc *safeInitProc); /* 257 */ Tcl_Obj * (*tclpCreateTemporaryDirectory) (Tcl_Obj *dirObj, Tcl_Obj *basenameObj); /* 258 */ } TclIntStubs; diff --git a/generic/tclStringObj.c b/generic/tclStringObj.c index ee2cde9..c643ba7 100644 --- a/generic/tclStringObj.c +++ b/generic/tclStringObj.c @@ -2484,7 +2484,7 @@ Tcl_Obj * Tcl_Format( Tcl_Interp *interp, const char *format, - int objc, + size_t objc, Tcl_Obj *const objv[]) { int result; diff --git a/generic/tclUtil.c b/generic/tclUtil.c index 16fb278..a133d64 100644 --- a/generic/tclUtil.c +++ b/generic/tclUtil.c @@ -1844,11 +1844,10 @@ TclTrim( char * Tcl_Concat( - int argc, /* Number of strings to concatenate. */ + size_t argc, /* Number of strings to concatenate. */ const char *const *argv) /* Array of strings to concatenate. */ { - int i; - size_t needSpace = 0, bytesNeeded = 0; + size_t i, needSpace = 0, bytesNeeded = 0; char *result, *p; /* -- cgit v0.12 From 60f5d30e4406df3a2d80e61d7d9972dce3293133 Mon Sep 17 00:00:00 2001 From: bch Date: Fri, 28 Jan 2022 08:29:14 +0000 Subject: rejig argv/argc Tcl_MainEx() handling, prompted by outside discussion re: current [https://arstechnica.com/information-technology/2022/01/a-bug-lurking-for-12-years-gives-attackers-root-on-every-major-linux-distro/|polkit] issues, and comparisons of execve(2) abuse/mitigation (esp wrt OpenBSD); Probably most importantly, the access to argv has been limited to indexing, not swapping back/forth between indexing and advancing argv; pls review --- generic/tclMain.c | 24 +++++++++++++++--------- 1 file changed, 15 insertions(+), 9 deletions(-) diff --git a/generic/tclMain.c b/generic/tclMain.c index f175319..c2eee13 100644 --- a/generic/tclMain.c +++ b/generic/tclMain.c @@ -288,6 +288,7 @@ Tcl_MainEx( * but before starting to execute commands. */ Tcl_Interp *interp) { + int i=0; /* argv[i] index */ Tcl_Obj *path, *resultPtr, *argvPtr, *appName; const char *encodingName = NULL; int code, exitCode = 0; @@ -296,7 +297,13 @@ Tcl_MainEx( InteractiveState is; TclpSetInitialEncodings(); - TclpFindExecutable((const char *)argv[0]); + if (0 < argc) { + --argc; /* consume argv[0] */ + ++i; + } + TclpFindExecutable((const char *)argv[0]); /* nb: this could be NULL + * w/ (eg) a malformed + * execve() */ Tcl_InitMemory(interp); @@ -318,36 +325,35 @@ Tcl_MainEx( * FILENAME */ - if ((argc > 3) && (0 == _tcscmp(TEXT("-encoding"), argv[1])) + /* mind argc is being adjusted as we proceed */ + if ((argc >= 3) && (0 == _tcscmp(TEXT("-encoding"), argv[1])) && ('-' != argv[3][0])) { Tcl_Obj *value = NewNativeObj(argv[2]); Tcl_SetStartupScript(NewNativeObj(argv[3]), TclGetString(value)); Tcl_DecrRefCount(value); argc -= 3; - argv += 3; - } else if ((argc > 1) && ('-' != argv[1][0])) { + i += 3; + } else if ((argc >= 1) && ('-' != argv[1][0])) { Tcl_SetStartupScript(NewNativeObj(argv[1]), NULL); argc--; - argv++; + i++; } } path = Tcl_GetStartupScript(&encodingName); if (path == NULL) { - appName = NewNativeObj(argv[0]); + appName = NewNativeObj(argv[0]); // nb: argv is _not_ advanced here... } else { appName = path; } Tcl_SetVar2Ex(interp, "argv0", NULL, appName, TCL_GLOBAL_ONLY); - argc--; - argv++; Tcl_SetVar2Ex(interp, "argc", NULL, Tcl_NewWideIntObj(argc), TCL_GLOBAL_ONLY); argvPtr = Tcl_NewListObj(0, NULL); while (argc--) { - Tcl_ListObjAppendElement(NULL, argvPtr, NewNativeObj(*argv++)); + Tcl_ListObjAppendElement(NULL, argvPtr, NewNativeObj(argv[i++])); } Tcl_SetVar2Ex(interp, "argv", NULL, argvPtr, TCL_GLOBAL_ONLY); -- cgit v0.12 From 43b31960b76a22c951489e76a812d22fae7582e2 Mon Sep 17 00:00:00 2001 From: bch Date: Fri, 28 Jan 2022 10:46:06 +0000 Subject: be more strict about using argv[0] --- generic/tclMain.c | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/generic/tclMain.c b/generic/tclMain.c index c2eee13..de745bd 100644 --- a/generic/tclMain.c +++ b/generic/tclMain.c @@ -288,6 +288,7 @@ Tcl_MainEx( * but before starting to execute commands. */ Tcl_Interp *interp) { + char *progname = NULL; /* may/may-not be able to use argv[0] */ int i=0; /* argv[i] index */ Tcl_Obj *path, *resultPtr, *argvPtr, *appName; const char *encodingName = NULL; @@ -298,10 +299,11 @@ Tcl_MainEx( TclpSetInitialEncodings(); if (0 < argc) { + progname = argv[0]; --argc; /* consume argv[0] */ ++i; } - TclpFindExecutable((const char *)argv[0]); /* nb: this could be NULL + TclpFindExecutable ((const char *)progname); /* nb: this could be NULL * w/ (eg) a malformed * execve() */ @@ -343,7 +345,7 @@ Tcl_MainEx( path = Tcl_GetStartupScript(&encodingName); if (path == NULL) { - appName = NewNativeObj(argv[0]); // nb: argv is _not_ advanced here... + appName = NewNativeObj(progname); } else { appName = path; } -- cgit v0.12 From bf64a365e9f1d014beba0694f2dce3718eb64036 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 28 Jan 2022 10:52:40 +0000 Subject: Use more size_t in tclTest.c, for testing the new wrapper functions --- generic/tclTest.c | 8 +++++--- 1 file changed, 5 insertions(+), 3 deletions(-) diff --git a/generic/tclTest.c b/generic/tclTest.c index 5e6ca8c..7c820df 100644 --- a/generic/tclTest.c +++ b/generic/tclTest.c @@ -443,7 +443,8 @@ Tcltest_Init( Tcl_Interp *interp) /* Interpreter for application. */ { Tcl_Obj **objv, *objPtr; - int objc, index; + size_t objc; + int index; static const char *const specialOptions[] = { "-appinitprocerror", "-appinitprocdeleteinterp", "-appinitprocclosestderr", "-appinitprocsetrcfile", NULL @@ -6790,7 +6791,7 @@ SimpleMatchInDirectory( origPtr = SimpleRedirect(dirPtr); res = Tcl_FSMatchInDirectory(interp, resPtr, origPtr, pattern, types); if (res == TCL_OK) { - int gLength, j; + size_t gLength, j; Tcl_ListObjLength(NULL, resPtr, &gLength); for (j = 0; j < gLength; j++) { Tcl_Obj *gElt, *nElt; @@ -7353,7 +7354,8 @@ TestconcatobjCmd( TCL_UNUSED(const char **) /*argv*/) { Tcl_Obj *list1Ptr, *list2Ptr, *emptyPtr, *concatPtr, *tmpPtr; - int result = TCL_OK, len; + int result = TCL_OK; + size_t len; Tcl_Obj *objv[3]; /* -- cgit v0.12 From 8a77ee4ce9cbc4b3b5f858eaf986deff8f654fcd Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 28 Jan 2022 13:25:51 +0000 Subject: Fix ParseArgsObjv() wrapper, and adapt testcase to prove that it works --- generic/tclStubInit.c | 22 ++++++++++++++-------- generic/tclTest.c | 4 ++-- 2 files changed, 16 insertions(+), 10 deletions(-) diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c index f9987cf..5fd6da7 100644 --- a/generic/tclStubInit.c +++ b/generic/tclStubInit.c @@ -133,7 +133,7 @@ static const char *TclUtfPrev(const char *src, const char *start) { static int LOGetElements(Tcl_Interp *interp, Tcl_Obj *listPtr, size_t *objcPtr, Tcl_Obj ***objvPtr) { int n, result = Tcl_ListObjGetElements(interp, listPtr, &n, objvPtr); - if (objcPtr) { + if ((result == TCL_OK) && objcPtr) { *objcPtr = n; } return result; @@ -142,7 +142,7 @@ static int LOLength(Tcl_Interp *interp, Tcl_Obj *listPtr, size_t *lengthPtr) { int n; int result = Tcl_ListObjLength(interp, listPtr, &n); - if (lengthPtr) { + if ((result == TCL_OK) && lengthPtr) { *lengthPtr = n; } return result; @@ -150,7 +150,7 @@ static int LOLength(Tcl_Interp *interp, Tcl_Obj *listPtr, static int DOSize(Tcl_Interp *interp, Tcl_Obj *dictPtr, size_t *sizePtr) { int n, result = Tcl_DictObjSize(interp, dictPtr, &n); - if (sizePtr) { + if ((result == TCL_OK) && sizePtr) { *sizePtr = n; } return result; @@ -159,7 +159,7 @@ static int SplitList(Tcl_Interp *interp, const char *listStr, size_t *argcPtr, const char ***argvPtr) { int n; int result = Tcl_SplitList(interp, listStr, &n, argvPtr); - if (argcPtr) { + if ((result == TCL_OK) && argcPtr) { *argcPtr = n; } return result; @@ -174,7 +174,7 @@ static void SplitPath(const char *path, size_t *argcPtr, const char ***argvPtr) static Tcl_Obj *FSSplitPath(Tcl_Obj *pathPtr, size_t *lenPtr) { int n; Tcl_Obj *result = Tcl_FSSplitPath(pathPtr, &n); - if (lenPtr) { + if (result && lenPtr) { *lenPtr = n; } return result; @@ -182,10 +182,16 @@ static Tcl_Obj *FSSplitPath(Tcl_Obj *pathPtr, size_t *lenPtr) { static int ParseArgsObjv(Tcl_Interp *interp, const Tcl_ArgvInfo *argTable, size_t *objcPtr, Tcl_Obj *const *objv, Tcl_Obj ***remObjv) { - int n, result = Tcl_ParseArgsObjv(interp, argTable, &n, objv, remObjv); - if (objcPtr) { - *objcPtr = n; + int n, result; + if (*objcPtr > INT_MAX) { + if (interp) { + Tcl_AppendResult(interp, "Tcl_ParseArgsObjv cannot handle *objcPtr > INT_MAX", NULL); + } + return TCL_ERROR; } + n = (int)*objcPtr; + result = Tcl_ParseArgsObjv(interp, argTable, &n, objv, remObjv); + *objcPtr = n; return result; } diff --git a/generic/tclTest.c b/generic/tclTest.c index 7c820df..b523a96 100644 --- a/generic/tclTest.c +++ b/generic/tclTest.c @@ -7712,7 +7712,7 @@ TestparseargsCmd( Tcl_Obj *const objv[]) /* Arguments. */ { static int foo = 0; - int count = objc; + size_t count = objc; Tcl_Obj **remObjv, *result[3]; Tcl_ArgvInfo argTable[] = { {TCL_ARGV_CONSTANT, "-bool", INT2PTR(1), &foo, "booltest", NULL}, @@ -7724,7 +7724,7 @@ TestparseargsCmd( return TCL_ERROR; } result[0] = Tcl_NewIntObj(foo); - result[1] = Tcl_NewIntObj(count); + result[1] = Tcl_NewWideIntObj(count); result[2] = Tcl_NewListObj(count, remObjv); Tcl_SetObjResult(interp, Tcl_NewListObj(3, result)); ckfree(remObjv); -- cgit v0.12 From 7a979d7a9a53922375f02407d8ca44c602e8a033 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 28 Jan 2022 16:45:11 +0000 Subject: Fix ParseArgsObjv() wrapper --- generic/tclDecls.h | 2 -- generic/tclOOBasic.c | 2 +- generic/tclStubInit.c | 14 ++------------ generic/tclTest.c | 12 +++++------- win/tclWinDde.c | 3 +-- win/tclWinReg.c | 2 +- 6 files changed, 10 insertions(+), 25 deletions(-) diff --git a/generic/tclDecls.h b/generic/tclDecls.h index 92efa47..596638c 100644 --- a/generic/tclDecls.h +++ b/generic/tclDecls.h @@ -3940,7 +3940,6 @@ extern const TclStubs *tclStubsPtr; # define Tcl_UtfToWChar (sizeof(wchar_t) != sizeof(short) \ ? (int (*)(const char *, wchar_t *))tclStubsPtr->tcl_UtfToChar16 \ : (int (*)(const char *, wchar_t *))Tcl_UtfToUniChar) -#if 0 # undef Tcl_ListObjGetElements # define Tcl_ListObjGetElements(interp, listPtr, objcPtr, objvPtr) (sizeof(*objcPtr) != sizeof(int) \ ? tclStubsPtr->tcl_ListObjGetElements((interp), (listPtr), (size_t *)(void *)(objcPtr), (objvPtr)) \ @@ -3969,7 +3968,6 @@ extern const TclStubs *tclStubsPtr; # define Tcl_ParseArgsObjv(interp, argTable, objcPtr, objv, remObjv) (sizeof(*objcPtr) != sizeof(int) \ ? tclStubsPtr->tcl_ParseArgsObjv((interp), (argTable), (size_t *)(void *)(objcPtr), (objv), (remObjv)) \ : tclStubsPtr->tclParseArgsObjv_((interp), (argTable), (int *)(void *)(objcPtr), (objv), (remObjv))) -#endif /* TCL_NO_DEPRECATED */ #else # define Tcl_WCharToUtfDString (sizeof(wchar_t) != sizeof(short) \ ? (char *(*)(const wchar_t *, size_t, Tcl_DString *))Tcl_UniCharToUtfDString \ diff --git a/generic/tclOOBasic.c b/generic/tclOOBasic.c index 753474a..9573720 100644 --- a/generic/tclOOBasic.c +++ b/generic/tclOOBasic.c @@ -636,7 +636,7 @@ TclOO_Object_LinkVar( Namespace *savedNsPtr; int i; - if (objc-Tcl_ObjectContextSkippedArgs(context) < 0) { + if ((size_t)objc < Tcl_ObjectContextSkippedArgs(context)) { Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv, "?varName ...?"); return TCL_ERROR; diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c index 16d81fe..f41d89d 100644 --- a/generic/tclStubInit.c +++ b/generic/tclStubInit.c @@ -181,19 +181,9 @@ static Tcl_Obj *FSSplitPath(Tcl_Obj *pathPtr, int *lenPtr) { static int ParseArgsObjv(Tcl_Interp *interp, const Tcl_ArgvInfo *argTable, int *objcPtr, Tcl_Obj *const *objv, Tcl_Obj ***remObjv) { - size_t n = TCL_INDEX_NONE; + size_t n = (*objcPtr < 0) ? TCL_INDEX_NONE: (size_t)*objcPtr ; int result = Tcl_ParseArgsObjv(interp, argTable, &n, objv, remObjv); - if (objcPtr) { - if ((result == TCL_OK) && (n > INT_MAX)) { - if (interp) { - Tcl_AppendResult(interp, "Too many args to be processed", NULL); - } - Tcl_Free(*remObjv); - *remObjv = NULL; - return TCL_ERROR; - } - *objcPtr = n; - } + *objcPtr = (int)n; return result; } diff --git a/generic/tclTest.c b/generic/tclTest.c index 7a066fd..91239a9 100644 --- a/generic/tclTest.c +++ b/generic/tclTest.c @@ -440,8 +440,7 @@ Tcltest_Init( Tcl_Interp *interp) /* Interpreter for application. */ { Tcl_Obj **objv, *objPtr; - size_t objc; - int index; + int objc, index; static const char *const specialOptions[] = { "-appinitprocerror", "-appinitprocdeleteinterp", "-appinitprocclosestderr", "-appinitprocsetrcfile", NULL @@ -6790,7 +6789,7 @@ SimpleMatchInDirectory( origPtr = SimpleRedirect(dirPtr); res = Tcl_FSMatchInDirectory(interp, resPtr, origPtr, pattern, types); if (res == TCL_OK) { - size_t gLength, j; + int gLength, j; Tcl_ListObjLength(NULL, resPtr, &gLength); for (j = 0; j < gLength; j++) { Tcl_Obj *gElt, *nElt; @@ -7356,8 +7355,7 @@ TestconcatobjCmd( TCL_UNUSED(const char **) /*argv*/) { Tcl_Obj *list1Ptr, *list2Ptr, *emptyPtr, *concatPtr, *tmpPtr; - int result = TCL_OK; - size_t len; + int result = TCL_OK, len; Tcl_Obj *objv[3]; /* @@ -7714,7 +7712,7 @@ TestparseargsCmd( Tcl_Obj *const objv[]) /* Arguments. */ { static int foo = 0; - size_t count = objc; + int count = objc; Tcl_Obj **remObjv, *result[3]; Tcl_ArgvInfo argTable[] = { {TCL_ARGV_CONSTANT, "-bool", INT2PTR(1), &foo, "booltest", NULL}, @@ -7726,7 +7724,7 @@ TestparseargsCmd( return TCL_ERROR; } result[0] = Tcl_NewIntObj(foo); - result[1] = Tcl_NewWideIntObj((Tcl_WideUInt)(count + 1) - 1); + result[1] = Tcl_NewIntObj(count); result[2] = Tcl_NewListObj(count, remObjv); Tcl_SetObjResult(interp, Tcl_NewListObj(3, result)); Tcl_Free(remObjv); diff --git a/win/tclWinDde.c b/win/tclWinDde.c index 8398677..2570954 100644 --- a/win/tclWinDde.c +++ b/win/tclWinDde.c @@ -314,8 +314,7 @@ DdeSetServerName( Tcl_DString dString; const WCHAR *actualName; Tcl_Obj *srvListPtr = NULL, **srvPtrPtr = NULL; - size_t n, srvCount = 0; - int lastSuffix, r = TCL_OK; + int n, srvCount = 0, lastSuffix, r = TCL_OK; ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); /* diff --git a/win/tclWinReg.c b/win/tclWinReg.c index 0d048ca..998521c 100644 --- a/win/tclWinReg.c +++ b/win/tclWinReg.c @@ -1318,7 +1318,7 @@ SetValue( (DWORD) type, (BYTE *) &value, sizeof(DWORD)); } else if (type == REG_MULTI_SZ) { Tcl_DString data, buf; - size_t objc, i; + int objc, i; Tcl_Obj **objv; if (Tcl_ListObjGetElements(interp, dataObj, &objc, &objv) != TCL_OK) { -- cgit v0.12 From cc66f3601ff68b38489ca84cb582dbbe3ea804ef Mon Sep 17 00:00:00 2001 From: bch Date: Fri, 28 Jan 2022 23:28:24 +0000 Subject: rejig argv/argc handling in response to investigation prompted by [https://arstechnica.com/information-technology/2022/01/a-bug-lurking-for- 12-years-gives-attackers-root-on-every-major-linux-distro/|this "polkit issue"] and some experimenting w/ execve() (ab)use. Essentially port of [0e1d2702ab] and its parent; discussed at length on IRC --- generic/tclMain.c | 26 +++++++++++++++++--------- 1 file changed, 17 insertions(+), 9 deletions(-) diff --git a/generic/tclMain.c b/generic/tclMain.c index bb48dbb..f1b1ae2 100644 --- a/generic/tclMain.c +++ b/generic/tclMain.c @@ -288,6 +288,8 @@ Tcl_MainEx( * but before starting to execute commands. */ Tcl_Interp *interp) { + char *progname = NULL; /* may/may-not be able to use argv[0] */ + int i=0; /* argv[i] index */ Tcl_Obj *path, *resultPtr, *argvPtr, *appName; const char *encodingName = NULL; int code, exitCode = 0; @@ -296,7 +298,14 @@ Tcl_MainEx( InteractiveState is; TclpSetInitialEncodings(); - TclpFindExecutable((const char *)argv[0]); + if (0 < argc) { + progname = argv[0]; + --argc; /* consume argv[0] */ + ++i; + } + TclpFindExecutable ((const char *)progname); /* nb: this could be NULL + * w/ (eg) a malformed + * execve() */ Tcl_InitMemory(interp); @@ -318,36 +327,35 @@ Tcl_MainEx( * FILENAME */ - if ((argc > 3) && (0 == _tcscmp(TEXT("-encoding"), argv[1])) + /* mind argc is being adjusted as we proceed */ + if ((argc >= 3) && (0 == _tcscmp(TEXT("-encoding"), argv[1])) && ('-' != argv[3][0])) { Tcl_Obj *value = NewNativeObj(argv[2]); Tcl_SetStartupScript(NewNativeObj(argv[3]), Tcl_GetString(value)); Tcl_DecrRefCount(value); argc -= 3; - argv += 3; - } else if ((argc > 1) && ('-' != argv[1][0])) { + i += 3; + } else if ((argc >= 1) && ('-' != argv[1][0])) { Tcl_SetStartupScript(NewNativeObj(argv[1]), NULL); argc--; - argv++; + i++; } } path = Tcl_GetStartupScript(&encodingName); if (path == NULL) { - appName = NewNativeObj(argv[0]); + appName = NewNativeObj(progname); } else { appName = path; } Tcl_SetVar2Ex(interp, "argv0", NULL, appName, TCL_GLOBAL_ONLY); - argc--; - argv++; Tcl_SetVar2Ex(interp, "argc", NULL, Tcl_NewWideIntObj(argc), TCL_GLOBAL_ONLY); argvPtr = Tcl_NewListObj(0, NULL); while (argc--) { - Tcl_ListObjAppendElement(NULL, argvPtr, NewNativeObj(*argv++)); + Tcl_ListObjAppendElement(NULL, argvPtr, NewNativeObj(argv[i++])); } Tcl_SetVar2Ex(interp, "argv", NULL, argvPtr, TCL_GLOBAL_ONLY); -- cgit v0.12 From 95bcc538075fc86ab77313a173e2c4ce89a38f0d Mon Sep 17 00:00:00 2001 From: bch Date: Fri, 28 Jan 2022 23:52:10 +0000 Subject: take advantage of what we know re: argv guarantees [https://www.iso-9899.info/n1570.html#5.1.2.2.1|argv spec] (per @cousteau on #tcl) --- generic/tclMain.c | 12 +++++------- 1 file changed, 5 insertions(+), 7 deletions(-) diff --git a/generic/tclMain.c b/generic/tclMain.c index f1b1ae2..be9ec4c 100644 --- a/generic/tclMain.c +++ b/generic/tclMain.c @@ -288,7 +288,6 @@ Tcl_MainEx( * but before starting to execute commands. */ Tcl_Interp *interp) { - char *progname = NULL; /* may/may-not be able to use argv[0] */ int i=0; /* argv[i] index */ Tcl_Obj *path, *resultPtr, *argvPtr, *appName; const char *encodingName = NULL; @@ -299,13 +298,12 @@ Tcl_MainEx( TclpSetInitialEncodings(); if (0 < argc) { - progname = argv[0]; - --argc; /* consume argv[0] */ + --argc; /* "consume" argv[0] */ ++i; } - TclpFindExecutable ((const char *)progname); /* nb: this could be NULL - * w/ (eg) a malformed - * execve() */ + TclpFindExecutable ((const char *)argv [0]); /* nb: this could be NULL + * w/ (eg) an empty argv + * supplied to execve() */ Tcl_InitMemory(interp); @@ -345,7 +343,7 @@ Tcl_MainEx( path = Tcl_GetStartupScript(&encodingName); if (path == NULL) { - appName = NewNativeObj(progname); + appName = NewNativeObj(argv[0]); } else { appName = path; } -- cgit v0.12 From 7fc2a5ab3094bee1c0945f828ab784d9d04af625 Mon Sep 17 00:00:00 2001 From: bch Date: Sat, 29 Jan 2022 00:13:14 +0000 Subject: take advantage of what we know re: argv guarantees [https://www.iso-9899.info/n1570.html#5.1.2.2.1|argv spec] (per @cousteau on #tcl) --- generic/tclMain.c | 10 ++++------ 1 file changed, 4 insertions(+), 6 deletions(-) diff --git a/generic/tclMain.c b/generic/tclMain.c index de745bd..a26577e 100644 --- a/generic/tclMain.c +++ b/generic/tclMain.c @@ -288,7 +288,6 @@ Tcl_MainEx( * but before starting to execute commands. */ Tcl_Interp *interp) { - char *progname = NULL; /* may/may-not be able to use argv[0] */ int i=0; /* argv[i] index */ Tcl_Obj *path, *resultPtr, *argvPtr, *appName; const char *encodingName = NULL; @@ -299,13 +298,12 @@ Tcl_MainEx( TclpSetInitialEncodings(); if (0 < argc) { - progname = argv[0]; --argc; /* consume argv[0] */ ++i; } - TclpFindExecutable ((const char *)progname); /* nb: this could be NULL - * w/ (eg) a malformed - * execve() */ + TclpFindExecutable ((const char *)argv [0]); /* nb: this could be NULL + * w/ (eg) an empty argv + * supplied to execve() */ Tcl_InitMemory(interp); @@ -345,7 +343,7 @@ Tcl_MainEx( path = Tcl_GetStartupScript(&encodingName); if (path == NULL) { - appName = NewNativeObj(progname); + appName = NewNativeObj(argv[0]); } else { appName = path; } -- cgit v0.12 From 3311ca7d306a1bf7de8e03bac9eac81d63677899 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 1 Feb 2022 12:03:54 +0000 Subject: Code cleanup in tclMain.c and tclAppInit.c: Make them Tcl-8.7-aware, usable as more generic examples for extensions. --- generic/tclMain.c | 21 +++++++++++---------- unix/tclAppInit.c | 15 +++++++++++---- win/tclAppInit.c | 26 +++++++++++++++++--------- 3 files changed, 39 insertions(+), 23 deletions(-) diff --git a/generic/tclMain.c b/generic/tclMain.c index f0b2682..30a206f 100644 --- a/generic/tclMain.c +++ b/generic/tclMain.c @@ -95,7 +95,7 @@ typedef enum { PROMPT_CONTINUE /* Print prompt for command continuation */ } PromptType; -typedef struct InteractiveState { +typedef struct { Tcl_Channel input; /* The standard input channel from which lines * are read. */ int tty; /* Non-zero means standard input is a @@ -229,7 +229,7 @@ Tcl_SourceRCFile( const char *fileName; Tcl_Channel chan; - fileName = Tcl_GetVar(interp, "tcl_rcFileName", TCL_GLOBAL_ONLY); + fileName = Tcl_GetVar2(interp, "tcl_rcFileName", NULL, TCL_GLOBAL_ONLY); if (fileName != NULL) { Tcl_Channel c; const char *fullName; @@ -515,7 +515,7 @@ Tcl_MainEx( * error messages troubles deeper in, so lop it back off. */ - Tcl_GetStringFromObj(is.commandPtr, &length); + (void)Tcl_GetStringFromObj(is.commandPtr, &length); Tcl_SetObjLength(is.commandPtr, --length); code = Tcl_RecordAndEvalObj(interp, is.commandPtr, TCL_EVAL_GLOBAL); @@ -532,7 +532,7 @@ Tcl_MainEx( } else if (is.tty) { resultPtr = Tcl_GetObjResult(interp); Tcl_IncrRefCount(resultPtr); - Tcl_GetStringFromObj(resultPtr, &length); + (void)Tcl_GetStringFromObj(resultPtr, &length); chan = Tcl_GetStdChannel(TCL_STDOUT); if ((length > 0) && chan) { Tcl_WriteObj(chan, resultPtr); @@ -745,17 +745,18 @@ TclFullFinalizationRequested(void) *---------------------------------------------------------------------- */ - /* ARGSUSED */ static void StdinProc( ClientData clientData, /* The state of interactive cmd line */ int mask) /* Not used. */ { - int code, length; - InteractiveState *isPtr = clientData; + int code; + int length; + InteractiveState *isPtr = (InteractiveState *)clientData; Tcl_Channel chan = isPtr->input; Tcl_Obj *commandPtr = isPtr->commandPtr; Tcl_Interp *interp = isPtr->interp; + (void)mask; if (Tcl_IsShared(commandPtr)) { Tcl_DecrRefCount(commandPtr); @@ -791,7 +792,7 @@ StdinProc( goto prompt; } isPtr->prompt = PROMPT_START; - Tcl_GetStringFromObj(commandPtr, &length); + (void)Tcl_GetStringFromObj(commandPtr, &length); Tcl_SetObjLength(commandPtr, --length); /* @@ -823,7 +824,7 @@ StdinProc( chan = Tcl_GetStdChannel(TCL_STDOUT); Tcl_IncrRefCount(resultPtr); - Tcl_GetStringFromObj(resultPtr, &length); + (void)Tcl_GetStringFromObj(resultPtr, &length); if ((length > 0) && (chan != NULL)) { Tcl_WriteObj(chan, resultPtr); Tcl_WriteChars(chan, "\n", 1); @@ -925,7 +926,7 @@ static void FreeMainInterp( ClientData clientData) { - Tcl_Interp *interp = clientData; + Tcl_Interp *interp = (Tcl_Interp *)clientData; /*if (TclInExit()) return;*/ diff --git a/unix/tclAppInit.c b/unix/tclAppInit.c index 9bbc88b..552f9e4 100644 --- a/unix/tclAppInit.c +++ b/unix/tclAppInit.c @@ -15,15 +15,19 @@ #undef BUILD_tcl #undef STATIC_BUILD #include "tcl.h" +#if TCL_MAJOR_VERSION < 9 && TCL_MINOR_VERSION < 7 +# define Tcl_LibraryInitProc Tcl_PackageInitProc +# define Tcl_StaticLibrary Tcl_StaticPackage +#endif #ifdef TCL_TEST -extern Tcl_PackageInitProc Tcltest_Init; -extern Tcl_PackageInitProc Tcltest_SafeInit; +extern Tcl_LibraryInitProc Tcltest_Init; +extern Tcl_LibraryInitProc Tcltest_SafeInit; #endif /* TCL_TEST */ #ifdef TCL_XT_TEST extern void XtToolkitInitialize(void); -extern Tcl_PackageInitProc Tclxttest_Init; +extern Tcl_LibraryInitProc Tclxttest_Init; #endif /* TCL_XT_TEST */ /* @@ -79,6 +83,9 @@ main( #ifdef TCL_LOCAL_MAIN_HOOK TCL_LOCAL_MAIN_HOOK(&argc, &argv); +#elif (TCL_MAJOR_VERSION > 8 || TCL_MINOR_VERSION > 6) && (!defined(_WIN32) || defined(UNICODE)) + /* New in Tcl 8.7. This doesn't work on Windows without UNICODE */ + TclZipfs_AppHook(&argc, &argv); #endif Tcl_Main(argc, argv, TCL_LOCAL_APPINIT); @@ -122,7 +129,7 @@ Tcl_AppInit( if (Tcltest_Init(interp) == TCL_ERROR) { return TCL_ERROR; } - Tcl_StaticPackage(interp, "Tcltest", Tcltest_Init, Tcltest_SafeInit); + Tcl_StaticLibrary(interp, "Tcltest", Tcltest_Init, Tcltest_SafeInit); #endif /* TCL_TEST */ /* diff --git a/win/tclAppInit.c b/win/tclAppInit.c index 695099e..058b92a 100644 --- a/win/tclAppInit.c +++ b/win/tclAppInit.c @@ -23,16 +23,20 @@ #include #include #include +#if TCL_MAJOR_VERSION < 9 && TCL_MINOR_VERSION < 7 +# define Tcl_LibraryInitProc Tcl_PackageInitProc +# define Tcl_StaticLibrary Tcl_StaticPackage +#endif #ifdef TCL_TEST -extern Tcl_PackageInitProc Tcltest_Init; -extern Tcl_PackageInitProc Tcltest_SafeInit; +extern Tcl_LibraryInitProc Tcltest_Init; +extern Tcl_LibraryInitProc Tcltest_SafeInit; #endif /* TCL_TEST */ #if defined(STATIC_BUILD) && defined(TCL_USE_STATIC_PACKAGES) && TCL_USE_STATIC_PACKAGES -extern Tcl_PackageInitProc Registry_Init; -extern Tcl_PackageInitProc Dde_Init; -extern Tcl_PackageInitProc Dde_SafeInit; +extern Tcl_LibraryInitProc Registry_Init; +extern Tcl_LibraryInitProc Dde_Init; +extern Tcl_LibraryInitProc Dde_SafeInit; #endif #if defined(__GNUC__) || defined(TCL_BROKEN_MAINARGS) @@ -87,7 +91,7 @@ MODULE_SCOPE int TCL_LOCAL_MAIN_HOOK(int *argc, TCHAR ***argv); int main( int argc, /* Number of command-line arguments. */ - char *dummy[]) /* Not used. */ + char **argv1) /* Not used. */ { TCHAR **argv; #else @@ -111,6 +115,7 @@ _tmain( * Get our args from the c-runtime. Ignore command line. */ + (void)argv1; setargv(&argc, &argv); #endif @@ -126,6 +131,9 @@ _tmain( #ifdef TCL_LOCAL_MAIN_HOOK TCL_LOCAL_MAIN_HOOK(&argc, &argv); +#elif (TCL_MAJOR_VERSION > 8 || TCL_MINOR_VERSION > 6) && (!defined(_WIN32) || defined(UNICODE)) + /* New in Tcl 8.7. This doesn't work on Windows without UNICODE */ + TclZipfs_AppHook(&argc, &argv); #endif Tcl_Main(argc, argv, TCL_LOCAL_APPINIT); @@ -163,19 +171,19 @@ Tcl_AppInit( if (Registry_Init(interp) == TCL_ERROR) { return TCL_ERROR; } - Tcl_StaticPackage(interp, "Registry", Registry_Init, NULL); + Tcl_StaticLibrary(interp, "Registry", Registry_Init, NULL); if (Dde_Init(interp) == TCL_ERROR) { return TCL_ERROR; } - Tcl_StaticPackage(interp, "Dde", Dde_Init, Dde_SafeInit); + Tcl_StaticLibrary(interp, "Dde", Dde_Init, Dde_SafeInit); #endif #ifdef TCL_TEST if (Tcltest_Init(interp) == TCL_ERROR) { return TCL_ERROR; } - Tcl_StaticPackage(interp, "Tcltest", Tcltest_Init, Tcltest_SafeInit); + Tcl_StaticLibrary(interp, "Tcltest", Tcltest_Init, Tcltest_SafeInit); #endif /* TCL_TEST */ /* -- cgit v0.12 From 7b1d345686119335c547557b1029df64b0d3c5c5 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 2 Feb 2022 16:42:18 +0000 Subject: Change DEFAULT_PRIMARY_PROMPT from #define to static const string (saves a strlen() call) --- generic/tclMain.c | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/generic/tclMain.c b/generic/tclMain.c index 30a206f..3f72838 100644 --- a/generic/tclMain.c +++ b/generic/tclMain.c @@ -28,7 +28,7 @@ * The default prompt used when the user has not overridden it. */ -#define DEFAULT_PRIMARY_PROMPT "% " +static const char DEFAULT_PRIMARY_PROMPT[] = "% "; /* * This file can be compiled on Windows in UNICODE mode, as well as on all @@ -887,7 +887,7 @@ Prompt( chan = Tcl_GetStdChannel(TCL_STDOUT); if (chan != NULL) { Tcl_WriteChars(chan, DEFAULT_PRIMARY_PROMPT, - strlen(DEFAULT_PRIMARY_PROMPT)); + sizeof(DEFAULT_PRIMARY_PROMPT) - 1); } } } else { -- cgit v0.12 From 99678d70f78441ead651c6b62e7af986648deaeb Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 3 Feb 2022 12:49:55 +0000 Subject: Fix Tcl_UtfToWChar() typedef --- generic/tclDecls.h | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/generic/tclDecls.h b/generic/tclDecls.h index 6ca7633..f1962b2 100644 --- a/generic/tclDecls.h +++ b/generic/tclDecls.h @@ -4269,8 +4269,8 @@ extern const TclStubs *tclStubsPtr; ? (wchar_t *(*)(const char *, int, Tcl_DString *))tclStubsPtr->tcl_UtfToUniCharDString \ : (wchar_t *(*)(const char *, int, Tcl_DString *))Tcl_UtfToChar16DString) # define Tcl_UtfToWChar (sizeof(wchar_t) != sizeof(short) \ - ? (int (*)(const char *, wchar_t *))tclStubsPtr->tcl_UtfToChar16 \ - : (int (*)(const char *, wchar_t *))Tcl_UtfToUniChar) + ? (int (*)(const char *, wchar_t *))tclStubsPtr->tcl_UtfToUniChar \ + : (int (*)(const char *, wchar_t *))Tcl_UtfToChar16) #else # define Tcl_WCharToUtfDString (sizeof(wchar_t) != sizeof(short) \ ? (char *(*)(const wchar_t *, int, Tcl_DString *))Tcl_UniCharToUtfDString \ @@ -4279,8 +4279,8 @@ extern const TclStubs *tclStubsPtr; ? (wchar_t *(*)(const char *, int, Tcl_DString *))Tcl_UtfToUniCharDString \ : (wchar_t *(*)(const char *, int, Tcl_DString *))Tcl_UtfToChar16DString) # define Tcl_UtfToWChar (sizeof(wchar_t) != sizeof(short) \ - ? (int (*)(const char *, wchar_t *))Tcl_UtfToChar16 \ - : (int (*)(const char *, wchar_t *))Tcl_UtfToUniChar) + ? (int (*)(const char *, wchar_t *))Tcl_UtfToUniChar \ + : (int (*)(const char *, wchar_t *))Tcl_UtfToChar16) #endif /* -- cgit v0.12 From 62f5155cc809b84cc59bc06780d309edaa2b59f0 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 3 Feb 2022 13:13:06 +0000 Subject: TIP #617: Tcl_WCharLen/Tcl_Char16Len --- doc/Utf.3 | 16 +++++++++++++++- generic/tcl.decls | 10 ++++++++-- generic/tclDecls.h | 43 ++++++++++++++++++++++++++++++++++++++----- generic/tclStubInit.c | 10 +++++++++- generic/tclUtf.c | 33 ++++++++++++++++++++++++++++++++- 5 files changed, 102 insertions(+), 10 deletions(-) diff --git a/doc/Utf.3 b/doc/Utf.3 index f1aca4c..b0c7f64 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_UtfToChar16, Tcl_UtfToWChar, Tcl_UniCharToUtfDString, Tcl_UtfToUniCharDString, Tcl_Char16ToUtfDString, Tcl_UtfToWCharDString, Tcl_UtfToChar16DString, 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 +Tcl_UniChar, Tcl_UniCharToUtf, Tcl_UtfToUniChar, Tcl_UtfToChar16, Tcl_UtfToWChar, Tcl_UniCharToUtfDString, Tcl_UtfToUniCharDString, Tcl_Char16ToUtfDString, Tcl_UtfToWCharDString, Tcl_UtfToChar16DString, Tcl_WCharLen, Tcl_Char16Len, 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 @@ -46,6 +46,12 @@ wchar_t * \fBTcl_UtfToWCharDString\fR(\fIsrc, length, dsPtr\fR) .sp int +\fBTcl_Char16Len\fR(\fIuniStr\fR) +.sp +int +\fBTcl_WCharLen\fR(\fIuniStr\fR) +.sp +int \fBTcl_UniCharLen\fR(\fIuniStr\fR) .sp int @@ -198,6 +204,14 @@ representation of the UTF-8 string. Storage for the return value is appended to the end of the \fBTcl_DString\fR. The Unicode string is terminated with a Unicode null character. .PP +\fBTcl_Char16Len\fR corresponds to \fBstrlen\fR for UTF-16 +characters. It accepts a null-terminated Unicode string and returns +the number of Unicode characters (not bytes) in that string. +.PP +\fBTcl_WCharLen\fR corresponds to \fBstrlen\fR for wchar_t +characters. It accepts a null-terminated Unicode string and returns +the number of Unicode characters (not bytes) in that string. +.PP \fBTcl_UniCharLen\fR corresponds to \fBstrlen\fR for Unicode characters. It accepts a null-terminated Unicode string and returns the number of Unicode characters (not bytes) in that string. diff --git a/generic/tcl.decls b/generic/tcl.decls index bd9800a..38dbe5a 100644 --- a/generic/tcl.decls +++ b/generic/tcl.decls @@ -1244,8 +1244,8 @@ declare 350 { declare 351 { int Tcl_UniCharIsWordChar(int ch) } -declare 352 {deprecated {Use Tcl_GetCharLength}} { - int Tcl_UniCharLen(const Tcl_UniChar *uniStr) +declare 352 { + int Tcl_Char16Len(const unsigned short *uniStr) } declare 353 {deprecated {Use Tcl_UtfNcmp}} { int Tcl_UniCharNcmp(const Tcl_UniChar *ucs, const Tcl_UniChar *uct, @@ -2442,6 +2442,12 @@ declare 660 { int Tcl_AsyncMarkFromSignal(Tcl_AsyncHandler async, int sigNumber) } +# TIP #617 +declare 668 { + int Tcl_UniCharLen(const int *uniStr) +} + + # ----- BASELINE -- FOR -- 8.7.0 ----- # ############################################################################## diff --git a/generic/tclDecls.h b/generic/tclDecls.h index f1962b2..6400029 100644 --- a/generic/tclDecls.h +++ b/generic/tclDecls.h @@ -1063,8 +1063,7 @@ EXTERN int Tcl_UniCharIsUpper(int ch); /* 351 */ EXTERN int Tcl_UniCharIsWordChar(int ch); /* 352 */ -TCL_DEPRECATED("Use Tcl_GetCharLength") -int Tcl_UniCharLen(const Tcl_UniChar *uniStr); +EXTERN int Tcl_Char16Len(const unsigned short *uniStr); /* 353 */ TCL_DEPRECATED("Use Tcl_UtfNcmp") int Tcl_UniCharNcmp(const Tcl_UniChar *ucs, @@ -1948,6 +1947,15 @@ EXTERN int Tcl_UniCharIsUnicode(int ch); /* 660 */ EXTERN int Tcl_AsyncMarkFromSignal(Tcl_AsyncHandler async, int sigNumber); +/* Slot 661 is reserved */ +/* Slot 662 is reserved */ +/* Slot 663 is reserved */ +/* Slot 664 is reserved */ +/* Slot 665 is reserved */ +/* Slot 666 is reserved */ +/* Slot 667 is reserved */ +/* 668 */ +EXTERN int Tcl_UniCharLen(const int *uniStr); typedef struct { const struct TclPlatStubs *tclPlatStubs; @@ -2335,7 +2343,7 @@ typedef struct TclStubs { int (*tcl_UniCharIsSpace) (int ch); /* 349 */ int (*tcl_UniCharIsUpper) (int ch); /* 350 */ int (*tcl_UniCharIsWordChar) (int ch); /* 351 */ - TCL_DEPRECATED_API("Use Tcl_GetCharLength") int (*tcl_UniCharLen) (const Tcl_UniChar *uniStr); /* 352 */ + int (*tcl_Char16Len) (const unsigned short *uniStr); /* 352 */ TCL_DEPRECATED_API("Use Tcl_UtfNcmp") int (*tcl_UniCharNcmp) (const Tcl_UniChar *ucs, const Tcl_UniChar *uct, unsigned long numChars); /* 353 */ char * (*tcl_Char16ToUtfDString) (const unsigned short *uniStr, int uniLength, Tcl_DString *dsPtr); /* 354 */ unsigned short * (*tcl_UtfToChar16DString) (const char *src, int length, Tcl_DString *dsPtr); /* 355 */ @@ -2644,6 +2652,14 @@ typedef struct TclStubs { void (*reserved658)(void); void (*reserved659)(void); int (*tcl_AsyncMarkFromSignal) (Tcl_AsyncHandler async, int sigNumber); /* 660 */ + void (*reserved661)(void); + void (*reserved662)(void); + void (*reserved663)(void); + void (*reserved664)(void); + void (*reserved665)(void); + void (*reserved666)(void); + void (*reserved667)(void); + int (*tcl_UniCharLen) (const int *uniStr); /* 668 */ } TclStubs; extern const TclStubs *tclStubsPtr; @@ -3378,8 +3394,8 @@ extern const TclStubs *tclStubsPtr; (tclStubsPtr->tcl_UniCharIsUpper) /* 350 */ #define Tcl_UniCharIsWordChar \ (tclStubsPtr->tcl_UniCharIsWordChar) /* 351 */ -#define Tcl_UniCharLen \ - (tclStubsPtr->tcl_UniCharLen) /* 352 */ +#define Tcl_Char16Len \ + (tclStubsPtr->tcl_Char16Len) /* 352 */ #define Tcl_UniCharNcmp \ (tclStubsPtr->tcl_UniCharNcmp) /* 353 */ #define Tcl_Char16ToUtfDString \ @@ -3994,6 +4010,15 @@ extern const TclStubs *tclStubsPtr; /* Slot 659 is reserved */ #define Tcl_AsyncMarkFromSignal \ (tclStubsPtr->tcl_AsyncMarkFromSignal) /* 660 */ +/* Slot 661 is reserved */ +/* Slot 662 is reserved */ +/* Slot 663 is reserved */ +/* Slot 664 is reserved */ +/* Slot 665 is reserved */ +/* Slot 666 is reserved */ +/* Slot 667 is reserved */ +#define Tcl_UniCharLen \ + (tclStubsPtr->tcl_UniCharLen) /* 668 */ #endif /* defined(USE_TCL_STUBS) */ @@ -4260,6 +4285,8 @@ extern const TclStubs *tclStubsPtr; # define Tcl_UtfToUniCharDString Tcl_UtfToChar16DString # undef Tcl_UtfToUniChar # define Tcl_UtfToUniChar Tcl_UtfToChar16 +# undef Tcl_UniCharLen +# define Tcl_UniCharLen Tcl_Char16Len #endif #if defined(USE_TCL_STUBS) # define Tcl_WCharToUtfDString (sizeof(wchar_t) != sizeof(short) \ @@ -4271,6 +4298,9 @@ extern const TclStubs *tclStubsPtr; # define Tcl_UtfToWChar (sizeof(wchar_t) != sizeof(short) \ ? (int (*)(const char *, wchar_t *))tclStubsPtr->tcl_UtfToUniChar \ : (int (*)(const char *, wchar_t *))Tcl_UtfToChar16) +# define Tcl_WCharLen (sizeof(wchar_t) != sizeof(short) \ + ? (int (*)(wchar_t *))tclStubsPtr->tcl_UniCharLen \ + : (int (*)(wchar_t *))Tcl_Char16Len) #else # define Tcl_WCharToUtfDString (sizeof(wchar_t) != sizeof(short) \ ? (char *(*)(const wchar_t *, int, Tcl_DString *))Tcl_UniCharToUtfDString \ @@ -4281,6 +4311,9 @@ extern const TclStubs *tclStubsPtr; # define Tcl_UtfToWChar (sizeof(wchar_t) != sizeof(short) \ ? (int (*)(const char *, wchar_t *))Tcl_UtfToUniChar \ : (int (*)(const char *, wchar_t *))Tcl_UtfToChar16) +# define Tcl_WCharLen (sizeof(wchar_t) != sizeof(short) \ + ? (int (*)(wchar_t *))Tcl_UniCharLen \ + : (int (*)(wchar_t *))Tcl_Char16Len) #endif /* diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c index a1878c1..6374ab5 100644 --- a/generic/tclStubInit.c +++ b/generic/tclStubInit.c @@ -1635,7 +1635,7 @@ const TclStubs tclStubs = { Tcl_UniCharIsSpace, /* 349 */ Tcl_UniCharIsUpper, /* 350 */ Tcl_UniCharIsWordChar, /* 351 */ - Tcl_UniCharLen, /* 352 */ + Tcl_Char16Len, /* 352 */ Tcl_UniCharNcmp, /* 353 */ Tcl_Char16ToUtfDString, /* 354 */ Tcl_UtfToChar16DString, /* 355 */ @@ -1944,6 +1944,14 @@ const TclStubs tclStubs = { 0, /* 658 */ 0, /* 659 */ Tcl_AsyncMarkFromSignal, /* 660 */ + 0, /* 661 */ + 0, /* 662 */ + 0, /* 663 */ + 0, /* 664 */ + 0, /* 665 */ + 0, /* 666 */ + 0, /* 667 */ + Tcl_UniCharLen, /* 668 */ }; /* !END!: Do not edit above this line. */ diff --git a/generic/tclUtf.c b/generic/tclUtf.c index fcdf80a..fae6edd 100644 --- a/generic/tclUtf.c +++ b/generic/tclUtf.c @@ -1773,6 +1773,36 @@ Tcl_UniCharToTitle( /* *---------------------------------------------------------------------- * + * Tcl_Char16Len -- + * + * Find the length of a UniChar string. The str input must be null + * terminated. + * + * Results: + * Returns the length of str in UniChars (not bytes). + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_Char16Len( + const unsigned short *uniStr) /* Unicode string to find length of. */ +{ + int len = 0; + + while (*uniStr != '\0') { + len++; + uniStr++; + } + return len; +} + +/* + *---------------------------------------------------------------------- + * * Tcl_UniCharLen -- * * Find the length of a UniChar string. The str input must be null @@ -1787,9 +1817,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; -- cgit v0.12 From 8be8b508867864add7ba4793c6b856384ef8b873 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 4 Feb 2022 16:19:25 +0000 Subject: See [https://github.com/tcltk/tcl/pull/10] --- generic/tclTest.c | 6 +++--- tests/env.test | 4 +++- win/configure | 12 ++++++++++-- win/rules.vc | 9 +++++++++ win/tcl.m4 | 9 ++++++++- win/tclWin32Dll.c | 6 +++--- 6 files changed, 36 insertions(+), 10 deletions(-) diff --git a/generic/tclTest.c b/generic/tclTest.c index 8d22edf..9c94f91 100644 --- a/generic/tclTest.c +++ b/generic/tclTest.c @@ -326,7 +326,7 @@ static Tcl_NRPostProc NREUnwind_callback; static Tcl_ObjCmdProc TestNREUnwind; static Tcl_ObjCmdProc TestNRELevels; static Tcl_ObjCmdProc TestInterpResolverCmd; -#if defined(HAVE_CPUID) || defined(_WIN32) +#if defined(HAVE_CPUID) static Tcl_ObjCmdProc TestcpuidCmd; #endif @@ -600,7 +600,7 @@ Tcltest_Init( NULL, NULL); Tcl_CreateCommand(interp, "testexitmainloop", TestexitmainloopCmd, NULL, NULL); -#if defined(HAVE_CPUID) || defined(_WIN32) +#if defined(HAVE_CPUID) Tcl_CreateObjCommand(interp, "testcpuid", TestcpuidCmd, NULL, NULL); #endif @@ -6955,7 +6955,7 @@ TestFindLastCmd( return TCL_OK; } -#if defined(HAVE_CPUID) || defined(_WIN32) +#if defined(HAVE_CPUID) /* *---------------------------------------------------------------------- * diff --git a/tests/env.test b/tests/env.test index e4e209f..905cdab 100644 --- a/tests/env.test +++ b/tests/env.test @@ -102,7 +102,9 @@ variable keep { SHLIB_PATH SYSTEMDRIVE SYSTEMROOT DYLD_LIBRARY_PATH DYLD_FRAMEWORK_PATH DYLD_NEW_LOCAL_SHARED_REGIONS DYLD_NO_FIX_PREBINDING MSYSTEM __CF_USER_TEXT_ENCODING SECURITYSESSIONID LANG WINDIR TERM - CommonProgramFiles ProgramFiles CommonProgramW6432 ProgramW6432 + CommonProgramFiles CommonProgramFiles(x86) ProgramFiles + ProgramFiles(x86) CommonProgramW6432 ProgramW6432 + WINECONFIGDIR WINEDATADIR WINEDLLDIR0 WINEHOMEDIR PROCESSOR_ARCHITECTURE } variable printenvScript [makeFile [string map [list @keep@ [list $keep]] { diff --git a/win/configure b/win/configure index b4eeb4f..8abb3d3 100755 --- a/win/configure +++ b/win/configure @@ -3763,10 +3763,15 @@ echo "$as_me: error: ${CC} does not support the -shared option. echo "$as_me:$LINENO: result: Using 64-bit $MACHINE mode" >&5 echo "${ECHO_T} Using 64-bit $MACHINE mode" >&6 ;; + arm64) + MACHINE="ARM64" + echo "$as_me:$LINENO: result: Using ARM64 $MACHINE mode" >&5 +echo "${ECHO_T} Using ARM64 $MACHINE mode" >&6 + ;; ia64) MACHINE="IA64" - echo "$as_me:$LINENO: result: Using 64-bit $MACHINE mode" >&5 -echo "${ECHO_T} Using 64-bit $MACHINE mode" >&6 + echo "$as_me:$LINENO: result: Using IA64 $MACHINE mode" >&5 +echo "${ECHO_T} Using IA64 $MACHINE mode" >&6 ;; *) cat >conftest.$ac_ext <<_ACEOF @@ -3863,6 +3868,9 @@ echo "${ECHO_T}using shared flags" >&6 amd64|x64|yes) MACHINE="AMD64" ; # assume AMD64 as default 64-bit build ;; + arm64) + MACHINE="ARM64" + ;; ia64) MACHINE="IA64" ;; diff --git a/win/rules.vc b/win/rules.vc index 8a91b58..37723c8 100644 --- a/win/rules.vc +++ b/win/rules.vc @@ -435,6 +435,8 @@ VCVER=0 && ![echo ARCH=IX86 >> vercl.x] \ && ![echo $(_HASH)elif defined(_M_AMD64) >> vercl.x] \ && ![echo ARCH=AMD64 >> vercl.x] \ + && ![echo $(_HASH)elif defined(_M_ARM64) >> vercl.x] \ + && ![echo ARCH=ARM64 >> vercl.x] \ && ![echo $(_HASH)endif >> vercl.x] \ && ![$(cc32) -nologo -TC -P vercl.x 2>NUL] !include vercl.i @@ -490,6 +492,8 @@ MULTIPLATFORM_INSTALL = 0 !if ![reg query HKLM\Hardware\Description\System\CentralProcessor\0 /v Identifier | findstr /i x86] NATIVE_ARCH=IX86 +!if ![reg query HKLM\Hardware\Description\System\CentralProcessor\0 /v Identifier | findstr /i ARM | findstr /i 64-bit] +NATIVE_ARCH=ARM64 !else NATIVE_ARCH=AMD64 !endif @@ -1476,6 +1480,11 @@ carch = /D_ARM_WINAPI_PARTITION_DESKTOP_SDK_AVAILABLE carch = !endif +# cpuid is only available on intel machines +!if "$(MACHINE)" == "IX86" || "$(MACHINE)" == "AMD64" +carch = $(carch) /DHAVE_CPUID=1 +!endif + !if $(DEBUG) # Turn warnings into errors cwarn = $(cwarn) -WX diff --git a/win/tcl.m4 b/win/tcl.m4 index 00cd4d2..e2117d2 100644 --- a/win/tcl.m4 +++ b/win/tcl.m4 @@ -783,9 +783,13 @@ AC_DEFUN([SC_CONFIG_CFLAGS], [ MACHINE="AMD64" ; # assume AMD64 as default 64-bit build AC_MSG_RESULT([ Using 64-bit $MACHINE mode]) ;; + arm64) + MACHINE="ARM64" + AC_MSG_RESULT([ Using ARM64 $MACHINE mode]) + ;; ia64) MACHINE="IA64" - AC_MSG_RESULT([ Using 64-bit $MACHINE mode]) + AC_MSG_RESULT([ Using IA64 $MACHINE mode]) ;; *) AC_COMPILE_IFELSE([AC_LANG_PROGRAM([[ @@ -837,6 +841,9 @@ AC_DEFUN([SC_CONFIG_CFLAGS], [ amd64|x64|yes) MACHINE="AMD64" ; # assume AMD64 as default 64-bit build ;; + arm64) + MACHINE="ARM64" + ;; ia64) MACHINE="IA64" ;; diff --git a/win/tclWin32Dll.c b/win/tclWin32Dll.c index 9061dd0..8620a08 100644 --- a/win/tclWin32Dll.c +++ b/win/tclWin32Dll.c @@ -661,12 +661,12 @@ TclWinCPUID( { int status = TCL_ERROR; -#if defined(HAVE_INTRIN_H) && defined(_WIN64) +#if defined(HAVE_INTRIN_H) && defined(_WIN64) && defined(HAVE_CPUID) __cpuid((int *)regsPtr, index); status = TCL_OK; -#elif defined(__GNUC__) +#elif defined(__GNUC__) && defined(HAVE_CPUID) # if defined(_WIN64) /* * Execute the CPUID instruction with the given index, and store results @@ -782,7 +782,7 @@ TclWinCPUID( status = registration.status; # endif /* !_WIN64 */ -#elif defined(_MSC_VER) +#elif defined(_MSC_VER) && defined(HAVE_CPUID) # if defined(_WIN64) __cpuid(regsPtr, index); -- cgit v0.12 From 8f8b424c15d02d04e3289418b601c7443c1c6f27 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Sun, 6 Feb 2022 12:47:54 +0000 Subject: another try, rules.vc version 1.10 --- win/rules.vc | 13 +++++++++---- 1 file changed, 9 insertions(+), 4 deletions(-) diff --git a/win/rules.vc b/win/rules.vc index 37723c8..2f01de0 100644 --- a/win/rules.vc +++ b/win/rules.vc @@ -24,7 +24,7 @@ _RULES_VC = 1 # For modifications that are not backward-compatible, you *must* change # the major version. RULES_VERSION_MAJOR = 1 -RULES_VERSION_MINOR = 9 +RULES_VERSION_MINOR = 10 # The PROJECT macro must be defined by parent makefile. !if "$(PROJECT)" == "" @@ -411,8 +411,8 @@ _INSTALLDIR=$(_INSTALLDIR)\lib # compiler version 1200. This is kept only for legacy reasons as it # does not make sense for recent Microsoft compilers. Only used for # output directory names. -# ARCH - set to IX86 or AMD64 depending on 32- or 64-bit target -# NATIVE_ARCH - set to IX86 or AMD64 for the host machine +# ARCH - set to IX86, ARM64 or AMD64 depending on 32- or 64-bit target +# NATIVE_ARCH - set to IX86, ARM64 or AMD64 for the host machine # MACHINE - same as $(ARCH) - legacy # _VC_MANIFEST_EMBED_{DLL,EXE} - commands for embedding a manifest if needed @@ -461,6 +461,9 @@ VCVER = $(VCVERSION) !if "$(MACHINE)" == "x86" !undef MACHINE MACHINE = IX86 +!elseif "$(MACHINE)" == "arm64" +!undef MACHINE +MACHINE = ARM64 !elseif "$(MACHINE)" == "x64" !undef MACHINE MACHINE = AMD64 @@ -477,6 +480,8 @@ MACHINE=$(ARCH) # the Tcl platform::identify command !if "$(MACHINE)" == "AMD64" PLATFORM_IDENTIFY = win32-x86_64 +!elseif "$(MACHINE)" == "ARM64" +PLATFORM_IDENTIFY = win32-arm !else PLATFORM_IDENTIFY = win32-ix86 !endif @@ -492,7 +497,7 @@ MULTIPLATFORM_INSTALL = 0 !if ![reg query HKLM\Hardware\Description\System\CentralProcessor\0 /v Identifier | findstr /i x86] NATIVE_ARCH=IX86 -!if ![reg query HKLM\Hardware\Description\System\CentralProcessor\0 /v Identifier | findstr /i ARM | findstr /i 64-bit] +!elseif ![reg query HKLM\Hardware\Description\System\CentralProcessor\0 /v Identifier | findstr /i ARM | findstr /i 64-bit] NATIVE_ARCH=ARM64 !else NATIVE_ARCH=AMD64 -- cgit v0.12 From f48af06d664b9d4f48755833e764c916ec561f68 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 7 Feb 2022 14:42:11 +0000 Subject: Fix [bae42b3d24]: [d86e92fb33] et.al. eliminates cpuid when cross compiling for win32 --- win/configure | 14 ++++++++++++-- win/configure.in | 2 +- win/makefile.vc | 4 ++-- win/tcl.m4 | 12 +++++++++++- 4 files changed, 26 insertions(+), 6 deletions(-) diff --git a/win/configure b/win/configure index 8abb3d3..1701b6f 100755 --- a/win/configure +++ b/win/configure @@ -3279,7 +3279,7 @@ fi SHLIB_SUFFIX=".dll" # MACHINE is IX86 for LINK, but this is used by the manifest, - # which requires x86|amd64|ia64. + # which requires x86|amd64|arm64|ia64. MACHINE="X86" if test "$GCC" = "yes"; then @@ -3352,6 +3352,13 @@ echo "${ECHO_T}$ac_cv_cross" >&6 RANLIB="x86_64-w64-mingw32-ranlib" RC="x86_64-w64-mingw32-windres" ;; + arm64) + CC="arm64-w64-mingw32-${CC}" + LD="arm64-w64-mingw32-ld" + AR="arm64-w64-mingw32-ar" + RANLIB="arm64-w64-mingw32-ranlib" + RC="arm64-w64-mingw32-windres" + ;; *) CC="i686-w64-mingw32-${CC}" LD="i686-w64-mingw32-ld" @@ -3470,6 +3477,9 @@ echo "${ECHO_T}$ac_cv_win32" >&6 echo "$as_me: error: ${CC} cannot produce win32 executables." >&2;} { (exit 1); exit 1; }; } fi + if test "$MACHINE" != "ARM64"; then + extra_cflags="$extra_cflags -DHAVE_CPUID=1" + fi hold_cflags=$CFLAGS; CFLAGS="$CFLAGS -mwindows -municode -Dmain=xxmain" echo "$as_me:$LINENO: checking for working -municode linker flag" >&5 @@ -5277,7 +5287,7 @@ case "$TCL_PATCH_LEVEL" in esac TCL_WIN_VERSION="$TCL_VERSION.$TCL_RELEASE_LEVEL.`echo $TCL_PATCH_LEVEL | tr -d ab.`" -# X86|AMD64|IA64 for manifest +# X86|AMD64|ARM64|IA64 for manifest diff --git a/win/configure.in b/win/configure.in index 0aa3224..45ee1fb 100644 --- a/win/configure.in +++ b/win/configure.in @@ -375,7 +375,7 @@ case "$TCL_PATCH_LEVEL" in esac TCL_WIN_VERSION="$TCL_VERSION.$TCL_RELEASE_LEVEL.`echo $TCL_PATCH_LEVEL | tr -d ab.`" AC_SUBST(TCL_WIN_VERSION) -# X86|AMD64|IA64 for manifest +# X86|AMD64|ARM64|IA64 for manifest AC_SUBST(MACHINE) AC_SUBST(TCL_VERSION) diff --git a/win/makefile.vc b/win/makefile.vc index 22e0267..08ffc31 100644 --- a/win/makefile.vc +++ b/win/makefile.vc @@ -97,7 +97,7 @@ # nodep = Turns off compatibility macros to ensure the core # isn't being built with deprecated functions. # -# MACHINE=(ALPHA|AMD64|IA64|IX86) +# MACHINE=(ALPHA|AMD64|ARM64|IA64|IX86) # Set the machine type used for the compiler, linker, and # resource compiler. This hook is needed to tell the tools # when alternate platforms are requested. IX86 is the default @@ -520,7 +520,7 @@ $(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 +!elseif "$(MACHINE)" == "IX86" $(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 diff --git a/win/tcl.m4 b/win/tcl.m4 index e2117d2..ad0cf4f 100644 --- a/win/tcl.m4 +++ b/win/tcl.m4 @@ -557,7 +557,7 @@ AC_DEFUN([SC_CONFIG_CFLAGS], [ SHLIB_SUFFIX=".dll" # MACHINE is IX86 for LINK, but this is used by the manifest, - # which requires x86|amd64|ia64. + # which requires x86|amd64|arm64|ia64. MACHINE="X86" if test "$GCC" = "yes"; then @@ -582,6 +582,13 @@ AC_DEFUN([SC_CONFIG_CFLAGS], [ RANLIB="x86_64-w64-mingw32-ranlib" RC="x86_64-w64-mingw32-windres" ;; + arm64) + CC="arm64-w64-mingw32-${CC}" + LD="arm64-w64-mingw32-ld" + AR="arm64-w64-mingw32-ar" + RANLIB="arm64-w64-mingw32-ranlib" + RC="arm64-w64-mingw32-windres" + ;; *) CC="i686-w64-mingw32-${CC}" LD="i686-w64-mingw32-ld" @@ -642,6 +649,9 @@ AC_DEFUN([SC_CONFIG_CFLAGS], [ if test "$ac_cv_win32" != "yes"; then AC_MSG_ERROR([${CC} cannot produce win32 executables.]) fi + if test "$MACHINE" != "ARM64"; then + extra_cflags="$extra_cflags -DHAVE_CPUID=1" + fi hold_cflags=$CFLAGS; CFLAGS="$CFLAGS -mwindows -municode -Dmain=xxmain" AC_CACHE_CHECK(for working -municode linker flag, -- cgit v0.12 From 962d2a813067833151a5269899a50a865cd39e91 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 7 Feb 2022 15:35:09 +0000 Subject: Fix [1fe745559a]: 8.7, 9.0: Conditional jump or move depends on uninitialised value in Tcl_UniCharToUtf --- generic/tclUtil.c | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/generic/tclUtil.c b/generic/tclUtil.c index e29afcc..01548ae 100644 --- a/generic/tclUtil.c +++ b/generic/tclUtil.c @@ -802,9 +802,11 @@ TclCopyAndCollapse( char c = *src; if (c == '\\') { + char buf[4] = ""; int numRead; - int backslashCount = TclParseBackslash(src, count, &numRead, dst); + int backslashCount = TclParseBackslash(src, count, &numRead, &buf); + memcpy(dst, buf, backslashCount); dst += backslashCount; newCount += backslashCount; src += numRead; -- cgit v0.12 From 2b26997c85f274c792552385b6a36b8614a3662c Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 8 Feb 2022 10:54:45 +0000 Subject: More changed for windows-arm (e.g. add zdll.lib for ARM64, although zlib1.dll still missing) --- compat/zlib/win64-arm/zdll.lib | Bin 0 -> 16732 bytes win/Makefile.in | 6 +++++- win/configure | 29 ++++++++++++++++++++++++----- win/configure.in | 14 +++++++++++--- win/makefile.vc | 15 ++++++++++----- win/tcl.m4 | 3 +-- 6 files changed, 51 insertions(+), 16 deletions(-) create mode 100755 compat/zlib/win64-arm/zdll.lib diff --git a/compat/zlib/win64-arm/zdll.lib b/compat/zlib/win64-arm/zdll.lib new file mode 100755 index 0000000..a1b6c50 Binary files /dev/null and b/compat/zlib/win64-arm/zdll.lib differ diff --git a/win/Makefile.in b/win/Makefile.in index 71b40cd..0c83fd6 100644 --- a/win/Makefile.in +++ b/win/Makefile.in @@ -517,7 +517,11 @@ ${TEST_EXE_FILE}: ${TCL_STUB_LIB_FILE} ${TCLTEST_OBJS} tclTestMain.${OBJEXT} # use pre-built zlib1.dll ${ZLIB_DLL_FILE}: ${TCL_STUB_LIB_FILE} - @if test "@ZLIB_LIBS@set" != "${ZLIB_DIR_NATIVE}/win32/zdll.libset" ; then \ + @if test "@ZLIB_LIBS@set" = "${ZLIB_DIR_NATIVE}/win64-arm/zdll.libset" ; then \ + $(COPY) $(ZLIB_DIR)/win64-arm/${ZLIB_DLL_FILE} ${ZLIB_DLL_FILE}; \ + elif test "@ZLIB_LIBS@set" = "${ZLIB_DIR_NATIVE}/win64-arm/libz.dll.aset" ; then \ + $(COPY) $(ZLIB_DIR)/win64-arm/${ZLIB_DLL_FILE} ${ZLIB_DLL_FILE}; \ + elif test "@ZLIB_LIBS@set" = "${ZLIB_DIR_NATIVE}/win32/zdll.libset" ; then \ $(COPY) $(ZLIB_DIR)/win64/${ZLIB_DLL_FILE} ${ZLIB_DLL_FILE}; \ else \ $(COPY) $(ZLIB_DIR)/win32/${ZLIB_DLL_FILE} ${ZLIB_DLL_FILE}; \ diff --git a/win/configure b/win/configure index 1701b6f..7b1ec92 100755 --- a/win/configure +++ b/win/configure @@ -3902,8 +3902,7 @@ echo "${ECHO_T} Using 64-bit $MACHINE mode" >&6 if test "$do64bit" != "no" ; then RC="rc" CFLAGS_DEBUG="-nologo -Zi -Od ${runtime}d" - # Do not use -O2 for Win64 - this has proved buggy in code gen. - CFLAGS_OPTIMIZE="-nologo -O1 ${runtime}" + CFLAGS_OPTIMIZE="-nologo -O2 ${runtime}" lflags="${lflags} -nologo -MACHINE:${MACHINE}" LINKBIN="link" # Avoid 'unresolved external symbol __security_cookie' errors. @@ -4396,14 +4395,34 @@ if test "$tcl_ok" = "yes"; then if test "$do64bit" != "no"; then - if test "$GCC" == "yes"; then + if test "$do64bit" = "arm64"; then + + if test "$GCC" == "yes"; then + + ZLIB_LIBS=\${ZLIB_DIR_NATIVE}/win64-arm/libz.dll.a - ZLIB_LIBS=\${ZLIB_DIR_NATIVE}/win64/libz.dll.a + +else + + ZLIB_LIBS=\${ZLIB_DIR_NATIVE}/win64-arm/zdll.lib + + +fi else - ZLIB_LIBS=\${ZLIB_DIR_NATIVE}/win64/zdll.lib + if test "$GCC" == "yes"; then + + ZLIB_LIBS=\${ZLIB_DIR_NATIVE}/win64/libz.dll.a + + +else + + ZLIB_LIBS=\${ZLIB_DIR_NATIVE}/win64/zdll.lib + + +fi fi diff --git a/win/configure.in b/win/configure.in index 45ee1fb..1f52c52 100644 --- a/win/configure.in +++ b/win/configure.in @@ -144,10 +144,18 @@ AS_IF([test "${enable_shared+set}" = "set"], [ AS_IF([test "$tcl_ok" = "yes"], [ AC_SUBST(ZLIB_DLL_FILE,[\${ZLIB_DLL_FILE}]) AS_IF([test "$do64bit" != "no"], [ - AS_IF([test "$GCC" == "yes"],[ - AC_SUBST(ZLIB_LIBS,[\${ZLIB_DIR_NATIVE}/win64/libz.dll.a]) + AS_IF([test "$do64bit" = "arm64"], [ + AS_IF([test "$GCC" == "yes"],[ + AC_SUBST(ZLIB_LIBS,[\${ZLIB_DIR_NATIVE}/win64-arm/libz.dll.a]) + ], [ + AC_SUBST(ZLIB_LIBS,[\${ZLIB_DIR_NATIVE}/win64-arm/zdll.lib]) + ]) ], [ - AC_SUBST(ZLIB_LIBS,[\${ZLIB_DIR_NATIVE}/win64/zdll.lib]) + AS_IF([test "$GCC" == "yes"],[ + AC_SUBST(ZLIB_LIBS,[\${ZLIB_DIR_NATIVE}/win64/libz.dll.a]) + ], [ + AC_SUBST(ZLIB_LIBS,[\${ZLIB_DIR_NATIVE}/win64/zdll.lib]) + ]) ]) ], [ AC_SUBST(ZLIB_LIBS,[\${ZLIB_DIR_NATIVE}/win32/zdll.lib]) diff --git a/win/makefile.vc b/win/makefile.vc index 08ffc31..a4de4c2 100644 --- a/win/makefile.vc +++ b/win/makefile.vc @@ -515,16 +515,21 @@ $(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 +!if "$(MACHINE)" == "ARM64" +$(OUT_DIR)\zlib1.dll: $(COMPATDIR)\zlib\win64-arm\zlib1.dll + $(COPY) $(COMPATDIR)\zlib\win64-arm\zlib1.dll $(OUT_DIR)\zlib1.dll +$(OUT_DIR)\zdll.lib: $(COMPATDIR)\zlib\win64-arm\zdll.lib + $(COPY) $(COMPATDIR)\zlib\win64-arm\zdll.lib $(OUT_DIR)\zdll.lib !elseif "$(MACHINE)" == "IX86" $(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 +!else +$(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 !endif pkgs: diff --git a/win/tcl.m4 b/win/tcl.m4 index ad0cf4f..f36f263 100644 --- a/win/tcl.m4 +++ b/win/tcl.m4 @@ -874,8 +874,7 @@ AC_DEFUN([SC_CONFIG_CFLAGS], [ if test "$do64bit" != "no" ; then RC="rc" CFLAGS_DEBUG="-nologo -Zi -Od ${runtime}d" - # Do not use -O2 for Win64 - this has proved buggy in code gen. - CFLAGS_OPTIMIZE="-nologo -O1 ${runtime}" + CFLAGS_OPTIMIZE="-nologo -O2 ${runtime}" lflags="${lflags} -nologo -MACHINE:${MACHINE}" LINKBIN="link" # Avoid 'unresolved external symbol __security_cookie' errors. -- cgit v0.12 From d6d9d92060423c36c4badb814b2d88be198bf4ed Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 8 Feb 2022 14:23:39 +0000 Subject: Correct previous commit (Windows build error) --- generic/tclUtil.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/generic/tclUtil.c b/generic/tclUtil.c index 01548ae..2f31960 100644 --- a/generic/tclUtil.c +++ b/generic/tclUtil.c @@ -804,7 +804,7 @@ TclCopyAndCollapse( if (c == '\\') { char buf[4] = ""; int numRead; - int backslashCount = TclParseBackslash(src, count, &numRead, &buf); + int backslashCount = TclParseBackslash(src, count, &numRead, buf); memcpy(dst, buf, backslashCount); dst += backslashCount; -- cgit v0.12 From 4e39a8e0b828039a94b8014caea48a24a4938349 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 8 Feb 2022 15:07:28 +0000 Subject: Accept aarch64 too (in stead of arm64) --- win/configure | 22 +++++++++++----------- win/tcl.m4 | 26 +++++++++++++------------- 2 files changed, 24 insertions(+), 24 deletions(-) diff --git a/win/configure b/win/configure index 7b1ec92..f815682 100755 --- a/win/configure +++ b/win/configure @@ -3352,12 +3352,12 @@ echo "${ECHO_T}$ac_cv_cross" >&6 RANLIB="x86_64-w64-mingw32-ranlib" RC="x86_64-w64-mingw32-windres" ;; - arm64) - CC="arm64-w64-mingw32-${CC}" - LD="arm64-w64-mingw32-ld" - AR="arm64-w64-mingw32-ar" - RANLIB="arm64-w64-mingw32-ranlib" - RC="arm64-w64-mingw32-windres" + arm64|aarch64) + CC="aarch64-w64-mingw32-${CC}" + LD="aarch64-w64-mingw32-ld" + AR="aarch64-w64-mingw32-ar" + RANLIB="aarch64-w64-mingw32-ranlib" + RC="aarch64-w64-mingw32-windres" ;; *) CC="i686-w64-mingw32-${CC}" @@ -3773,7 +3773,7 @@ echo "$as_me: error: ${CC} does not support the -shared option. echo "$as_me:$LINENO: result: Using 64-bit $MACHINE mode" >&5 echo "${ECHO_T} Using 64-bit $MACHINE mode" >&6 ;; - arm64) + arm64|aarch64) MACHINE="ARM64" echo "$as_me:$LINENO: result: Using ARM64 $MACHINE mode" >&5 echo "${ECHO_T} Using ARM64 $MACHINE mode" >&6 @@ -3835,9 +3835,9 @@ tcl_win_64bit=no fi rm -f conftest.err conftest.$ac_objext conftest.$ac_ext if test "$tcl_win_64bit" = "yes" ; then - do64bit=amd64 - MACHINE="AMD64" - echo "$as_me:$LINENO: result: Using 64-bit $MACHINE mode" >&5 + do64bit=amd64 + MACHINE="AMD64" + echo "$as_me:$LINENO: result: Using 64-bit $MACHINE mode" >&5 echo "${ECHO_T} Using 64-bit $MACHINE mode" >&6 fi ;; @@ -3878,7 +3878,7 @@ echo "${ECHO_T}using shared flags" >&6 amd64|x64|yes) MACHINE="AMD64" ; # assume AMD64 as default 64-bit build ;; - arm64) + arm64|aarch64) MACHINE="ARM64" ;; ia64) diff --git a/win/tcl.m4 b/win/tcl.m4 index f36f263..26702b6 100644 --- a/win/tcl.m4 +++ b/win/tcl.m4 @@ -30,7 +30,7 @@ AC_DEFUN([SC_PATH_TCLCONFIG], [ AC_ARG_WITH(tcl, AS_HELP_STRING([--with-tcl], [directory containing tcl configuration (tclConfig.sh)]), - with_tclconfig="${withval}") + [with_tclconfig="${withval}"]) AC_MSG_CHECKING([for Tcl configuration]) AC_CACHE_VAL(ac_cv_c_tclconfig,[ @@ -148,7 +148,7 @@ AC_DEFUN([SC_PATH_TKCONFIG], [ AC_ARG_WITH(tk, AS_HELP_STRING([--with-tk], [directory containing tk configuration (tkConfig.sh)]), - with_tkconfig="${withval}") + [with_tkconfig="${withval}"]) AC_MSG_CHECKING([for Tk configuration]) AC_CACHE_VAL(ac_cv_c_tkconfig,[ @@ -582,12 +582,12 @@ AC_DEFUN([SC_CONFIG_CFLAGS], [ RANLIB="x86_64-w64-mingw32-ranlib" RC="x86_64-w64-mingw32-windres" ;; - arm64) - CC="arm64-w64-mingw32-${CC}" - LD="arm64-w64-mingw32-ld" - AR="arm64-w64-mingw32-ar" - RANLIB="arm64-w64-mingw32-ranlib" - RC="arm64-w64-mingw32-windres" + arm64|aarch64) + CC="aarch64-w64-mingw32-${CC}" + LD="aarch64-w64-mingw32-ld" + AR="aarch64-w64-mingw32-ar" + RANLIB="aarch64-w64-mingw32-ranlib" + RC="aarch64-w64-mingw32-windres" ;; *) CC="i686-w64-mingw32-${CC}" @@ -793,7 +793,7 @@ AC_DEFUN([SC_CONFIG_CFLAGS], [ MACHINE="AMD64" ; # assume AMD64 as default 64-bit build AC_MSG_RESULT([ Using 64-bit $MACHINE mode]) ;; - arm64) + arm64|aarch64) MACHINE="ARM64" AC_MSG_RESULT([ Using ARM64 $MACHINE mode]) ;; @@ -811,9 +811,9 @@ AC_DEFUN([SC_CONFIG_CFLAGS], [ [tcl_win_64bit=no] ) if test "$tcl_win_64bit" = "yes" ; then - do64bit=amd64 - MACHINE="AMD64" - AC_MSG_RESULT([ Using 64-bit $MACHINE mode]) + do64bit=amd64 + MACHINE="AMD64" + AC_MSG_RESULT([ Using 64-bit $MACHINE mode]) fi ;; esac @@ -851,7 +851,7 @@ AC_DEFUN([SC_CONFIG_CFLAGS], [ amd64|x64|yes) MACHINE="AMD64" ; # assume AMD64 as default 64-bit build ;; - arm64) + arm64|aarch64) MACHINE="ARM64" ;; ia64) -- cgit v0.12 From f608eb10d475301aedbbf0d6a0addbd50dea0e34 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 9 Feb 2022 22:09:07 +0000 Subject: Put back '@' (lost in previous commit) --- win/Makefile.in | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/win/Makefile.in b/win/Makefile.in index 08d4db4..ed2ee68 100644 --- a/win/Makefile.in +++ b/win/Makefile.in @@ -517,7 +517,7 @@ ${TEST_EXE_FILE}: ${TCL_STUB_LIB_FILE} ${TCLTEST_OBJS} tclTestMain.${OBJEXT} # use pre-built zlib1.dll ${ZLIB_DLL_FILE}: ${TCL_STUB_LIB_FILE} - if test "@ZLIB_LIBS@set" = "${ZLIB_DIR_NATIVE}/win64-arm/zdll.libset" ; then \ + @if test "@ZLIB_LIBS@set" = "${ZLIB_DIR_NATIVE}/win64-arm/zdll.libset" ; then \ $(COPY) $(ZLIB_DIR)/win64-arm/${ZLIB_DLL_FILE} ${ZLIB_DLL_FILE}; \ elif test "@ZLIB_LIBS@set" = "${ZLIB_DIR_NATIVE}/win64-arm/libz.dll.aset" ; then \ $(COPY) $(ZLIB_DIR)/win64-arm/${ZLIB_DLL_FILE} ${ZLIB_DLL_FILE}; \ -- cgit v0.12 From 58aa27c456e8787c6b178a0c68265201b6803c74 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 10 Feb 2022 08:34:43 +0000 Subject: Tcl_ListObjLength -> TclListObjLength --- generic/tclBasic.c | 2 +- generic/tclCmdIL.c | 14 +++++++------- generic/tclCmdMZ.c | 12 ++++++------ generic/tclCompCmds.c | 4 ++-- generic/tclCompCmdsSZ.c | 8 ++++---- generic/tclDisassemble.c | 2 +- generic/tclEncoding.c | 8 ++++---- generic/tclEnsemble.c | 22 +++++++++++----------- generic/tclExecute.c | 12 ++++++------ generic/tclFCmd.c | 2 +- generic/tclFileName.c | 14 +++++++------- generic/tclIOGT.c | 2 +- generic/tclIOUtil.c | 8 ++++---- generic/tclIndexObj.c | 4 ++-- generic/tclInterp.c | 2 +- generic/tclListObj.c | 2 +- generic/tclNamesp.c | 6 +++--- generic/tclOOMethod.c | 8 ++++---- generic/tclObj.c | 2 +- generic/tclPathObj.c | 2 +- generic/tclProc.c | 2 +- generic/tclResult.c | 6 +++--- generic/tclStrToD.c | 2 +- generic/tclStringObj.c | 2 +- generic/tclStubInit.c | 2 +- generic/tclTrace.c | 4 ++-- generic/tclUtil.c | 2 +- generic/tclVar.c | 6 +++--- generic/tclZlib.c | 8 ++++---- 29 files changed, 85 insertions(+), 85 deletions(-) diff --git a/generic/tclBasic.c b/generic/tclBasic.c index cbf613b..08933a3 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -5222,7 +5222,7 @@ TclEvalEx( if (tokenPtr->type == TCL_TOKEN_EXPAND_WORD) { size_t numElements; - code = Tcl_ListObjLength(interp, objv[objectsUsed], + code = TclListObjLength(interp, objv[objectsUsed], &numElements); if (code == TCL_ERROR) { /* diff --git a/generic/tclCmdIL.c b/generic/tclCmdIL.c index d43c0f3..9dead6b 100644 --- a/generic/tclCmdIL.c +++ b/generic/tclCmdIL.c @@ -2406,7 +2406,7 @@ Tcl_LinsertObjCmd( return TCL_ERROR; } - result = Tcl_ListObjLength(interp, objv[1], &len); + result = TclListObjLength(interp, objv[1], &len); if (result != TCL_OK) { return result; } @@ -2525,7 +2525,7 @@ Tcl_LlengthObjCmd( return TCL_ERROR; } - result = Tcl_ListObjLength(interp, objv[1], &listLen); + result = TclListObjLength(interp, objv[1], &listLen); if (result != TCL_OK) { return result; } @@ -2674,7 +2674,7 @@ Tcl_LrangeObjCmd( return TCL_ERROR; } - result = Tcl_ListObjLength(interp, objv[1], &listLen); + result = TclListObjLength(interp, objv[1], &listLen); if (result != TCL_OK) { return result; } @@ -2748,7 +2748,7 @@ Tcl_LremoveObjCmd( } listObj = objv[1]; - if (Tcl_ListObjLength(interp, listObj, &listLen) != TCL_OK) { + if (TclListObjLength(interp, listObj, &listLen) != TCL_OK) { return TCL_ERROR; } @@ -2972,7 +2972,7 @@ Tcl_LreplaceObjCmd( return TCL_ERROR; } - result = Tcl_ListObjLength(interp, objv[1], &listLen); + result = TclListObjLength(interp, objv[1], &listLen); if (result != TCL_OK) { return result; } @@ -4651,7 +4651,7 @@ SortCompare( * Replace them and evaluate the result. */ - Tcl_ListObjLength(infoPtr->interp, infoPtr->compareCmdPtr, &objc); + TclListObjLength(infoPtr->interp, infoPtr->compareCmdPtr, &objc); Tcl_ListObjReplace(infoPtr->interp, infoPtr->compareCmdPtr, objc - 2, 2, 2, paramObjv); Tcl_ListObjGetElements(infoPtr->interp, infoPtr->compareCmdPtr, @@ -4865,7 +4865,7 @@ SelectObjFromSublist( int index; Tcl_Obj *currentObj; - if (Tcl_ListObjLength(infoPtr->interp, objPtr, &listLen) != TCL_OK) { + if (TclListObjLength(infoPtr->interp, objPtr, &listLen) != TCL_OK) { infoPtr->resultCode = TCL_ERROR; return NULL; } diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c index 3d2cda3..2554f0a 100644 --- a/generic/tclCmdMZ.c +++ b/generic/tclCmdMZ.c @@ -675,7 +675,7 @@ Tcl_RegsubObjCmd( * object. (If they aren't, that's cheap to do.) */ - if (Tcl_ListObjLength(interp, objv[2], &numParts) != TCL_OK) { + if (TclListObjLength(interp, objv[2], &numParts) != TCL_OK) { return TCL_ERROR; } if (numParts < 1) { @@ -1813,7 +1813,7 @@ StringIsCmd( * well-formed lists. */ - if (TCL_OK == Tcl_ListObjLength(NULL, objPtr, &length3)) { + if (TCL_OK == TclListObjLength(NULL, objPtr, &length3)) { break; } @@ -3966,7 +3966,7 @@ Tcl_ThrowObjCmd( * The type must be a list of at least length 1. */ - if (Tcl_ListObjLength(interp, objv[1], &len) != TCL_OK) { + if (TclListObjLength(interp, objv[1], &len) != TCL_OK) { return TCL_ERROR; } else if (len < 1) { Tcl_SetObjResult(interp, Tcl_NewStringObj( @@ -4755,7 +4755,7 @@ TclNRTryObjCmd( return TCL_ERROR; } code = 1; - if (Tcl_ListObjLength(NULL, objv[i+1], &dummy) != TCL_OK) { + if (TclListObjLength(NULL, objv[i+1], &dummy) != TCL_OK) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "bad prefix '%s': must be a list", TclGetString(objv[i+1]))); @@ -4767,7 +4767,7 @@ TclNRTryObjCmd( info[2] = objv[i+1]; commonHandler: - if (Tcl_ListObjLength(interp, objv[i+2], &dummy) != TCL_OK) { + if (TclListObjLength(interp, objv[i+2], &dummy) != TCL_OK) { Tcl_DecrRefCount(handlersObj); return TCL_ERROR; } @@ -4984,7 +4984,7 @@ TryPostBody( Tcl_ResetResult(interp); result = TCL_ERROR; - Tcl_ListObjLength(NULL, info[3], &numElems); + TclListObjLength(NULL, info[3], &numElems); if (numElems> 0) { Tcl_Obj *varName; diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c index c7da104..0130da8 100644 --- a/generic/tclCompCmds.c +++ b/generic/tclCompCmds.c @@ -302,7 +302,7 @@ TclCompileArraySetCmd( TclNewObj(literalObj); isDataLiteral = TclWordKnownAtCompileTime(dataTokenPtr, literalObj); isDataValid = (isDataLiteral - && Tcl_ListObjLength(NULL, literalObj, &len) == TCL_OK); + && TclListObjLength(NULL, literalObj, &len) == TCL_OK); isDataEven = (isDataValid && (len & 1) == 0); /* @@ -2755,7 +2755,7 @@ CompileEachloopCmd( */ if (!TclWordKnownAtCompileTime(tokenPtr, varListObj) || - TCL_OK != Tcl_ListObjLength(NULL, varListObj, &numVars) || + TCL_OK != TclListObjLength(NULL, varListObj, &numVars) || numVars == 0) { code = TCL_ERROR; goto done; diff --git a/generic/tclCompCmdsSZ.c b/generic/tclCompCmdsSZ.c index 4d9e0dc..9092367 100644 --- a/generic/tclCompCmdsSZ.c +++ b/generic/tclCompCmdsSZ.c @@ -2735,7 +2735,7 @@ TclCompileThrowCmd( CompileWord(envPtr, msgToken, interp, 2); codeIsList = codeKnown && (TCL_OK == - Tcl_ListObjLength(interp, objPtr, &len)); + TclListObjLength(interp, objPtr, &len)); codeIsValid = codeIsList && (len != 0); if (codeIsValid) { @@ -2868,7 +2868,7 @@ TclCompileTryCmd( TclNewObj(tmpObj); Tcl_IncrRefCount(tmpObj); if (!TclWordKnownAtCompileTime(tokenPtr, tmpObj) - || Tcl_ListObjLength(NULL, tmpObj, &objc) != TCL_OK + || TclListObjLength(NULL, tmpObj, &objc) != TCL_OK || (objc == 0)) { TclDecrRefCount(tmpObj); goto failedToCompile; @@ -3123,7 +3123,7 @@ IssueTryClausesInstructions( JUMP4( JUMP_FALSE, notCodeJumpSource); if (matchClauses[i]) { const char *p; - Tcl_ListObjLength(NULL, matchClauses[i], &len); + TclListObjLength(NULL, matchClauses[i], &len); /* * Match the errorcode according to try/trap rules. @@ -3335,7 +3335,7 @@ IssueTryClausesFinallyInstructions( OP( EQ); JUMP4( JUMP_FALSE, notCodeJumpSource); if (matchClauses[i]) { - Tcl_ListObjLength(NULL, matchClauses[i], &len); + TclListObjLength(NULL, matchClauses[i], &len); /* * Match the errorcode according to try/trap rules. diff --git a/generic/tclDisassemble.c b/generic/tclDisassemble.c index b056381..9d30b09 100644 --- a/generic/tclDisassemble.c +++ b/generic/tclDisassemble.c @@ -763,7 +763,7 @@ TclGetInnerContext( * Reset while keeping the list internalrep as much as possible. */ - Tcl_ListObjLength(interp, result, &len); + TclListObjLength(interp, result, &len); Tcl_ListObjReplace(interp, result, 0, len, 0, NULL); } Tcl_ListObjAppendElement(NULL, result, TclNewInstNameObj(*pc)); diff --git a/generic/tclEncoding.c b/generic/tclEncoding.c index bab6376..64cf48d 100644 --- a/generic/tclEncoding.c +++ b/generic/tclEncoding.c @@ -370,7 +370,7 @@ Tcl_SetEncodingSearchPath( { size_t dummy; - if (TCL_ERROR == Tcl_ListObjLength(NULL, searchPath, &dummy)) { + if (TCL_ERROR == TclListObjLength(NULL, searchPath, &dummy)) { return TCL_ERROR; } TclSetProcessGlobalValue(&encodingSearchPath, searchPath, NULL); @@ -417,7 +417,7 @@ TclSetLibraryPath( { size_t dummy; - if (TCL_ERROR == Tcl_ListObjLength(NULL, path, &dummy)) { + if (TCL_ERROR == TclListObjLength(NULL, path, &dummy)) { return; } TclSetProcessGlobalValue(&libraryPath, path, NULL); @@ -456,7 +456,7 @@ FillEncodingFileMap(void) searchPath = Tcl_GetEncodingSearchPath(); Tcl_IncrRefCount(searchPath); - Tcl_ListObjLength(NULL, searchPath, &numDirs); + TclListObjLength(NULL, searchPath, &numDirs); map = Tcl_NewDictObj(); Tcl_IncrRefCount(map); @@ -3851,7 +3851,7 @@ InitializeEncodingSearchPath( Tcl_IncrRefCount(searchPathObj); libPathObj = TclGetLibraryPath(); Tcl_IncrRefCount(libPathObj); - Tcl_ListObjLength(NULL, libPathObj, &numDirs); + TclListObjLength(NULL, libPathObj, &numDirs); for (i = 0; i < numDirs; i++) { Tcl_Obj *directoryObj, *pathObj; diff --git a/generic/tclEnsemble.c b/generic/tclEnsemble.c index cbb8119..b91a758 100644 --- a/generic/tclEnsemble.c +++ b/generic/tclEnsemble.c @@ -233,7 +233,7 @@ TclNamespaceEnsembleCmd( cxtPtr = nsPtr; continue; case CRT_SUBCMDS: - if (Tcl_ListObjLength(interp, objv[1], &len) != TCL_OK) { + if (TclListObjLength(interp, objv[1], &len) != TCL_OK) { if (allocatedMapFlag) { Tcl_DecrRefCount(mapObj); } @@ -242,7 +242,7 @@ TclNamespaceEnsembleCmd( subcmdObj = (len > 0 ? objv[1] : NULL); continue; case CRT_PARAM: - if (Tcl_ListObjLength(interp, objv[1], &len) != TCL_OK) { + if (TclListObjLength(interp, objv[1], &len) != TCL_OK) { if (allocatedMapFlag) { Tcl_DecrRefCount(mapObj); } @@ -337,7 +337,7 @@ TclNamespaceEnsembleCmd( } continue; case CRT_UNKNOWN: - if (Tcl_ListObjLength(interp, objv[1], &len) != TCL_OK) { + if (TclListObjLength(interp, objv[1], &len) != TCL_OK) { if (allocatedMapFlag) { Tcl_DecrRefCount(mapObj); } @@ -533,13 +533,13 @@ TclNamespaceEnsembleCmd( } switch ((enum EnsConfigOpts) index) { case CONF_SUBCMDS: - if (Tcl_ListObjLength(interp, objv[1], &len) != TCL_OK) { + if (TclListObjLength(interp, objv[1], &len) != TCL_OK) { goto freeMapAndError; } subcmdObj = (len > 0 ? objv[1] : NULL); continue; case CONF_PARAM: - if (Tcl_ListObjLength(interp, objv[1], &len) != TCL_OK) { + if (TclListObjLength(interp, objv[1], &len) != TCL_OK) { goto freeMapAndError; } paramObj = (len > 0 ? objv[1] : NULL); @@ -623,7 +623,7 @@ TclNamespaceEnsembleCmd( } continue; case CONF_UNKNOWN: - if (Tcl_ListObjLength(interp, objv[1], &len) != TCL_OK) { + if (TclListObjLength(interp, objv[1], &len) != TCL_OK) { goto freeMapAndError; } unknownObj = (len > 0 ? objv[1] : NULL); @@ -792,7 +792,7 @@ Tcl_SetEnsembleSubcommandList( if (subcmdList != NULL) { size_t length; - if (Tcl_ListObjLength(interp, subcmdList, &length) != TCL_OK) { + if (TclListObjLength(interp, subcmdList, &length) != TCL_OK) { return TCL_ERROR; } if (length < 1) { @@ -868,7 +868,7 @@ Tcl_SetEnsembleParameterList( if (paramList == NULL) { length = 0; } else { - if (Tcl_ListObjLength(interp, paramList, &length) != TCL_OK) { + if (TclListObjLength(interp, paramList, &length) != TCL_OK) { return TCL_ERROR; } if (length < 1) { @@ -1044,7 +1044,7 @@ Tcl_SetEnsembleUnknownHandler( if (unknownList != NULL) { size_t length; - if (Tcl_ListObjLength(interp, unknownList, &length) != TCL_OK) { + if (TclListObjLength(interp, unknownList, &length) != TCL_OK) { return TCL_ERROR; } if (length < 1) { @@ -1888,7 +1888,7 @@ NsEnsembleImplementationCmdNR( Tcl_Obj **copyObjv; size_t copyObjc, prefixObjc; - Tcl_ListObjLength(NULL, prefixObj, &prefixObjc); + TclListObjLength(NULL, prefixObj, &prefixObjc); if (objc == 2) { copyPtr = TclListObjCopy(NULL, prefixObj); @@ -2335,7 +2335,7 @@ EnsembleUnknownCallback( /* A non-empty list is the replacement command. */ - if (Tcl_ListObjLength(interp, *prefixObjPtr, &prefixObjc) != TCL_OK) { + if (TclListObjLength(interp, *prefixObjPtr, &prefixObjc) != TCL_OK) { TclDecrRefCount(*prefixObjPtr); Tcl_AddErrorInfo(interp, "\n while parsing result of " "ensemble unknown subcommand handler"); diff --git a/generic/tclExecute.c b/generic/tclExecute.c index 80044a4..a36dc44 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -3363,7 +3363,7 @@ TEBCresume( lappendListDirect: objResultPtr = varPtr->value.objPtr; - if (Tcl_ListObjLength(interp, objResultPtr, &len) != TCL_OK) { + if (TclListObjLength(interp, objResultPtr, &len) != TCL_OK) { TRACE_ERROR(interp); goto gotError; } @@ -3422,7 +3422,7 @@ TEBCresume( if (!objResultPtr) { valueToAssign = valuePtr; - } else if (Tcl_ListObjLength(interp, objResultPtr, &len)!=TCL_OK) { + } else if (TclListObjLength(interp, objResultPtr, &len)!=TCL_OK) { TRACE_ERROR(interp); goto gotError; } else { @@ -4638,7 +4638,7 @@ TEBCresume( case INST_LIST_LENGTH: TRACE(("\"%.30s\" => ", O2S(OBJ_AT_TOS))); - if (Tcl_ListObjLength(interp, OBJ_AT_TOS, &length) != TCL_OK) { + if (TclListObjLength(interp, OBJ_AT_TOS, &length) != TCL_OK) { TRACE_ERROR(interp); goto gotError; } @@ -4839,7 +4839,7 @@ TEBCresume( * in the process. */ - if (Tcl_ListObjLength(interp, valuePtr, &objc) != TCL_OK) { + if (TclListObjLength(interp, valuePtr, &objc) != TCL_OK) { TRACE_ERROR(interp); goto gotError; } @@ -4904,7 +4904,7 @@ TEBCresume( s1 = Tcl_GetStringFromObj(valuePtr, &s1len); TRACE(("\"%.30s\" \"%.30s\" => ", O2S(valuePtr), O2S(value2Ptr))); - if (Tcl_ListObjLength(interp, value2Ptr, &length) != TCL_OK) { + if (TclListObjLength(interp, value2Ptr, &length) != TCL_OK) { TRACE_ERROR(interp); goto gotError; } @@ -6245,7 +6245,7 @@ TEBCresume( varListPtr = infoPtr->varLists[i]; numVars = varListPtr->numVars; listPtr = OBJ_AT_DEPTH(listTmpDepth); - if (Tcl_ListObjLength(interp, listPtr, &listLen) != TCL_OK) { + if (TclListObjLength(interp, listPtr, &listLen) != TCL_OK) { TRACE_APPEND(("ERROR converting list %ld, \"%s\": %s", i, O2S(listPtr), O2S(Tcl_GetObjResult(interp)))); goto gotError; diff --git a/generic/tclFCmd.c b/generic/tclFCmd.c index 821347a..183b88a 100644 --- a/generic/tclFCmd.c +++ b/generic/tclFCmd.c @@ -1007,7 +1007,7 @@ TclFileAttrsCmd( * Use objStrings as a list object. */ - if (Tcl_ListObjLength(interp, objStrings, &numObjStrings) != TCL_OK) { + if (TclListObjLength(interp, objStrings, &numObjStrings) != TCL_OK) { goto end; } attributeStringsAllocated = (const char **) diff --git a/generic/tclFileName.c b/generic/tclFileName.c index fd86209..2f10a01 100644 --- a/generic/tclFileName.c +++ b/generic/tclFileName.c @@ -516,7 +516,7 @@ TclpNativeSplitPath( */ if (lenPtr != NULL) { - Tcl_ListObjLength(NULL, resultPtr, lenPtr); + TclListObjLength(NULL, resultPtr, lenPtr); } return resultPtr; } @@ -1333,7 +1333,7 @@ Tcl_GlobObjCmd( return TCL_ERROR; } typePtr = objv[i+1]; - if (Tcl_ListObjLength(interp, typePtr, &length) != TCL_OK) { + if (TclListObjLength(interp, typePtr, &length) != TCL_OK) { return TCL_ERROR; } i++; @@ -1455,7 +1455,7 @@ Tcl_GlobObjCmd( * platform. */ - Tcl_ListObjLength(interp, typePtr, &length); + TclListObjLength(interp, typePtr, &length); if (length == 0) { goto skipTypes; } @@ -1526,7 +1526,7 @@ Tcl_GlobObjCmd( Tcl_Obj *item; size_t llen; - if ((Tcl_ListObjLength(NULL, look, &llen) == TCL_OK) + if ((TclListObjLength(NULL, look, &llen) == TCL_OK) && (llen == 3)) { Tcl_ListObjIndex(interp, look, 0, &item); if (!strcmp("macintosh", TclGetString(item))) { @@ -1633,7 +1633,7 @@ Tcl_GlobObjCmd( } if ((globFlags & TCL_GLOBMODE_NO_COMPLAIN) == 0) { - if (Tcl_ListObjLength(interp, Tcl_GetObjResult(interp), + if (TclListObjLength(interp, Tcl_GetObjResult(interp), &length) != TCL_OK) { /* * This should never happen. Maybe we should be more dramatic. @@ -2351,7 +2351,7 @@ DoGlob( Tcl_Obj *copy = NULL; if (pathPtr == NULL && TclGetString(subdirv[i])[0] == '~') { - Tcl_ListObjLength(NULL, matchesObj, &repair); + TclListObjLength(NULL, matchesObj, &repair); copy = subdirv[i]; subdirv[i] = Tcl_NewStringObj("./", 2); Tcl_AppendObjToObj(subdirv[i], copy); @@ -2364,7 +2364,7 @@ DoGlob( Tcl_DecrRefCount(subdirv[i]); subdirv[i] = copy; - Tcl_ListObjLength(NULL, matchesObj, &end); + TclListObjLength(NULL, matchesObj, &end); while (repair + 1 <= end) { const char *bytes; size_t numBytes; diff --git a/generic/tclIOGT.c b/generic/tclIOGT.c index a755959..3091467 100644 --- a/generic/tclIOGT.c +++ b/generic/tclIOGT.c @@ -266,7 +266,7 @@ TclChannelTransform( return TCL_ERROR; } - if (TCL_OK != Tcl_ListObjLength(interp, cmdObjPtr, &objc)) { + if (TCL_OK != TclListObjLength(interp, cmdObjPtr, &objc)) { Tcl_SetObjResult(interp, Tcl_NewStringObj("-command value is not a list", -1)); return TCL_ERROR; diff --git a/generic/tclIOUtil.c b/generic/tclIOUtil.c index 32a96ef..f4a7089 100644 --- a/generic/tclIOUtil.c +++ b/generic/tclIOUtil.c @@ -1114,10 +1114,10 @@ FsAddMountsToGlobResult( return; } - if (Tcl_ListObjLength(NULL, mounts, &mLength) != TCL_OK || mLength == 0) { + if (TclListObjLength(NULL, mounts, &mLength) != TCL_OK || mLength == 0) { goto endOfMounts; } - if (Tcl_ListObjLength(NULL, resultPtr, &gLength) != TCL_OK) { + if (TclListObjLength(NULL, resultPtr, &gLength) != TCL_OK) { goto endOfMounts; } for (i=0 ; ifsPtr->listVolumesProc(); if (thisFsVolumes != NULL) { - if (Tcl_ListObjLength(NULL, thisFsVolumes, &numVolumes) + if (TclListObjLength(NULL, thisFsVolumes, &numVolumes) != TCL_OK) { /* * This is VERY bad; the listVolumesProc didn't return a diff --git a/generic/tclIndexObj.c b/generic/tclIndexObj.c index 442aae2..1099fc2 100644 --- a/generic/tclIndexObj.c +++ b/generic/tclIndexObj.c @@ -523,7 +523,7 @@ PrefixMatchObjCmd( return TCL_ERROR; } i++; - result = Tcl_ListObjLength(interp, objv[i], &errorLength); + result = TclListObjLength(interp, objv[i], &errorLength); if (result != TCL_OK) { return TCL_ERROR; } @@ -547,7 +547,7 @@ PrefixMatchObjCmd( * error case regardless of level. */ - result = Tcl_ListObjLength(interp, tablePtr, &dummyLength); + result = TclListObjLength(interp, tablePtr, &dummyLength); if (result != TCL_OK) { return result; } diff --git a/generic/tclInterp.c b/generic/tclInterp.c index 8458915..3aecb25 100644 --- a/generic/tclInterp.c +++ b/generic/tclInterp.c @@ -2380,7 +2380,7 @@ ChildBgerror( if (objc) { size_t length; - if (TCL_ERROR == Tcl_ListObjLength(NULL, objv[0], &length) + if (TCL_ERROR == TclListObjLength(NULL, objv[0], &length) || (length < 1)) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "cmdPrefix must be list of length >= 1", -1)); diff --git a/generic/tclListObj.c b/generic/tclListObj.c index 3f32447..a70ad46 100644 --- a/generic/tclListObj.c +++ b/generic/tclListObj.c @@ -1677,7 +1677,7 @@ TclLsetFlat( */ len = TCL_INDEX_NONE; - Tcl_ListObjLength(NULL, subListPtr, &len); + TclListObjLength(NULL, subListPtr, &len); if (valuePtr == NULL) { Tcl_ListObjReplace(NULL, subListPtr, index, 1, 0, NULL); } else if (index == (size_t)len) { diff --git a/generic/tclNamesp.c b/generic/tclNamesp.c index 53c5769..fd43f5b 100644 --- a/generic/tclNamesp.c +++ b/generic/tclNamesp.c @@ -4436,7 +4436,7 @@ Tcl_SetNamespaceUnknownHandler( */ if (handlerPtr != NULL) { - if (Tcl_ListObjLength(interp, handlerPtr, &lstlen) != TCL_OK) { + if (TclListObjLength(interp, handlerPtr, &lstlen) != TCL_OK) { /* * Not a list. */ @@ -5013,7 +5013,7 @@ TclLogCommandInfo( size_t len; iPtr->resetErrorStack = 0; - Tcl_ListObjLength(interp, iPtr->errorStack, &len); + TclListObjLength(interp, iPtr->errorStack, &len); /* * Reset while keeping the list internalrep as much as possible. @@ -5098,7 +5098,7 @@ TclErrorStackResetIf( size_t len; iPtr->resetErrorStack = 0; - Tcl_ListObjLength(interp, iPtr->errorStack, &len); + TclListObjLength(interp, iPtr->errorStack, &len); /* * Reset while keeping the list internalrep as much as possible. diff --git a/generic/tclOOMethod.c b/generic/tclOOMethod.c index 14648ed..dd3183b 100644 --- a/generic/tclOOMethod.c +++ b/generic/tclOOMethod.c @@ -339,7 +339,7 @@ TclOONewProcInstanceMethod( ProcedureMethod *pmPtr; Tcl_Method method; - if (Tcl_ListObjLength(interp, argsObj, &argsLen) != TCL_OK) { + if (TclListObjLength(interp, argsObj, &argsLen) != TCL_OK) { return NULL; } pmPtr = (ProcedureMethod *)Tcl_Alloc(sizeof(ProcedureMethod)); @@ -397,7 +397,7 @@ TclOONewProcMethod( TclNewObj(argsObj); Tcl_IncrRefCount(argsObj); procName = ""; - } else if (Tcl_ListObjLength(interp, argsObj, &argsLen) != TCL_OK) { + } else if (TclListObjLength(interp, argsObj, &argsLen) != TCL_OK) { return NULL; } else { procName = (nameObj==NULL ? "" : TclGetString(nameObj)); @@ -1390,7 +1390,7 @@ TclOONewForwardInstanceMethod( size_t prefixLen; ForwardMethod *fmPtr; - if (Tcl_ListObjLength(interp, prefixObj, &prefixLen) != TCL_OK) { + if (TclListObjLength(interp, prefixObj, &prefixLen) != TCL_OK) { return NULL; } if (prefixLen < 1) { @@ -1429,7 +1429,7 @@ TclOONewForwardMethod( size_t prefixLen; ForwardMethod *fmPtr; - if (Tcl_ListObjLength(interp, prefixObj, &prefixLen) != TCL_OK) { + if (TclListObjLength(interp, prefixObj, &prefixLen) != TCL_OK) { return NULL; } if (prefixLen < 1) { diff --git a/generic/tclObj.c b/generic/tclObj.c index 8f95260..ebc92ae 100644 --- a/generic/tclObj.c +++ b/generic/tclObj.c @@ -841,7 +841,7 @@ Tcl_AppendAllObjTypes( * Get the test for a valid list out of the way first. */ - if (Tcl_ListObjLength(interp, objPtr, &numElems) != TCL_OK) { + if (TclListObjLength(interp, objPtr, &numElems) != TCL_OK) { return TCL_ERROR; } diff --git a/generic/tclPathObj.c b/generic/tclPathObj.c index 113c2ed..16ad5f4 100644 --- a/generic/tclPathObj.c +++ b/generic/tclPathObj.c @@ -810,7 +810,7 @@ Tcl_FSJoinPath( size_t objc; Tcl_Obj **objv; - if (Tcl_ListObjLength(NULL, listObj, &objc) != TCL_OK) { + if (TclListObjLength(NULL, listObj, &objc) != TCL_OK) { return NULL; } diff --git a/generic/tclProc.c b/generic/tclProc.c index 5f4d884..0284a66 100644 --- a/generic/tclProc.c +++ b/generic/tclProc.c @@ -920,7 +920,7 @@ TclNRUplevelObjCmd( } else if (!TclHasStringRep(objv[1]) && objc == 2) { int status; size_t llength; - status = Tcl_ListObjLength(interp, objv[1], &llength); + status = TclListObjLength(interp, objv[1], &llength); if (status == TCL_OK && llength > 1) { /* the first argument can't interpreted as a level. Avoid * generating a string representation of the script. */ diff --git a/generic/tclResult.c b/generic/tclResult.c index 6286070..899b299 100644 --- a/generic/tclResult.c +++ b/generic/tclResult.c @@ -755,7 +755,7 @@ TclProcessReturn( return TCL_ERROR; } iPtr->resetErrorStack = 0; - Tcl_ListObjLength(interp, iPtr->errorStack, &len); + TclListObjLength(interp, iPtr->errorStack, &len); /* * Reset while keeping the list internalrep as much as possible. @@ -912,7 +912,7 @@ TclMergeReturnOptions( if (valuePtr != NULL) { size_t length; - if (TCL_ERROR == Tcl_ListObjLength(NULL, valuePtr, &length )) { + if (TCL_ERROR == TclListObjLength(NULL, valuePtr, &length )) { /* * Value is not a list, which is illegal for -errorcode. */ @@ -934,7 +934,7 @@ TclMergeReturnOptions( if (valuePtr != NULL) { size_t length; - if (TCL_ERROR == Tcl_ListObjLength(NULL, valuePtr, &length)) { + if (TCL_ERROR == TclListObjLength(NULL, valuePtr, &length)) { /* * Value is not a list, which is illegal for -errorstack. */ diff --git a/generic/tclStrToD.c b/generic/tclStrToD.c index f820ae4..d4bf9dd 100644 --- a/generic/tclStrToD.c +++ b/generic/tclStrToD.c @@ -559,7 +559,7 @@ TclParseNumber( if (TclHasInternalRep(objPtr, &tclListType)) { size_t length; /* A list can only be a (single) number if its length == 1 */ - Tcl_ListObjLength(NULL, objPtr, &length); + TclListObjLength(NULL, objPtr, &length); if (length != 1) { return TCL_ERROR; } diff --git a/generic/tclStringObj.c b/generic/tclStringObj.c index c643ba7..0bb5acb 100644 --- a/generic/tclStringObj.c +++ b/generic/tclStringObj.c @@ -473,7 +473,7 @@ TclCheckEmptyString( } if (TclListObjIsCanonical(objPtr)) { - Tcl_ListObjLength(NULL, objPtr, &length); + TclListObjLength(NULL, objPtr, &length); return length == 0; } diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c index f41d89d..97e2fdd 100644 --- a/generic/tclStubInit.c +++ b/generic/tclStubInit.c @@ -111,7 +111,7 @@ int LOGetElements(Tcl_Interp *interp, Tcl_Obj *listPtr, int LOLength(Tcl_Interp *interp, Tcl_Obj *listPtr, int *lengthPtr) { size_t n = TCL_INDEX_NONE; - int result = Tcl_ListObjLength(interp, listPtr, &n); + int result = TclListObjLength(interp, listPtr, &n); if (lengthPtr) { if ((result == TCL_OK) && (n > INT_MAX)) { if (interp) { diff --git a/generic/tclTrace.c b/generic/tclTrace.c index 72bf4cd..df5f49d 100644 --- a/generic/tclTrace.c +++ b/generic/tclTrace.c @@ -603,7 +603,7 @@ TraceExecutionObjCmd( TclNewLiteralStringObj(opObj, "leavestep"); Tcl_ListObjAppendElement(NULL, elemObjPtr, opObj); } - Tcl_ListObjLength(NULL, elemObjPtr, &numOps); + TclListObjLength(NULL, elemObjPtr, &numOps); if (0 == numOps) { Tcl_DecrRefCount(elemObjPtr); continue; @@ -798,7 +798,7 @@ TraceCommandObjCmd( TclNewLiteralStringObj(opObj, "delete"); Tcl_ListObjAppendElement(NULL, elemObjPtr, opObj); } - Tcl_ListObjLength(NULL, elemObjPtr, &numOps); + TclListObjLength(NULL, elemObjPtr, &numOps); if (0 == numOps) { Tcl_DecrRefCount(elemObjPtr); continue; diff --git a/generic/tclUtil.c b/generic/tclUtil.c index aef3a6e..bda3494 100644 --- a/generic/tclUtil.c +++ b/generic/tclUtil.c @@ -3485,7 +3485,7 @@ GetEndOffsetFromObj( if ((TclMaxListLength(bytes, -1, NULL) > 1) /* If it's possible, do the full list parse. */ - && (TCL_OK == Tcl_ListObjLength(NULL, objPtr, &len)) + && (TCL_OK == TclListObjLength(NULL, objPtr, &len)) && (len > 1)) { goto parseError; } diff --git a/generic/tclVar.c b/generic/tclVar.c index 6b47fb1..6eeec4c 100644 --- a/generic/tclVar.c +++ b/generic/tclVar.c @@ -2835,7 +2835,7 @@ Tcl_LappendObjCmd( return TCL_ERROR; } } else { - result = Tcl_ListObjLength(interp, newValuePtr, &numElems); + result = TclListObjLength(interp, newValuePtr, &numElems); if (result != TCL_OK) { return result; } @@ -2893,7 +2893,7 @@ Tcl_LappendObjCmd( createdNewObj = 1; } - result = Tcl_ListObjLength(interp, varValuePtr, &numElems); + result = TclListObjLength(interp, varValuePtr, &numElems); if (result == TCL_OK) { result = Tcl_ListObjReplace(interp, varValuePtr, numElems, 0, (objc-2), (objv+2)); @@ -3046,7 +3046,7 @@ ArrayForNRCmd( * Parse arguments. */ - if (Tcl_ListObjLength(interp, objv[1], &numVars) != TCL_OK) { + if (TclListObjLength(interp, objv[1], &numVars) != TCL_OK) { return TCL_ERROR; } diff --git a/generic/tclZlib.c b/generic/tclZlib.c index 03fa8e2..00b262d 100644 --- a/generic/tclZlib.c +++ b/generic/tclZlib.c @@ -1373,7 +1373,7 @@ Tcl_ZlibStreamGet( Tcl_DecrRefCount(zshPtr->currentInput); zshPtr->currentInput = NULL; } - Tcl_ListObjLength(NULL, zshPtr->inData, &listLen); + TclListObjLength(NULL, zshPtr->inData, &listLen); if (listLen > 0) { /* * There is more input available, get it from the list and @@ -1422,7 +1422,7 @@ Tcl_ZlibStreamGet( e = inflate(&zshPtr->stream, zshPtr->flush); } }; - Tcl_ListObjLength(NULL, zshPtr->inData, &listLen); + TclListObjLength(NULL, zshPtr->inData, &listLen); while ((zshPtr->stream.avail_out > 0) && (e == Z_OK || e == Z_BUF_ERROR) && (listLen > 0)) { @@ -1502,7 +1502,7 @@ Tcl_ZlibStreamGet( inflateEnd(&zshPtr->stream); } } else { - Tcl_ListObjLength(NULL, zshPtr->outData, &listLen); + TclListObjLength(NULL, zshPtr->outData, &listLen); if (count == TCL_INDEX_NONE) { count = 0; for (i=0; i dataPos) && - (Tcl_ListObjLength(NULL, zshPtr->outData, &listLen) == TCL_OK) + (TclListObjLength(NULL, zshPtr->outData, &listLen) == TCL_OK) && (listLen > 0)) { /* * Get the next chunk off our list of chunks and grab the data out -- cgit v0.12 From da5c2b08af1531f171e79ee0d09a5288eabbec46 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 10 Feb 2022 08:42:43 +0000 Subject: Same with TclListObjGetElements --- generic/tclAssembly.c | 2 +- generic/tclBasic.c | 12 ++++++------ generic/tclBinary.c | 4 ++-- generic/tclClock.c | 8 ++++---- generic/tclCmdAH.c | 4 ++-- generic/tclCmdIL.c | 24 ++++++++++++------------ generic/tclCmdMZ.c | 14 +++++++------- generic/tclCompCmds.c | 2 +- generic/tclCompCmdsSZ.c | 4 ++-- generic/tclCompExpr.c | 4 ++-- generic/tclDictObj.c | 18 +++++++++--------- generic/tclEncoding.c | 4 ++-- generic/tclEnsemble.c | 16 ++++++++-------- generic/tclEvent.c | 2 +- generic/tclExecute.c | 26 +++++++++++++------------- generic/tclFileName.c | 4 ++-- generic/tclIO.c | 2 +- generic/tclIORChan.c | 10 +++++----- generic/tclIORTrans.c | 6 +++--- generic/tclIOUtil.c | 4 ++-- generic/tclIndexObj.c | 6 +++--- generic/tclInterp.c | 4 ++-- generic/tclLink.c | 2 +- generic/tclListObj.c | 10 +++++----- generic/tclNamesp.c | 2 +- generic/tclOODefineCmds.c | 16 ++++++++-------- generic/tclOOMethod.c | 2 +- generic/tclPathObj.c | 4 ++-- generic/tclPkg.c | 4 ++-- generic/tclProc.c | 6 +++--- generic/tclResult.c | 4 ++-- generic/tclStringObj.c | 2 +- generic/tclTrace.c | 6 +++--- generic/tclVar.c | 6 +++--- 34 files changed, 122 insertions(+), 122 deletions(-) diff --git a/generic/tclAssembly.c b/generic/tclAssembly.c index da55cea..1ea3d37 100644 --- a/generic/tclAssembly.c +++ b/generic/tclAssembly.c @@ -1983,7 +1983,7 @@ CreateMirrorJumpTable( * table. */ size_t i; - if (Tcl_ListObjGetElements(interp, jumps, &objc, &objv) != TCL_OK) { + if (TclListObjGetElements(interp, jumps, &objc, &objv) != TCL_OK) { return TCL_ERROR; } if (objc % 2 != 0) { diff --git a/generic/tclBasic.c b/generic/tclBasic.c index 08933a3..c49ce34 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -4714,7 +4714,7 @@ TEOV_NotFound( * itself. */ - Tcl_ListObjGetElements(NULL, currNsPtr->unknownHandlerPtr, + TclListObjGetElements(NULL, currNsPtr->unknownHandlerPtr, &handlerObjc, &handlerObjv); newObjc = objc + handlerObjc; newObjv = (Tcl_Obj **)TclStackAlloc(interp, sizeof(Tcl_Obj *) * newObjc); @@ -5274,7 +5274,7 @@ TclEvalEx( size_t numElements; Tcl_Obj **elements, *temp = copy[wordIdx]; - Tcl_ListObjGetElements(NULL, temp, &numElements, + TclListObjGetElements(NULL, temp, &numElements, &elements); objectsUsed += numElements; while (numElements--) { @@ -6037,7 +6037,7 @@ TclNREvalObjEx( TclNRAddCallback(interp, TEOEx_ListCallback, listPtr, eoFramePtr, objPtr, NULL); - Tcl_ListObjGetElements(NULL, listPtr, &objc, &objv); + TclListObjGetElements(NULL, listPtr, &objc, &objv); return TclNREvalObjv(interp, objc, objv, flags, NULL); } @@ -8640,7 +8640,7 @@ TclNRTailcallEval( size_t objc; Tcl_Obj **objv; - Tcl_ListObjGetElements(interp, listPtr, &objc, &objv); + TclListObjGetElements(interp, listPtr, &objc, &objv); nsObjPtr = objv[0]; if (result == TCL_OK) { @@ -9070,7 +9070,7 @@ TclNREvalList( TclMarkTailcall(interp); TclNRAddCallback(interp, TclNRReleaseValues, listPtr, NULL, NULL,NULL); - Tcl_ListObjGetElements(NULL, listPtr, &objc, &objv); + TclListObjGetElements(NULL, listPtr, &objc, &objv); return TclNREvalObjv(interp, objc, objv, 0, NULL); } @@ -9358,7 +9358,7 @@ InjectHandler( TclMarkTailcall(interp); TclNRAddCallback(interp, InjectHandlerPostCall, corPtr, listPtr, INT2PTR(nargs), isProbe); - Tcl_ListObjGetElements(NULL, listPtr, &objc, &objv); + TclListObjGetElements(NULL, listPtr, &objc, &objv); return TclNREvalObjv(interp, objc, objv, 0, NULL); } diff --git a/generic/tclBinary.c b/generic/tclBinary.c index ae454c4..8eea58c 100644 --- a/generic/tclBinary.c +++ b/generic/tclBinary.c @@ -1013,7 +1013,7 @@ BinaryFormatCmd( * The macro evals its args more than once: avoid arg++ */ - if (Tcl_ListObjGetElements(interp, objv[arg], &listc, + if (TclListObjGetElements(interp, objv[arg], &listc, &listv) != TCL_OK) { return TCL_ERROR; } @@ -1297,7 +1297,7 @@ BinaryFormatCmd( listc = 1; count = 1; } else { - Tcl_ListObjGetElements(interp, objv[arg], &listc, &listv); + TclListObjGetElements(interp, objv[arg], &listc, &listv); if (count == BINARY_ALL) { count = listc; } diff --git a/generic/tclClock.c b/generic/tclClock.c index 85274e6..c021a31 100644 --- a/generic/tclClock.c +++ b/generic/tclClock.c @@ -754,7 +754,7 @@ ConvertLocalToUTC( * Unpack the tz data. */ - if (Tcl_ListObjGetElements(interp, tzdata, &rowc, &rowv) != TCL_OK) { + if (TclListObjGetElements(interp, tzdata, &rowc, &rowv) != TCL_OK) { return TCL_ERROR; } @@ -819,7 +819,7 @@ ConvertLocalToUTCUsingTable( while (!found) { row = LookupLastTransition(interp, fields->seconds, rowc, rowv); if ((row == NULL) - || Tcl_ListObjGetElements(interp, row, &cellc, + || TclListObjGetElements(interp, row, &cellc, &cellv) != TCL_OK || TclGetIntFromObj(interp, cellv[1], &fields->tzOffset) != TCL_OK) { @@ -957,7 +957,7 @@ ConvertUTCToLocal( * Unpack the tz data. */ - if (Tcl_ListObjGetElements(interp, tzdata, &rowc, &rowv) != TCL_OK) { + if (TclListObjGetElements(interp, tzdata, &rowc, &rowv) != TCL_OK) { return TCL_ERROR; } @@ -1009,7 +1009,7 @@ ConvertUTCToLocalUsingTable( row = LookupLastTransition(interp, fields->seconds, rowc, rowv); if (row == NULL || - Tcl_ListObjGetElements(interp, row, &cellc, &cellv) != TCL_OK || + TclListObjGetElements(interp, row, &cellc, &cellv) != TCL_OK || TclGetIntFromObj(interp, cellv[1], &fields->tzOffset) != TCL_OK) { return TCL_ERROR; } diff --git a/generic/tclCmdAH.c b/generic/tclCmdAH.c index e124d66..d58b92c 100644 --- a/generic/tclCmdAH.c +++ b/generic/tclCmdAH.c @@ -2533,7 +2533,7 @@ EachloopCmd( result = TCL_ERROR; goto done; } - Tcl_ListObjGetElements(NULL, statePtr->vCopyList[i], + TclListObjGetElements(NULL, statePtr->vCopyList[i], &statePtr->varcList[i], &statePtr->varvList[i]); if (statePtr->varcList[i] < 1) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( @@ -2551,7 +2551,7 @@ EachloopCmd( result = TCL_ERROR; goto done; } - Tcl_ListObjGetElements(NULL, statePtr->aCopyList[i], + TclListObjGetElements(NULL, statePtr->aCopyList[i], &statePtr->argcList[i], &statePtr->argvList[i]); j = statePtr->argcList[i] / statePtr->varcList[i]; diff --git a/generic/tclCmdIL.c b/generic/tclCmdIL.c index 9dead6b..261cc65 100644 --- a/generic/tclCmdIL.c +++ b/generic/tclCmdIL.c @@ -2193,7 +2193,7 @@ Tcl_JoinObjCmd( * pointer to its array of element pointers. */ - if (Tcl_ListObjGetElements(interp, objv[1], &listLen, + if (TclListObjGetElements(interp, objv[1], &listLen, &elemPtrs) != TCL_OK) { return TCL_ERROR; } @@ -2280,7 +2280,7 @@ Tcl_LassignObjCmd( return TCL_ERROR; } - Tcl_ListObjGetElements(NULL, listCopyPtr, &listObjc, &listObjv); + TclListObjGetElements(NULL, listCopyPtr, &listObjc, &listObjv); objc -= 2; objv += 2; @@ -2579,7 +2579,7 @@ Tcl_LpopObjCmd( return TCL_ERROR; } - result = Tcl_ListObjGetElements(interp, listPtr, &listLen, &elemPtrs); + result = TclListObjGetElements(interp, listPtr, &listLen, &elemPtrs); if (result != TCL_OK) { return result; } @@ -3070,7 +3070,7 @@ Tcl_LreverseObjCmd( Tcl_WrongNumArgs(interp, 1, objv, "list"); return TCL_ERROR; } - if (Tcl_ListObjGetElements(interp, objv[1], &elemc, &elemv) != TCL_OK) { + if (TclListObjGetElements(interp, objv[1], &elemc, &elemv) != TCL_OK) { return TCL_ERROR; } @@ -3342,7 +3342,7 @@ Tcl_LsearchObjCmd( */ i++; - if (Tcl_ListObjGetElements(interp, objv[i], + if (TclListObjGetElements(interp, objv[i], &sortInfo.indexc, &indices) != TCL_OK) { result = TCL_ERROR; goto done; @@ -3448,7 +3448,7 @@ Tcl_LsearchObjCmd( * pointer to its array of element pointers. */ - result = Tcl_ListObjGetElements(interp, objv[objc - 2], &listc, &listv); + result = TclListObjGetElements(interp, objv[objc - 2], &listc, &listv); if (result != TCL_OK) { goto done; } @@ -3553,7 +3553,7 @@ Tcl_LsearchObjCmd( * 1844789] */ - Tcl_ListObjGetElements(NULL, objv[objc - 2], &listc, &listv); + TclListObjGetElements(NULL, objv[objc - 2], &listc, &listv); break; case REAL: result = Tcl_GetDoubleFromObj(interp, patObj, &patDouble); @@ -3566,7 +3566,7 @@ Tcl_LsearchObjCmd( * 1844789] */ - Tcl_ListObjGetElements(NULL, objv[objc - 2], &listc, &listv); + TclListObjGetElements(NULL, objv[objc - 2], &listc, &listv); break; } } else { @@ -4081,7 +4081,7 @@ Tcl_LsortObjCmd( sortInfo.resultCode = TCL_ERROR; goto done; } - if (Tcl_ListObjGetElements(interp, objv[i+1], &sortindex, + if (TclListObjGetElements(interp, objv[i+1], &sortindex, &indexv) != TCL_OK) { sortInfo.resultCode = TCL_ERROR; goto done; @@ -4174,7 +4174,7 @@ Tcl_LsortObjCmd( if (indexPtr) { Tcl_Obj **indexv; - Tcl_ListObjGetElements(interp, indexPtr, &sortInfo.indexc, &indexv); + TclListObjGetElements(interp, indexPtr, &sortInfo.indexc, &indexv); switch (sortInfo.indexc) { case 0: sortInfo.indexv = NULL; @@ -4234,7 +4234,7 @@ Tcl_LsortObjCmd( sortInfo.compareCmdPtr = newCommandPtr; } - sortInfo.resultCode = Tcl_ListObjGetElements(interp, listObj, + sortInfo.resultCode = TclListObjGetElements(interp, listObj, &length, &listObjPtrs); if (sortInfo.resultCode != TCL_OK || length <= 0) { goto done; @@ -4654,7 +4654,7 @@ SortCompare( TclListObjLength(infoPtr->interp, infoPtr->compareCmdPtr, &objc); Tcl_ListObjReplace(infoPtr->interp, infoPtr->compareCmdPtr, objc - 2, 2, 2, paramObjv); - Tcl_ListObjGetElements(infoPtr->interp, infoPtr->compareCmdPtr, + TclListObjGetElements(infoPtr->interp, infoPtr->compareCmdPtr, &objc, &objv); infoPtr->resultCode = Tcl_EvalObjv(infoPtr->interp, objc, objv, 0); diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c index 2554f0a..736aadb 100644 --- a/generic/tclCmdMZ.c +++ b/generic/tclCmdMZ.c @@ -777,7 +777,7 @@ Tcl_RegsubObjCmd( Tcl_Obj **args = NULL, **parts; size_t numArgs; - Tcl_ListObjGetElements(interp, subPtr, &numParts, &parts); + TclListObjGetElements(interp, subPtr, &numParts, &parts); numArgs = numParts + info.nsubs + 1; args = (Tcl_Obj **)Tcl_Alloc(sizeof(Tcl_Obj*) * numArgs); memcpy(args, parts, sizeof(Tcl_Obj*) * numParts); @@ -2030,7 +2030,7 @@ StringMapCmd( Tcl_DictObjDone(&search); } else { size_t i; - if (Tcl_ListObjGetElements(interp, objv[objc-2], &i, + if (TclListObjGetElements(interp, objv[objc-2], &i, &mapElemv) != TCL_OK) { return TCL_ERROR; } @@ -3580,7 +3580,7 @@ TclNRSwitchObjCmd( size_t listc; blist = objv[0]; - if (Tcl_ListObjGetElements(interp, objv[0], &listc, &listv) != TCL_OK) { + if (TclListObjGetElements(interp, objv[0], &listc, &listv) != TCL_OK) { return TCL_ERROR; } @@ -4917,12 +4917,12 @@ TryPostBody( int found = 0; Tcl_Obj **handlers, **info; - Tcl_ListObjGetElements(NULL, handlersObj, &numHandlers, &handlers); + TclListObjGetElements(NULL, handlersObj, &numHandlers, &handlers); for (i=0 ; i 2)) { TclDecrRefCount(tmpObj); goto failedToCompile; diff --git a/generic/tclCompExpr.c b/generic/tclCompExpr.c index 6e36c28..937e71e 100644 --- a/generic/tclCompExpr.c +++ b/generic/tclCompExpr.c @@ -2226,8 +2226,8 @@ TclCompileExpr( TclAdvanceLines(&envPtr->line, script, script + TclParseAllWhiteSpace(script, numBytes)); - Tcl_ListObjGetElements(NULL, litList, &objc, (Tcl_Obj ***)&litObjv); - Tcl_ListObjGetElements(NULL, funcList, &objc, &funcObjv); + TclListObjGetElements(NULL, litList, &objc, (Tcl_Obj ***)&litObjv); + TclListObjGetElements(NULL, funcList, &objc, &funcObjv); CompileExprTree(interp, opTree, 0, &litObjv, funcObjv, parsePtr->tokenPtr, envPtr, optimize); } else { diff --git a/generic/tclDictObj.c b/generic/tclDictObj.c index b3db861..b5599db 100644 --- a/generic/tclDictObj.c +++ b/generic/tclDictObj.c @@ -606,7 +606,7 @@ SetDictFromAny( Tcl_Obj **objv; /* Cannot fail, we already know the Tcl_ObjType is "list". */ - Tcl_ListObjGetElements(NULL, objPtr, &objc, &objv); + TclListObjGetElements(NULL, objPtr, &objc, &objv); if (objc & 1) { goto missingValue; } @@ -2473,7 +2473,7 @@ DictForNRCmd( * Parse arguments. */ - if (Tcl_ListObjGetElements(interp, objv[1], &varc, &varv) != TCL_OK) { + if (TclListObjGetElements(interp, objv[1], &varc, &varv) != TCL_OK) { return TCL_ERROR; } if (varc != 2) { @@ -2492,7 +2492,7 @@ DictForNRCmd( TclStackFree(interp, searchPtr); return TCL_OK; } - Tcl_ListObjGetElements(NULL, objv[1], &varc, &varv); + TclListObjGetElements(NULL, objv[1], &varc, &varv); keyVarObj = varv[0]; valueVarObj = varv[1]; scriptObj = objv[3]; @@ -2668,7 +2668,7 @@ DictMapNRCmd( * Parse arguments. */ - if (Tcl_ListObjGetElements(interp, objv[1], &varc, &varv) != TCL_OK) { + if (TclListObjGetElements(interp, objv[1], &varc, &varv) != TCL_OK) { return TCL_ERROR; } if (varc != 2) { @@ -2694,7 +2694,7 @@ DictMapNRCmd( return TCL_OK; } TclNewObj(storagePtr->accumulatorObj); - Tcl_ListObjGetElements(NULL, objv[1], &varc, &varv); + TclListObjGetElements(NULL, objv[1], &varc, &varv); storagePtr->keyVarObj = varv[0]; storagePtr->valueVarObj = varv[1]; storagePtr->scriptObj = objv[3]; @@ -3108,7 +3108,7 @@ DictFilterCmd( * copying from the "dict for" implementation has occurred! */ - if (Tcl_ListObjGetElements(interp, objv[3], &varc, &varv) != TCL_OK) { + if (TclListObjGetElements(interp, objv[3], &varc, &varv) != TCL_OK) { return TCL_ERROR; } if (varc != 2) { @@ -3370,7 +3370,7 @@ FinalizeDictUpdate( * an instruction to remove the key. */ - Tcl_ListObjGetElements(NULL, argsObj, &objc, &objv); + TclListObjGetElements(NULL, argsObj, &objc, &objv); for (i=0 ; ilookupNsPtr = ensemblePtr->nsPtr; return TclNREvalObjv(interp, copyObjc, copyObjv, TCL_EVAL_INVOKE, NULL); } @@ -2298,7 +2298,7 @@ EnsembleUnknownCallback( for (i = 1 ; i < (size_t)objc ; i++) { Tcl_ListObjAppendElement(NULL, unknownCmd, objv[i]); } - Tcl_ListObjGetElements(NULL, unknownCmd, ¶mc, ¶mv); + TclListObjGetElements(NULL, unknownCmd, ¶mc, ¶mv); Tcl_IncrRefCount(unknownCmd); /* @@ -2592,7 +2592,7 @@ BuildEnsembleConfig( * Determine the target for each. */ - Tcl_ListObjGetElements(NULL, subList, &subc, &subv); + TclListObjGetElements(NULL, subList, &subc, &subv); if (subList == mapDict) { /* * Unusual case where explicit list of subcommands is same value @@ -2989,7 +2989,7 @@ TclCompileEnsemble( const char *str; Tcl_Obj *matchObj = NULL; - if (Tcl_ListObjGetElements(NULL, listObj, &len, &elems) != TCL_OK) { + if (TclListObjGetElements(NULL, listObj, &len, &elems) != TCL_OK) { goto failed; } for (i=0 ; itokenPtr; i < parsePtr->numWords; i++, tokPtr = TokenAfter(tokPtr)) { if (i > 0 && (size_t)i <= numWords) { diff --git a/generic/tclEvent.c b/generic/tclEvent.c index f3a5b39..21647e4 100644 --- a/generic/tclEvent.c +++ b/generic/tclEvent.c @@ -220,7 +220,7 @@ HandleBgErrors( errPtr = assocPtr->firstBgPtr; - Tcl_ListObjGetElements(NULL, copyObj, &prefixObjc, &prefixObjv); + TclListObjGetElements(NULL, copyObj, &prefixObjc, &prefixObjv); tempObjv = (Tcl_Obj**)Tcl_Alloc((prefixObjc+2) * sizeof(Tcl_Obj *)); memcpy(tempObjv, prefixObjv, prefixObjc*sizeof(Tcl_Obj *)); tempObjv[prefixObjc] = errPtr->errorMsg; diff --git a/generic/tclExecute.c b/generic/tclExecute.c index a36dc44..8244486 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -2673,7 +2673,7 @@ TEBCresume( objPtr = OBJ_AT_TOS; TRACE(("\"%.30s\" => ", O2S(objPtr))); - if (Tcl_ListObjGetElements(interp, objPtr, &objc, &objv) != TCL_OK) { + if (TclListObjGetElements(interp, objPtr, &objc, &objv) != TCL_OK) { TRACE_ERROR(interp); goto gotError; } @@ -2883,7 +2883,7 @@ TEBCresume( TclMarkTailcall(interp); TclNRAddCallback(interp, TclClearRootEnsemble, NULL, NULL, NULL, NULL); - Tcl_ListObjGetElements(NULL, objPtr, &objc, &objv); + TclListObjGetElements(NULL, objPtr, &objc, &objv); TclNRAddCallback(interp, TclNRReleaseValues, objPtr, NULL, NULL, NULL); return TclNREvalObjv(interp, objc, objv, TCL_EVAL_INVOKE, NULL); @@ -3295,7 +3295,7 @@ TEBCresume( varPtr = varPtr->value.linkPtr; } TRACE(("%u <- \"%.30s\" => ", opnd, O2S(valuePtr))); - if (Tcl_ListObjGetElements(interp, valuePtr, &objc, &objv) + if (TclListObjGetElements(interp, valuePtr, &objc, &objv) != TCL_OK) { TRACE_ERROR(interp); goto gotError; @@ -3321,7 +3321,7 @@ TEBCresume( } TRACE(("%u \"%.30s\" \"%.30s\" => ", opnd, O2S(part2Ptr), O2S(valuePtr))); - if (Tcl_ListObjGetElements(interp, valuePtr, &objc, &objv) + if (TclListObjGetElements(interp, valuePtr, &objc, &objv) != TCL_OK) { TRACE_ERROR(interp); goto gotError; @@ -3384,7 +3384,7 @@ TEBCresume( lappendList: opnd = -1; - if (Tcl_ListObjGetElements(interp, valuePtr, &objc, &objv) + if (TclListObjGetElements(interp, valuePtr, &objc, &objv) != TCL_OK) { TRACE_ERROR(interp); goto gotError; @@ -4655,7 +4655,7 @@ TEBCresume( * Extract the desired list element. */ - if ((Tcl_ListObjGetElements(interp, valuePtr, &objc, &objv) == TCL_OK) + if ((TclListObjGetElements(interp, valuePtr, &objc, &objv) == TCL_OK) && !TclHasInternalRep(value2Ptr, &tclListType)) { int code; @@ -4700,7 +4700,7 @@ TEBCresume( * in the process. */ - if (Tcl_ListObjGetElements(interp, valuePtr, &objc, &objv) != TCL_OK) { + if (TclListObjGetElements(interp, valuePtr, &objc, &objv) != TCL_OK) { TRACE_ERROR(interp); goto gotError; } @@ -6326,7 +6326,7 @@ TEBCresume( numVars = varListPtr->numVars; listPtr = OBJ_AT_DEPTH(listTmpDepth); - Tcl_ListObjGetElements(interp, listPtr, &listLen, &elements); + TclListObjGetElements(interp, listPtr, &listLen, &elements); valIndex = (iterNum * numVars); for (j = 0; j < numVars; j++) { @@ -6941,7 +6941,7 @@ TEBCresume( } } Tcl_IncrRefCount(dictPtr); - if (Tcl_ListObjGetElements(interp, OBJ_AT_TOS, &length, + if (TclListObjGetElements(interp, OBJ_AT_TOS, &length, &keyPtrPtr) != TCL_OK) { TRACE_ERROR(interp); goto gotError; @@ -7001,7 +7001,7 @@ TEBCresume( NEXT_INST_F(9, 1, 0); } if (Tcl_DictObjSize(interp, dictPtr, &length) != TCL_OK - || Tcl_ListObjGetElements(interp, OBJ_AT_TOS, &length, + || TclListObjGetElements(interp, OBJ_AT_TOS, &length, &keyPtrPtr) != TCL_OK) { TRACE_ERROR(interp); goto gotError; @@ -7060,7 +7060,7 @@ TEBCresume( dictPtr = OBJ_UNDER_TOS; listPtr = OBJ_AT_TOS; TRACE(("\"%.30s\" \"%.30s\" =>", O2S(dictPtr), O2S(listPtr))); - if (Tcl_ListObjGetElements(interp, listPtr, &objc, &objv) != TCL_OK) { + if (TclListObjGetElements(interp, listPtr, &objc, &objv) != TCL_OK) { TRACE_ERROR(interp); goto gotError; } @@ -7078,7 +7078,7 @@ TEBCresume( listPtr = OBJ_AT_TOS; TRACE(("\"%.30s\" \"%.30s\" \"%.30s\" => ", O2S(varNamePtr), O2S(valuePtr), O2S(keysPtr))); - if (Tcl_ListObjGetElements(interp, listPtr, &objc, &objv) != TCL_OK) { + if (TclListObjGetElements(interp, listPtr, &objc, &objv) != TCL_OK) { TRACE_ERROR(interp); TclDecrRefCount(keysPtr); goto gotError; @@ -7109,7 +7109,7 @@ TEBCresume( varPtr = LOCAL(opnd); TRACE(("%u <- \"%.30s\" \"%.30s\" => ", opnd, O2S(valuePtr), O2S(keysPtr))); - if (Tcl_ListObjGetElements(interp, listPtr, &objc, &objv) != TCL_OK) { + if (TclListObjGetElements(interp, listPtr, &objc, &objv) != TCL_OK) { TRACE_ERROR(interp); goto gotError; } diff --git a/generic/tclFileName.c b/generic/tclFileName.c index 2f10a01..38e87e0 100644 --- a/generic/tclFileName.c +++ b/generic/tclFileName.c @@ -2016,7 +2016,7 @@ TclGlob( } } - Tcl_ListObjGetElements(NULL, filenamesObj, &objc, &objv); + TclListObjGetElements(NULL, filenamesObj, &objc, &objv); for (i = 0; i< objc; i++) { size_t len; const char *oldStr = Tcl_GetStringFromObj(objv[i], &len); @@ -2345,7 +2345,7 @@ DoGlob( size_t i, subdirc, repair = TCL_INDEX_NONE; Tcl_Obj **subdirv; - result = Tcl_ListObjGetElements(interp, subdirsPtr, + result = TclListObjGetElements(interp, subdirsPtr, &subdirc, &subdirv); for (i=0; result==TCL_OK && iflags & LINK_ALLOC_LAST) { - if (Tcl_ListObjGetElements(NULL, (valueObj), &objc, &objv) == TCL_ERROR + if (TclListObjGetElements(NULL, (valueObj), &objc, &objv) == TCL_ERROR || objc != linkPtr->numElems) { return (char *) "wrong dimension"; } diff --git a/generic/tclListObj.c b/generic/tclListObj.c index a70ad46..f7c32ef 100644 --- a/generic/tclListObj.c +++ b/generic/tclListObj.c @@ -416,7 +416,7 @@ TclListObjRange( size_t i, newLen; List *listRepPtr; - Tcl_ListObjGetElements(NULL, listPtr, &listLen, &elemPtrs); + TclListObjGetElements(NULL, listPtr, &listLen, &elemPtrs); if (fromIdx == TCL_INDEX_NONE) { fromIdx = 0; @@ -585,7 +585,7 @@ Tcl_ListObjAppendList( * Pull the elements to append from elemListPtr. */ - if (TCL_OK != Tcl_ListObjGetElements(interp, elemListPtr, &objc, &objv)) { + if (TCL_OK != TclListObjGetElements(interp, elemListPtr, &objc, &objv)) { return TCL_ERROR; } @@ -1316,7 +1316,7 @@ TclLindexFlat( break; } - Tcl_ListObjGetElements(NULL, sublistCopy, &listLen, &elemPtrs); + TclListObjGetElements(NULL, sublistCopy, &listLen, &elemPtrs); if (TclGetIntForIndexM(interp, indexArray[i], /*endValue*/ listLen-1, &index) == TCL_OK) { @@ -1409,7 +1409,7 @@ TclLsetList( return TclLsetFlat(interp, listPtr, 1, &indexArgPtr, valuePtr); } - Tcl_ListObjGetElements(NULL, indexArgPtr, &indexCount, &indices); + TclListObjGetElements(NULL, indexArgPtr, &indexCount, &indices); /* * Let TclLsetFlat handle the actual lset'ting. @@ -1530,7 +1530,7 @@ TclLsetFlat( * Check for the possible error conditions... */ - if (Tcl_ListObjGetElements(interp, subListPtr, &elemCount, &elemPtrs) + if (TclListObjGetElements(interp, subListPtr, &elemCount, &elemPtrs) != TCL_OK) { /* ...the sublist we're indexing into isn't a list at all. */ result = TCL_ERROR; diff --git a/generic/tclNamesp.c b/generic/tclNamesp.c index fd43f5b..e503c30 100644 --- a/generic/tclNamesp.c +++ b/generic/tclNamesp.c @@ -4068,7 +4068,7 @@ NamespacePathCmd( * There is a path given, so parse it into an array of namespace pointers. */ - if (Tcl_ListObjGetElements(interp, objv[1], &nsObjc, &nsObjv) != TCL_OK) { + if (TclListObjGetElements(interp, objv[1], &nsObjc, &nsObjv) != TCL_OK) { goto badNamespace; } if (nsObjc != 0) { diff --git a/generic/tclOODefineCmds.c b/generic/tclOODefineCmds.c index e589b24..d832d73 100644 --- a/generic/tclOODefineCmds.c +++ b/generic/tclOODefineCmds.c @@ -1068,7 +1068,7 @@ MagicDefinitionInvoke( Tcl_ListObjAppendElement(NULL, objPtr, obj2Ptr); /* TODO: overflow? */ Tcl_ListObjReplace(NULL, objPtr, 1, 0, objc - offset, objv + offset); - Tcl_ListObjGetElements(NULL, objPtr, &dummy, &objs); + TclListObjGetElements(NULL, objPtr, &dummy, &objs); result = Tcl_EvalObjv(interp, objc - cmdIndex, objs, TCL_EVAL_INVOKE); if (isRoot) { @@ -2375,7 +2375,7 @@ ClassFilterSet( "attempt to misuse API", -1)); Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL); return TCL_ERROR; - } else if (Tcl_ListObjGetElements(interp, objv[0], &filterc, + } else if (TclListObjGetElements(interp, objv[0], &filterc, &filterv) != TCL_OK) { return TCL_ERROR; } @@ -2459,7 +2459,7 @@ ClassMixinSet( "attempt to misuse API", -1)); Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL); return TCL_ERROR; - } else if (Tcl_ListObjGetElements(interp, objv[0], &mixinc, + } else if (TclListObjGetElements(interp, objv[0], &mixinc, &mixinv) != TCL_OK) { return TCL_ERROR; } @@ -2570,7 +2570,7 @@ ClassSuperSet( "may not modify the superclass of the root object", -1)); Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL); return TCL_ERROR; - } else if (Tcl_ListObjGetElements(interp, objv[0], &superc, + } else if (TclListObjGetElements(interp, objv[0], &superc, &superv) != TCL_OK) { return TCL_ERROR; } @@ -2740,7 +2740,7 @@ ClassVarsSet( "attempt to misuse API", -1)); Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL); return TCL_ERROR; - } else if (Tcl_ListObjGetElements(interp, objv[0], &varc, + } else if (TclListObjGetElements(interp, objv[0], &varc, &varv) != TCL_OK) { return TCL_ERROR; } @@ -2832,7 +2832,7 @@ ObjFilterSet( return TCL_ERROR; } objv += Tcl_ObjectContextSkippedArgs(context); - if (Tcl_ListObjGetElements(interp, objv[0], &filterc, + if (TclListObjGetElements(interp, objv[0], &filterc, &filterv) != TCL_OK) { return TCL_ERROR; } @@ -2906,7 +2906,7 @@ ObjMixinSet( return TCL_ERROR; } objv += Tcl_ObjectContextSkippedArgs(context); - if (Tcl_ListObjGetElements(interp, objv[0], &mixinc, + if (TclListObjGetElements(interp, objv[0], &mixinc, &mixinv) != TCL_OK) { return TCL_ERROR; } @@ -2996,7 +2996,7 @@ ObjVarsSet( return TCL_ERROR; } objv += Tcl_ObjectContextSkippedArgs(context); - if (Tcl_ListObjGetElements(interp, objv[0], &varc, + if (TclListObjGetElements(interp, objv[0], &varc, &varv) != TCL_OK) { return TCL_ERROR; } diff --git a/generic/tclOOMethod.c b/generic/tclOOMethod.c index dd3183b..3d81912 100644 --- a/generic/tclOOMethod.c +++ b/generic/tclOOMethod.c @@ -1479,7 +1479,7 @@ InvokeForwardMethod( * can ignore here. */ - Tcl_ListObjGetElements(NULL, fmPtr->prefixObj, &numPrefixes, &prefixObjs); + TclListObjGetElements(NULL, fmPtr->prefixObj, &numPrefixes, &prefixObjs); argObjs = InitEnsembleRewrite(interp, objc, objv, skip, numPrefixes, prefixObjs, &len); Tcl_NRAddCallback(interp, FinalizeForwardCall, argObjs, NULL, NULL, NULL); diff --git a/generic/tclPathObj.c b/generic/tclPathObj.c index 16ad5f4..8c81568 100644 --- a/generic/tclPathObj.c +++ b/generic/tclPathObj.c @@ -815,7 +815,7 @@ Tcl_FSJoinPath( } elements = ((elements != TCL_INDEX_NONE) && (elements <= objc)) ? elements : objc; - Tcl_ListObjGetElements(NULL, listObj, &objc, &objv); + TclListObjGetElements(NULL, listObj, &objc, &objv); res = TclJoinPath(elements, objv, 0); return res; } @@ -2314,7 +2314,7 @@ SetFsPathFromAny( Tcl_Obj **objv; Tcl_Obj *parts = TclpNativeSplitPath(pathPtr, NULL); - Tcl_ListObjGetElements(NULL, parts, &objc, &objv); + TclListObjGetElements(NULL, parts, &objc, &objv); /* * Skip '~'. It's replaced by its expansion. diff --git a/generic/tclPkg.c b/generic/tclPkg.c index 3f70ab8..aa81c55 100644 --- a/generic/tclPkg.c +++ b/generic/tclPkg.c @@ -1362,7 +1362,7 @@ TclNRPackageObjCmd( objvListPtr = Tcl_NewListObj(0, NULL); Tcl_IncrRefCount(objvListPtr); Tcl_ListObjAppendElement(interp, objvListPtr, ov); - Tcl_ListObjGetElements(interp, objvListPtr, &newobjc, &newObjvPtr); + TclListObjGetElements(interp, objvListPtr, &newobjc, &newObjvPtr); Tcl_NRAddCallback(interp, TclNRPackageObjCmdCleanup, objv[3], objvListPtr, NULL,NULL); @@ -1389,7 +1389,7 @@ TclNRPackageObjCmd( Tcl_ListObjAppendElement(interp, objvListPtr, Tcl_DuplicateObj(newobjv[i])); } - Tcl_ListObjGetElements(interp, objvListPtr, &newobjc, &newObjvPtr); + TclListObjGetElements(interp, objvListPtr, &newobjc, &newObjvPtr); Tcl_NRAddCallback(interp, TclNRPackageObjCmdCleanup, objv[2], objvListPtr, NULL,NULL); Tcl_NRAddCallback(interp, diff --git a/generic/tclProc.c b/generic/tclProc.c index 0284a66..d3059fa 100644 --- a/generic/tclProc.c +++ b/generic/tclProc.c @@ -484,7 +484,7 @@ TclCreateProc( * in the Proc. */ - result = Tcl_ListObjGetElements(interp , argsPtr ,&numArgs ,&argArray); + result = TclListObjGetElements(interp , argsPtr ,&numArgs ,&argArray); if (result != TCL_OK) { goto procError; } @@ -514,7 +514,7 @@ TclCreateProc( * Now divide the specifier up into name and default. */ - result = Tcl_ListObjGetElements(interp, argArray[i], &fieldCount, + result = TclListObjGetElements(interp, argArray[i], &fieldCount, &fieldValues); if (result != TCL_OK) { goto procError; @@ -2396,7 +2396,7 @@ SetLambdaFromAny( * length is not 2, then it cannot be converted to lambdaType. */ - result = Tcl_ListObjGetElements(NULL, objPtr, &objc, &objv); + result = TclListObjGetElements(NULL, objPtr, &objc, &objv); if ((result != TCL_OK) || ((objc != 2) && (objc != 3))) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "can't interpret \"%s\" as a lambda expression", diff --git a/generic/tclResult.c b/generic/tclResult.c index 899b299..b5573ae 100644 --- a/generic/tclResult.c +++ b/generic/tclResult.c @@ -750,7 +750,7 @@ TclProcessReturn( * if someone does [return -errorstack [info errorstack]] */ - if (Tcl_ListObjGetElements(interp, valuePtr, &valueObjc, + if (TclListObjGetElements(interp, valuePtr, &valueObjc, &valueObjv) == TCL_ERROR) { return TCL_ERROR; } @@ -1105,7 +1105,7 @@ Tcl_SetReturnOptions( Tcl_Obj **objv, *mergedOpts; Tcl_IncrRefCount(options); - if (TCL_ERROR == Tcl_ListObjGetElements(interp, options, &objc, &objv) + if (TCL_ERROR == TclListObjGetElements(interp, options, &objc, &objv) || (objc % 2)) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "expected dict but got \"%s\"", TclGetString(options))); diff --git a/generic/tclStringObj.c b/generic/tclStringObj.c index 0bb5acb..9fa9290 100644 --- a/generic/tclStringObj.c +++ b/generic/tclStringObj.c @@ -2679,7 +2679,7 @@ AppendPrintfToObjVA( } } while (seekingConversion); } - Tcl_ListObjGetElements(NULL, list, &objc, &objv); + TclListObjGetElements(NULL, list, &objc, &objv); code = Tcl_AppendFormatToObj(NULL, objPtr, format, objc, objv); if (code != TCL_OK) { Tcl_AppendPrintfToObj(objPtr, diff --git a/generic/tclTrace.c b/generic/tclTrace.c index df5f49d..69b40d7 100644 --- a/generic/tclTrace.c +++ b/generic/tclTrace.c @@ -433,7 +433,7 @@ TraceExecutionObjCmd( * pointer to its array of element pointers. */ - result = Tcl_ListObjGetElements(interp, objv[4], &listLen, &elemPtrs); + result = TclListObjGetElements(interp, objv[4], &listLen, &elemPtrs); if (result != TCL_OK) { return result; } @@ -674,7 +674,7 @@ TraceCommandObjCmd( * pointer to its array of element pointers. */ - result = Tcl_ListObjGetElements(interp, objv[4], &listLen, &elemPtrs); + result = TclListObjGetElements(interp, objv[4], &listLen, &elemPtrs); if (result != TCL_OK) { return result; } @@ -873,7 +873,7 @@ TraceVariableObjCmd( * pointer to its array of element pointers. */ - result = Tcl_ListObjGetElements(interp, objv[4], &listLen, &elemPtrs); + result = TclListObjGetElements(interp, objv[4], &listLen, &elemPtrs); if (result != TCL_OK) { return result; } diff --git a/generic/tclVar.c b/generic/tclVar.c index 6eeec4c..6636328 100644 --- a/generic/tclVar.c +++ b/generic/tclVar.c @@ -3158,7 +3158,7 @@ ArrayForLoopCallback( goto arrayfordone; } - Tcl_ListObjGetElements(NULL, varListObj, &varc, &varv); + TclListObjGetElements(NULL, varListObj, &varc, &varv); if (Tcl_ObjSetVar2(interp, varv[0], NULL, keyObj, TCL_LEAVE_ERR_MSG) == NULL) { result = TCL_ERROR; @@ -3699,7 +3699,7 @@ ArrayGetCmd( */ TclNewObj(tmpResObj); - result = Tcl_ListObjGetElements(interp, nameLstObj, &count, &nameObjPtr); + result = TclListObjGetElements(interp, nameLstObj, &count, &nameObjPtr); if (result != TCL_OK) { goto errorInArrayGet; } @@ -4024,7 +4024,7 @@ ArraySetCmd( size_t elemLen; Tcl_Obj **elemPtrs, *copyListObj; - result = Tcl_ListObjGetElements(interp, arrayElemObj, + result = TclListObjGetElements(interp, arrayElemObj, &elemLen, &elemPtrs); if (result != TCL_OK) { return result; -- cgit v0.12 From 8f805cf711937914ecd371343acfe9a4b8f27238 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 10 Feb 2022 09:26:16 +0000 Subject: Use TclListObjLength/TclListObjGetElements in stead of Tcl_ListObjLength/Tcl_ListObjGetElements everywhere. This is slightly more efficient if the refered list already has the correct type --- generic/tclAssembly.c | 2 +- generic/tclBasic.c | 6 +++--- generic/tclCmdMZ.c | 16 ++++++++-------- generic/tclCompCmds.c | 6 +++--- generic/tclCompCmdsSZ.c | 12 ++++++------ generic/tclDictObj.c | 4 ++-- generic/tclDisassemble.c | 2 +- generic/tclEncoding.c | 14 +++++++------- generic/tclEnsemble.c | 12 ++++++------ generic/tclEvent.c | 2 +- generic/tclExecute.c | 2 +- generic/tclFCmd.c | 2 +- generic/tclFileName.c | 18 +++++++++--------- generic/tclIO.c | 2 +- generic/tclIOGT.c | 2 +- generic/tclIORChan.c | 10 +++++----- generic/tclIORTrans.c | 6 +++--- generic/tclIOUtil.c | 10 +++++----- generic/tclIndexObj.c | 10 +++++----- generic/tclInterp.c | 2 +- generic/tclNamesp.c | 4 ++-- generic/tclOODefineCmds.c | 16 ++++++++-------- generic/tclOOMethod.c | 10 +++++----- generic/tclPathObj.c | 6 +++--- generic/tclPkg.c | 4 ++-- generic/tclProc.c | 6 +++--- generic/tclResult.c | 8 ++++---- generic/tclStringObj.c | 2 +- generic/tclTrace.c | 10 +++++----- generic/tclVar.c | 2 +- generic/tclZlib.c | 8 ++++---- 31 files changed, 108 insertions(+), 108 deletions(-) diff --git a/generic/tclAssembly.c b/generic/tclAssembly.c index bf86b90..42c0c47 100644 --- a/generic/tclAssembly.c +++ b/generic/tclAssembly.c @@ -1975,7 +1975,7 @@ CreateMirrorJumpTable( * table. */ int i; - if (Tcl_ListObjGetElements(interp, jumps, &objc, &objv) != TCL_OK) { + if (TclListObjGetElements(interp, jumps, &objc, &objv) != TCL_OK) { return TCL_ERROR; } if (objc % 2 != 0) { diff --git a/generic/tclBasic.c b/generic/tclBasic.c index 5975fd3..33a96eb 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -4715,7 +4715,7 @@ TEOV_NotFound( * itself. */ - Tcl_ListObjGetElements(NULL, currNsPtr->unknownHandlerPtr, + TclListObjGetElements(NULL, currNsPtr->unknownHandlerPtr, &handlerObjc, &handlerObjv); newObjc = objc + handlerObjc; newObjv = (Tcl_Obj **)TclStackAlloc(interp, sizeof(Tcl_Obj *) * newObjc); @@ -5322,7 +5322,7 @@ TclEvalEx( int numElements; Tcl_Obj **elements, *temp = copy[wordIdx]; - Tcl_ListObjGetElements(NULL, temp, &numElements, + TclListObjGetElements(NULL, temp, &numElements, &elements); objectsUsed += numElements; while (numElements--) { @@ -8497,7 +8497,7 @@ TclNRTailcallEval( int objc; Tcl_Obj **objv; - Tcl_ListObjGetElements(interp, listPtr, &objc, &objv); + TclListObjGetElements(interp, listPtr, &objc, &objv); nsObjPtr = objv[0]; if (result == TCL_OK) { diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c index 34fd6bf..c94abbd 100644 --- a/generic/tclCmdMZ.c +++ b/generic/tclCmdMZ.c @@ -4136,7 +4136,7 @@ Tcl_ThrowObjCmd( * The type must be a list of at least length 1. */ - if (Tcl_ListObjLength(interp, objv[1], &len) != TCL_OK) { + if (TclListObjLength(interp, objv[1], &len) != TCL_OK) { return TCL_ERROR; } else if (len < 1) { Tcl_SetObjResult(interp, Tcl_NewStringObj( @@ -4921,7 +4921,7 @@ TclNRTryObjCmd( return TCL_ERROR; } code = 1; - if (Tcl_ListObjLength(NULL, objv[i+1], &dummy) != TCL_OK) { + if (TclListObjLength(NULL, objv[i+1], &dummy) != TCL_OK) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "bad prefix '%s': must be a list", Tcl_GetString(objv[i+1]))); @@ -4933,7 +4933,7 @@ TclNRTryObjCmd( info[2] = objv[i+1]; commonHandler: - if (Tcl_ListObjLength(interp, objv[i+2], &dummy) != TCL_OK) { + if (TclListObjLength(interp, objv[i+2], &dummy) != TCL_OK) { Tcl_DecrRefCount(handlersObj); return TCL_ERROR; } @@ -5083,11 +5083,11 @@ TryPostBody( int found = 0; Tcl_Obj **handlers, **info; - Tcl_ListObjGetElements(NULL, handlersObj, &numHandlers, &handlers); + TclListObjGetElements(NULL, handlersObj, &numHandlers, &handlers); for (i=0 ; i 0) { Tcl_Obj *varName; diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c index f28175b..0f52338 100644 --- a/generic/tclCompCmds.c +++ b/generic/tclCompCmds.c @@ -314,7 +314,7 @@ TclCompileArraySetCmd( TclNewObj(literalObj); isDataLiteral = TclWordKnownAtCompileTime(dataTokenPtr, literalObj); isDataValid = (isDataLiteral - && Tcl_ListObjLength(NULL, literalObj, &len) == TCL_OK); + && TclListObjLength(NULL, literalObj, &len) == TCL_OK); isDataEven = (isDataValid && (len & 1) == 0); /* @@ -907,7 +907,7 @@ TclCompileConcatCmd( const char *bytes; int len; - Tcl_ListObjGetElements(NULL, listObj, &len, &objs); + TclListObjGetElements(NULL, listObj, &len, &objs); objPtr = Tcl_ConcatObj(len, objs); Tcl_DecrRefCount(listObj); bytes = Tcl_GetStringFromObj(objPtr, &len); @@ -2741,7 +2741,7 @@ CompileEachloopCmd( */ if (!TclWordKnownAtCompileTime(tokenPtr, varListObj) || - TCL_OK != Tcl_ListObjLength(NULL, varListObj, &numVars) || + TCL_OK != TclListObjLength(NULL, varListObj, &numVars) || numVars == 0) { code = TCL_ERROR; goto done; diff --git a/generic/tclCompCmdsSZ.c b/generic/tclCompCmdsSZ.c index 862ebb5..8828b59 100644 --- a/generic/tclCompCmdsSZ.c +++ b/generic/tclCompCmdsSZ.c @@ -883,7 +883,7 @@ TclCompileStringMapCmd( if (!TclWordKnownAtCompileTime(mapTokenPtr, mapObj)) { Tcl_DecrRefCount(mapObj); return TclCompileBasic2ArgCmd(interp, parsePtr, cmdPtr, envPtr); - } else if (Tcl_ListObjGetElements(NULL, mapObj, &len, &objv) != TCL_OK) { + } else if (TclListObjGetElements(NULL, mapObj, &len, &objv) != TCL_OK) { Tcl_DecrRefCount(mapObj); return TclCompileBasic2ArgCmd(interp, parsePtr, cmdPtr, envPtr); } else if (len != 2) { @@ -2689,7 +2689,7 @@ TclCompileThrowCmd( CompileWord(envPtr, msgToken, interp, 2); codeIsList = codeKnown && (TCL_OK == - Tcl_ListObjLength(interp, objPtr, &len)); + TclListObjLength(interp, objPtr, &len)); codeIsValid = codeIsList && (len != 0); if (codeIsValid) { @@ -2823,7 +2823,7 @@ TclCompileTryCmd( TclNewObj(tmpObj); Tcl_IncrRefCount(tmpObj); if (!TclWordKnownAtCompileTime(tokenPtr, tmpObj) - || Tcl_ListObjLength(NULL, tmpObj, &objc) != TCL_OK + || TclListObjLength(NULL, tmpObj, &objc) != TCL_OK || (objc == 0)) { TclDecrRefCount(tmpObj); goto failedToCompile; @@ -2866,7 +2866,7 @@ TclCompileTryCmd( TclDecrRefCount(tmpObj); goto failedToCompile; } - if (Tcl_ListObjGetElements(NULL, tmpObj, &objc, &objv) != TCL_OK + if (TclListObjGetElements(NULL, tmpObj, &objc, &objv) != TCL_OK || (objc > 2)) { TclDecrRefCount(tmpObj); goto failedToCompile; @@ -3077,7 +3077,7 @@ IssueTryClausesInstructions( JUMP4( JUMP_FALSE, notCodeJumpSource); if (matchClauses[i]) { const char *p; - Tcl_ListObjLength(NULL, matchClauses[i], &len); + TclListObjLength(NULL, matchClauses[i], &len); /* * Match the errorcode according to try/trap rules. @@ -3288,7 +3288,7 @@ IssueTryClausesFinallyInstructions( OP( EQ); JUMP4( JUMP_FALSE, notCodeJumpSource); if (matchClauses[i]) { - Tcl_ListObjLength(NULL, matchClauses[i], &len); + TclListObjLength(NULL, matchClauses[i], &len); /* * Match the errorcode according to try/trap rules. diff --git a/generic/tclDictObj.c b/generic/tclDictObj.c index becc029..ba9ab98 100644 --- a/generic/tclDictObj.c +++ b/generic/tclDictObj.c @@ -3257,7 +3257,7 @@ FinalizeDictUpdate( * an instruction to remove the key. */ - Tcl_ListObjGetElements(NULL, argsObj, &objc, &objv); + TclListObjGetElements(NULL, argsObj, &objc, &objv); for (i=0 ; ilookupNsPtr = ensemblePtr->nsPtr; return TclNREvalObjv(interp, copyObjc, copyObjv, TCL_EVAL_INVOKE, NULL); } @@ -2598,7 +2598,7 @@ BuildEnsembleConfig( * Must determine the target for each. */ - Tcl_ListObjGetElements(NULL, subList, &subc, &subv); + TclListObjGetElements(NULL, subList, &subc, &subv); if (subList == mapDict) { /* * Strange case where explicit list of subcommands is same value @@ -2992,7 +2992,7 @@ TclCompileEnsemble( const char *str; Tcl_Obj *matchObj = NULL; - if (Tcl_ListObjGetElements(NULL, listObj, &len, &elems) != TCL_OK) { + if (TclListObjGetElements(NULL, listObj, &len, &elems) != TCL_OK) { goto failed; } for (i=0 ; itokenPtr; i < parsePtr->numWords; i++, tokPtr = TokenAfter(tokPtr)) { if (i > 0 && i < numWords+1) { diff --git a/generic/tclEvent.c b/generic/tclEvent.c index e9d760c..3c4ff74 100644 --- a/generic/tclEvent.c +++ b/generic/tclEvent.c @@ -226,7 +226,7 @@ HandleBgErrors( errPtr = assocPtr->firstBgPtr; - Tcl_ListObjGetElements(NULL, copyObj, &prefixObjc, &prefixObjv); + TclListObjGetElements(NULL, copyObj, &prefixObjc, &prefixObjv); tempObjv = (Tcl_Obj**)ckalloc((prefixObjc+2) * sizeof(Tcl_Obj *)); memcpy(tempObjv, prefixObjv, prefixObjc*sizeof(Tcl_Obj *)); tempObjv[prefixObjc] = errPtr->errorMsg; diff --git a/generic/tclExecute.c b/generic/tclExecute.c index e5a6b71..2faf213 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -3240,7 +3240,7 @@ TEBCresume( TclMarkTailcall(interp); TclNRAddCallback(interp, TclClearRootEnsemble, NULL, NULL, NULL, NULL); - Tcl_ListObjGetElements(NULL, objPtr, &objc, &objv); + TclListObjGetElements(NULL, objPtr, &objc, &objv); TclNRAddCallback(interp, TclNRReleaseValues, objPtr, NULL, NULL, NULL); return TclNREvalObjv(interp, objc, objv, TCL_EVAL_INVOKE, NULL); diff --git a/generic/tclFCmd.c b/generic/tclFCmd.c index e2d4164..d58d02d 100644 --- a/generic/tclFCmd.c +++ b/generic/tclFCmd.c @@ -1006,7 +1006,7 @@ TclFileAttrsCmd( * Use objStrings as a list object. */ - if (Tcl_ListObjLength(interp, objStrings, &numObjStrings) != TCL_OK) { + if (TclListObjLength(interp, objStrings, &numObjStrings) != TCL_OK) { goto end; } attributeStringsAllocated = (const char **) diff --git a/generic/tclFileName.c b/generic/tclFileName.c index cfd76e6..b6a6439 100644 --- a/generic/tclFileName.c +++ b/generic/tclFileName.c @@ -517,7 +517,7 @@ TclpNativeSplitPath( */ if (lenPtr != NULL) { - Tcl_ListObjLength(NULL, resultPtr, lenPtr); + TclListObjLength(NULL, resultPtr, lenPtr); } return resultPtr; } @@ -1333,7 +1333,7 @@ Tcl_GlobObjCmd( return TCL_ERROR; } typePtr = objv[i+1]; - if (Tcl_ListObjLength(interp, typePtr, &length) != TCL_OK) { + if (TclListObjLength(interp, typePtr, &length) != TCL_OK) { return TCL_ERROR; } i++; @@ -1455,7 +1455,7 @@ Tcl_GlobObjCmd( * platform. */ - Tcl_ListObjLength(interp, typePtr, &length); + TclListObjLength(interp, typePtr, &length); if (length <= 0) { goto skipTypes; } @@ -1525,7 +1525,7 @@ Tcl_GlobObjCmd( } else { Tcl_Obj *item; - if ((Tcl_ListObjLength(NULL, look, &len) == TCL_OK) + if ((TclListObjLength(NULL, look, &len) == TCL_OK) && (len == 3)) { Tcl_ListObjIndex(interp, look, 0, &item); if (!strcmp("macintosh", Tcl_GetString(item))) { @@ -1632,7 +1632,7 @@ Tcl_GlobObjCmd( } if ((globFlags & TCL_GLOBMODE_NO_COMPLAIN) == 0) { - if (Tcl_ListObjLength(interp, Tcl_GetObjResult(interp), + if (TclListObjLength(interp, Tcl_GetObjResult(interp), &length) != TCL_OK) { /* * This should never happen. Maybe we should be more dramatic. @@ -2015,7 +2015,7 @@ TclGlob( } } - Tcl_ListObjGetElements(NULL, filenamesObj, &objc, &objv); + TclListObjGetElements(NULL, filenamesObj, &objc, &objv); for (i = 0; i< objc; i++) { int len; const char *oldStr = Tcl_GetStringFromObj(objv[i], &len); @@ -2344,13 +2344,13 @@ DoGlob( int subdirc, i, repair = -1; Tcl_Obj **subdirv; - result = Tcl_ListObjGetElements(interp, subdirsPtr, + result = TclListObjGetElements(interp, subdirsPtr, &subdirc, &subdirv); for (i=0; result==TCL_OK && ifsPtr->listVolumesProc(); if (thisFsVolumes != NULL) { - if (Tcl_ListObjLength(NULL, thisFsVolumes, &numVolumes) + if (TclListObjLength(NULL, thisFsVolumes, &numVolumes) != TCL_OK) { /* * This is VERY bad; the listVolumesProc didn't return a diff --git a/generic/tclIndexObj.c b/generic/tclIndexObj.c index 8911f00..b17b224 100644 --- a/generic/tclIndexObj.c +++ b/generic/tclIndexObj.c @@ -184,7 +184,7 @@ GetIndexFromObjList( * of the code there. This is a bit ineffiecient but simpler. */ - result = Tcl_ListObjGetElements(interp, tableObjPtr, &objc, &objv); + result = TclListObjGetElements(interp, tableObjPtr, &objc, &objv); if (result != TCL_OK) { return result; } @@ -588,7 +588,7 @@ PrefixMatchObjCmd( return TCL_ERROR; } i++; - result = Tcl_ListObjLength(interp, objv[i], &errorLength); + result = TclListObjLength(interp, objv[i], &errorLength); if (result != TCL_OK) { return TCL_ERROR; } @@ -612,7 +612,7 @@ PrefixMatchObjCmd( * error case regardless of level. */ - result = Tcl_ListObjLength(interp, tablePtr, &dummyLength); + result = TclListObjLength(interp, tablePtr, &dummyLength); if (result != TCL_OK) { return result; } @@ -677,7 +677,7 @@ PrefixAllObjCmd( return TCL_ERROR; } - result = Tcl_ListObjGetElements(interp, objv[1], &tableObjc, &tableObjv); + result = TclListObjGetElements(interp, objv[1], &tableObjc, &tableObjv); if (result != TCL_OK) { return result; } @@ -734,7 +734,7 @@ PrefixLongestObjCmd( return TCL_ERROR; } - result = Tcl_ListObjGetElements(interp, objv[1], &tableObjc, &tableObjv); + result = TclListObjGetElements(interp, objv[1], &tableObjc, &tableObjv); if (result != TCL_OK) { return result; } diff --git a/generic/tclInterp.c b/generic/tclInterp.c index 271bbf2..11202ce 100644 --- a/generic/tclInterp.c +++ b/generic/tclInterp.c @@ -2326,7 +2326,7 @@ ChildCreate( int isNew, objc; Tcl_Obj **objv; - if (Tcl_ListObjGetElements(interp, pathPtr, &objc, &objv) != TCL_OK) { + if (TclListObjGetElements(interp, pathPtr, &objc, &objv) != TCL_OK) { return NULL; } if (objc < 2) { diff --git a/generic/tclNamesp.c b/generic/tclNamesp.c index bea0043..eccca78 100644 --- a/generic/tclNamesp.c +++ b/generic/tclNamesp.c @@ -4998,7 +4998,7 @@ TclLogCommandInfo( int len; iPtr->resetErrorStack = 0; - Tcl_ListObjLength(interp, iPtr->errorStack, &len); + TclListObjLength(interp, iPtr->errorStack, &len); /* * Reset while keeping the list internalrep as much as possible. @@ -5083,7 +5083,7 @@ TclErrorStackResetIf( int len; iPtr->resetErrorStack = 0; - Tcl_ListObjLength(interp, iPtr->errorStack, &len); + TclListObjLength(interp, iPtr->errorStack, &len); /* * Reset while keeping the list internalrep as much as possible. diff --git a/generic/tclOODefineCmds.c b/generic/tclOODefineCmds.c index c1115be..4b97740 100644 --- a/generic/tclOODefineCmds.c +++ b/generic/tclOODefineCmds.c @@ -865,7 +865,7 @@ MagicDefinitionInvoke( Tcl_ListObjAppendElement(NULL, objPtr, obj2Ptr); /* TODO: overflow? */ Tcl_ListObjReplace(NULL, objPtr, 1, 0, objc - offset, objv + offset); - Tcl_ListObjGetElements(NULL, objPtr, &dummy, &objs); + TclListObjGetElements(NULL, objPtr, &dummy, &objs); result = Tcl_EvalObjv(interp, objc - cmdIndex, objs, TCL_EVAL_INVOKE); if (isRoot) { @@ -1908,7 +1908,7 @@ ClassFilterSet( "attempt to misuse API", -1)); Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL); return TCL_ERROR; - } else if (Tcl_ListObjGetElements(interp, objv[0], &filterc, + } else if (TclListObjGetElements(interp, objv[0], &filterc, &filterv) != TCL_OK) { return TCL_ERROR; } @@ -1991,7 +1991,7 @@ ClassMixinSet( "attempt to misuse API", -1)); Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL); return TCL_ERROR; - } else if (Tcl_ListObjGetElements(interp, objv[0], &mixinc, + } else if (TclListObjGetElements(interp, objv[0], &mixinc, &mixinv) != TCL_OK) { return TCL_ERROR; } @@ -2100,7 +2100,7 @@ ClassSuperSet( "may not modify the superclass of the root object", -1)); Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL); return TCL_ERROR; - } else if (Tcl_ListObjGetElements(interp, objv[0], &superc, + } else if (TclListObjGetElements(interp, objv[0], &superc, &superv) != TCL_OK) { return TCL_ERROR; } @@ -2259,7 +2259,7 @@ ClassVarsSet( "attempt to misuse API", -1)); Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL); return TCL_ERROR; - } else if (Tcl_ListObjGetElements(interp, objv[0], &varc, + } else if (TclListObjGetElements(interp, objv[0], &varc, &varv) != TCL_OK) { return TCL_ERROR; } @@ -2388,7 +2388,7 @@ ObjFilterSet( return TCL_ERROR; } objv += Tcl_ObjectContextSkippedArgs(context); - if (Tcl_ListObjGetElements(interp, objv[0], &filterc, + if (TclListObjGetElements(interp, objv[0], &filterc, &filterv) != TCL_OK) { return TCL_ERROR; } @@ -2461,7 +2461,7 @@ ObjMixinSet( return TCL_ERROR; } objv += Tcl_ObjectContextSkippedArgs(context); - if (Tcl_ListObjGetElements(interp, objv[0], &mixinc, + if (TclListObjGetElements(interp, objv[0], &mixinc, &mixinv) != TCL_OK) { return TCL_ERROR; } @@ -2540,7 +2540,7 @@ ObjVarsSet( return TCL_ERROR; } objv += Tcl_ObjectContextSkippedArgs(context); - if (Tcl_ListObjGetElements(interp, objv[0], &varc, + if (TclListObjGetElements(interp, objv[0], &varc, &varv) != TCL_OK) { return TCL_ERROR; } diff --git a/generic/tclOOMethod.c b/generic/tclOOMethod.c index 80e8478..717aa09 100644 --- a/generic/tclOOMethod.c +++ b/generic/tclOOMethod.c @@ -339,7 +339,7 @@ TclOONewProcInstanceMethod( ProcedureMethod *pmPtr; Tcl_Method method; - if (Tcl_ListObjLength(interp, argsObj, &argsLen) != TCL_OK) { + if (TclListObjLength(interp, argsObj, &argsLen) != TCL_OK) { return NULL; } pmPtr = ckalloc(sizeof(ProcedureMethod)); @@ -397,7 +397,7 @@ TclOONewProcMethod( TclNewObj(argsObj); Tcl_IncrRefCount(argsObj); procName = ""; - } else if (Tcl_ListObjLength(interp, argsObj, &argsLen) != TCL_OK) { + } else if (TclListObjLength(interp, argsObj, &argsLen) != TCL_OK) { return NULL; } else { procName = (nameObj==NULL ? "" : TclGetString(nameObj)); @@ -1367,7 +1367,7 @@ TclOONewForwardInstanceMethod( int prefixLen; ForwardMethod *fmPtr; - if (Tcl_ListObjLength(interp, prefixObj, &prefixLen) != TCL_OK) { + if (TclListObjLength(interp, prefixObj, &prefixLen) != TCL_OK) { return NULL; } if (prefixLen < 1) { @@ -1406,7 +1406,7 @@ TclOONewForwardMethod( int prefixLen; ForwardMethod *fmPtr; - if (Tcl_ListObjLength(interp, prefixObj, &prefixLen) != TCL_OK) { + if (TclListObjLength(interp, prefixObj, &prefixLen) != TCL_OK) { return NULL; } if (prefixLen < 1) { @@ -1454,7 +1454,7 @@ InvokeForwardMethod( * can ignore here. */ - Tcl_ListObjGetElements(NULL, fmPtr->prefixObj, &numPrefixes, &prefixObjs); + TclListObjGetElements(NULL, fmPtr->prefixObj, &numPrefixes, &prefixObjs); argObjs = InitEnsembleRewrite(interp, objc, objv, skip, numPrefixes, prefixObjs, &len); Tcl_NRAddCallback(interp, FinalizeForwardCall, argObjs, NULL, NULL, NULL); diff --git a/generic/tclPathObj.c b/generic/tclPathObj.c index b69607a..372a30d 100644 --- a/generic/tclPathObj.c +++ b/generic/tclPathObj.c @@ -833,12 +833,12 @@ Tcl_FSJoinPath( int objc; Tcl_Obj **objv; - if (Tcl_ListObjLength(NULL, listObj, &objc) != TCL_OK) { + if (TclListObjLength(NULL, listObj, &objc) != TCL_OK) { return NULL; } elements = ((elements >= 0) && (elements <= objc)) ? elements : objc; - Tcl_ListObjGetElements(NULL, listObj, &objc, &objv); + TclListObjGetElements(NULL, listObj, &objc, &objv); res = TclJoinPath(elements, objv, 0); return res; } @@ -2449,7 +2449,7 @@ SetFsPathFromAny( Tcl_Obj **objv; Tcl_Obj *parts = TclpNativeSplitPath(pathPtr, NULL); - Tcl_ListObjGetElements(NULL, parts, &objc, &objv); + TclListObjGetElements(NULL, parts, &objc, &objv); /* * Skip '~'. It's replaced by its expansion. diff --git a/generic/tclPkg.c b/generic/tclPkg.c index 67c91c4..35ec1a3 100644 --- a/generic/tclPkg.c +++ b/generic/tclPkg.c @@ -1132,7 +1132,7 @@ TclNRPackageObjCmd( objvListPtr = Tcl_NewListObj(0, NULL); Tcl_IncrRefCount(objvListPtr); Tcl_ListObjAppendElement(interp, objvListPtr, ov); - Tcl_ListObjGetElements(interp, objvListPtr, &newobjc, &newObjvPtr); + TclListObjGetElements(interp, objvListPtr, &newobjc, &newObjvPtr); Tcl_NRAddCallback(interp, TclNRPackageObjCmdCleanup, objv[3], objvListPtr, NULL, NULL); Tcl_NRAddCallback(interp, PkgRequireCore, (void *)argv3, INT2PTR(newobjc), newObjvPtr, NULL); @@ -1156,7 +1156,7 @@ TclNRPackageObjCmd( Tcl_ListObjAppendElement(interp, objvListPtr, Tcl_DuplicateObj(newobjv[i])); } - Tcl_ListObjGetElements(interp, objvListPtr, &newobjc, &newObjvPtr); + TclListObjGetElements(interp, objvListPtr, &newobjc, &newObjvPtr); Tcl_NRAddCallback(interp, TclNRPackageObjCmdCleanup, objv[2], objvListPtr, NULL, NULL); Tcl_NRAddCallback(interp, PkgRequireCore, (void *)argv2, INT2PTR(newobjc), newObjvPtr, NULL); return TCL_OK; diff --git a/generic/tclProc.c b/generic/tclProc.c index a533878..59153b8 100644 --- a/generic/tclProc.c +++ b/generic/tclProc.c @@ -452,7 +452,7 @@ TclCreateProc( * in the Proc. */ - result = Tcl_ListObjGetElements(interp, argsPtr, &numArgs, &argArray); + result = TclListObjGetElements(interp, argsPtr, &numArgs, &argArray); if (result != TCL_OK) { goto procError; } @@ -482,7 +482,7 @@ TclCreateProc( * Now divide the specifier up into name and default. */ - result = Tcl_ListObjGetElements(interp, argArray[i], &fieldCount, + result = TclListObjGetElements(interp, argArray[i], &fieldCount, &fieldValues); if (result != TCL_OK) { goto procError; @@ -913,7 +913,7 @@ TclNRUplevelObjCmd( return TCL_ERROR; } else if (!TclHasStringRep(objv[1]) && objc == 2) { int status ,llength; - status = Tcl_ListObjLength(interp, objv[1], &llength); + status = TclListObjLength(interp, objv[1], &llength); if (status == TCL_OK && llength > 1) { /* the first argument can't interpreted as a level. Avoid * generating a string representation of the script. */ diff --git a/generic/tclResult.c b/generic/tclResult.c index be84a61..f82e6a4 100644 --- a/generic/tclResult.c +++ b/generic/tclResult.c @@ -1315,12 +1315,12 @@ TclProcessReturn( * if someone does [return -errorstack [info errorstack]] */ - if (Tcl_ListObjGetElements(interp, valuePtr, &valueObjc, + if (TclListObjGetElements(interp, valuePtr, &valueObjc, &valueObjv) == TCL_ERROR) { return TCL_ERROR; } iPtr->resetErrorStack = 0; - Tcl_ListObjLength(interp, iPtr->errorStack, &len); + TclListObjLength(interp, iPtr->errorStack, &len); /* * Reset while keeping the list internalrep as much as possible. @@ -1479,7 +1479,7 @@ TclMergeReturnOptions( if (valuePtr != NULL) { int length; - if (TCL_ERROR == Tcl_ListObjLength(NULL, valuePtr, &length )) { + if (TCL_ERROR == TclListObjLength(NULL, valuePtr, &length )) { /* * Value is not a list, which is illegal for -errorcode. */ @@ -1501,7 +1501,7 @@ TclMergeReturnOptions( if (valuePtr != NULL) { int length; - if (TCL_ERROR == Tcl_ListObjLength(NULL, valuePtr, &length )) { + if (TCL_ERROR == TclListObjLength(NULL, valuePtr, &length )) { /* * Value is not a list, which is illegal for -errorstack. */ diff --git a/generic/tclStringObj.c b/generic/tclStringObj.c index 9e0e4af..8f4bfb2 100644 --- a/generic/tclStringObj.c +++ b/generic/tclStringObj.c @@ -501,7 +501,7 @@ TclCheckEmptyString ( } if (TclIsPureList(objPtr)) { - Tcl_ListObjLength(NULL, objPtr, &length); + TclListObjLength(NULL, objPtr, &length); return length == 0; } diff --git a/generic/tclTrace.c b/generic/tclTrace.c index 5ce4b95..0ed57c1 100644 --- a/generic/tclTrace.c +++ b/generic/tclTrace.c @@ -434,7 +434,7 @@ TraceExecutionObjCmd( * pointer to its array of element pointers. */ - result = Tcl_ListObjGetElements(interp, objv[4], &listLen, &elemPtrs); + result = TclListObjGetElements(interp, objv[4], &listLen, &elemPtrs); if (result != TCL_OK) { return result; } @@ -604,7 +604,7 @@ TraceExecutionObjCmd( TclNewLiteralStringObj(opObj, "leavestep"); Tcl_ListObjAppendElement(NULL, elemObjPtr, opObj); } - Tcl_ListObjLength(NULL, elemObjPtr, &numOps); + TclListObjLength(NULL, elemObjPtr, &numOps); if (0 == numOps) { Tcl_DecrRefCount(elemObjPtr); continue; @@ -675,7 +675,7 @@ TraceCommandObjCmd( * pointer to its array of element pointers. */ - result = Tcl_ListObjGetElements(interp, objv[4], &listLen, &elemPtrs); + result = TclListObjGetElements(interp, objv[4], &listLen, &elemPtrs); if (result != TCL_OK) { return result; } @@ -799,7 +799,7 @@ TraceCommandObjCmd( TclNewLiteralStringObj(opObj, "delete"); Tcl_ListObjAppendElement(NULL, elemObjPtr, opObj); } - Tcl_ListObjLength(NULL, elemObjPtr, &numOps); + TclListObjLength(NULL, elemObjPtr, &numOps); if (0 == numOps) { Tcl_DecrRefCount(elemObjPtr); continue; @@ -874,7 +874,7 @@ TraceVariableObjCmd( * pointer to its array of element pointers. */ - result = Tcl_ListObjGetElements(interp, objv[4], &listLen, &elemPtrs); + result = TclListObjGetElements(interp, objv[4], &listLen, &elemPtrs); if (result != TCL_OK) { return result; } diff --git a/generic/tclVar.c b/generic/tclVar.c index 566e543..a8d6664 100644 --- a/generic/tclVar.c +++ b/generic/tclVar.c @@ -3433,7 +3433,7 @@ ArrayGetCmd( */ TclNewObj(tmpResObj); - result = Tcl_ListObjGetElements(interp, nameLstObj, &count, &nameObjPtr); + result = TclListObjGetElements(interp, nameLstObj, &count, &nameObjPtr); if (result != TCL_OK) { goto errorInArrayGet; } diff --git a/generic/tclZlib.c b/generic/tclZlib.c index ac19449..63a25fa 100644 --- a/generic/tclZlib.c +++ b/generic/tclZlib.c @@ -1355,7 +1355,7 @@ Tcl_ZlibStreamGet( Tcl_DecrRefCount(zshPtr->currentInput); zshPtr->currentInput = NULL; } - Tcl_ListObjLength(NULL, zshPtr->inData, &listLen); + TclListObjLength(NULL, zshPtr->inData, &listLen); if (listLen > 0) { /* * There is more input available, get it from the list and @@ -1404,7 +1404,7 @@ Tcl_ZlibStreamGet( e = inflate(&zshPtr->stream, zshPtr->flush); } }; - Tcl_ListObjLength(NULL, zshPtr->inData, &listLen); + TclListObjLength(NULL, zshPtr->inData, &listLen); while ((zshPtr->stream.avail_out > 0) && (e == Z_OK || e == Z_BUF_ERROR) && (listLen > 0)) { @@ -1484,7 +1484,7 @@ Tcl_ZlibStreamGet( inflateEnd(&zshPtr->stream); } } else { - Tcl_ListObjLength(NULL, zshPtr->outData, &listLen); + TclListObjLength(NULL, zshPtr->outData, &listLen); if (count == -1) { count = 0; for (i=0; i dataPos) && - (Tcl_ListObjLength(NULL, zshPtr->outData, &listLen) == TCL_OK) + (TclListObjLength(NULL, zshPtr->outData, &listLen) == TCL_OK) && (listLen > 0)) { /* * Get the next chunk off our list of chunks and grab the data out -- cgit v0.12 From 1f35ddfe6233a4a056ba3c4e67a4a7563f6d681f Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 10 Feb 2022 14:16:00 +0000 Subject: Use Tcl_NewWideIntObj() for values that might be bigger than 32-bit --- generic/tclIORChan.c | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/generic/tclIORChan.c b/generic/tclIORChan.c index 2e25182..3e2bcbe 100644 --- a/generic/tclIORChan.c +++ b/generic/tclIORChan.c @@ -2111,7 +2111,7 @@ ReflectTruncate( Tcl_Preserve(rcPtr); - lenObj = Tcl_NewIntObj(length); + lenObj = Tcl_NewWideIntObj(length); Tcl_IncrRefCount(lenObj); if (InvokeTclMethod(rcPtr,METH_TRUNCATE,lenObj,NULL,&resObj)!=TCL_OK) { @@ -3361,7 +3361,7 @@ ForwardProc( break; case ForwardedTruncate: { - Tcl_Obj *lenObj = Tcl_NewIntObj(paramPtr->truncate.length); + Tcl_Obj *lenObj = Tcl_NewWideIntObj(paramPtr->truncate.length); Tcl_IncrRefCount(lenObj); Tcl_Preserve(rcPtr); -- cgit v0.12 From 6116d39ecba828dd74944ff5300d625f40deff4b Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 10 Feb 2022 15:17:45 +0000 Subject: Add zlib1.dll for windows-arm64 (cross-compiled with VS2017) --- compat/zlib/win64-arm/zlib1.dll | Bin 0 -> 84480 bytes 1 file changed, 0 insertions(+), 0 deletions(-) create mode 100755 compat/zlib/win64-arm/zlib1.dll diff --git a/compat/zlib/win64-arm/zlib1.dll b/compat/zlib/win64-arm/zlib1.dll new file mode 100755 index 0000000..2abef88 Binary files /dev/null and b/compat/zlib/win64-arm/zlib1.dll differ -- cgit v0.12 From 85cb8c27f27b0f3dab72ab181ba1bed5400e13e5 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 11 Feb 2022 14:22:09 +0000 Subject: See [https://github.com/tcltk/tcl/pull/11], but (hopefully) slightly better --- .github/workflows/win-build.yml | 4 ++-- win/rules.vc | 5 +++++ 2 files changed, 7 insertions(+), 2 deletions(-) diff --git a/.github/workflows/win-build.yml b/.github/workflows/win-build.yml index 370f2de..a470f50 100644 --- a/.github/workflows/win-build.yml +++ b/.github/workflows/win-build.yml @@ -4,7 +4,7 @@ env: ERROR_ON_FAILURES: 1 jobs: msvc: - runs-on: windows-latest + runs-on: windows-2022 defaults: run: shell: powershell @@ -41,7 +41,7 @@ jobs: throw "nmake exit code: $lastexitcode" } gcc: - runs-on: windows-latest + runs-on: windows-2022 defaults: run: shell: msys2 {0} diff --git a/win/rules.vc b/win/rules.vc index 2f01de0..4f103d0 100644 --- a/win/rules.vc +++ b/win/rules.vc @@ -548,10 +548,15 @@ NMAKEHLPC = $(_TCLDIR)\win\nmakehlp.c !endif # NMAKEHLPC +nmakehlp: + $(cc32) -nologo "$(NMAKEHLPC)" -link -subsystem:console + # We always build nmakehlp even if it exists since we do not know # what source it was built from. +!if "$(MACHINE)" == "$(NATIVE_ARCH)" !if [$(cc32) -nologo "$(NMAKEHLPC)" -link -subsystem:console > nul] !endif +!endif ################################################################ # 5. Test for compiler features -- cgit v0.12 From 21db6889635b43cef6b659b974ec0883a551d4e1 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 11 Feb 2022 16:21:35 +0000 Subject: more tweaks for windows-arm64 --- libtommath/tommath.h | 2 +- win/rules.vc | 6 +++--- 2 files changed, 4 insertions(+), 4 deletions(-) diff --git a/libtommath/tommath.h b/libtommath/tommath.h index 22951c9..8ccbb89 100644 --- a/libtommath/tommath.h +++ b/libtommath/tommath.h @@ -37,7 +37,7 @@ extern "C" { #endif /* detect 64-bit mode if possible */ -#if defined(__x86_64__) || defined(_M_X64) || defined(_M_AMD64) || \ +#if defined(__x86_64__) || defined(_M_X64) || defined(_M_AMD64) || defined(_M_ARM64) || \ defined(__powerpc64__) || defined(__ppc64__) || defined(__PPC64__) || \ defined(__s390x__) || defined(__arch64__) || defined(__aarch64__) || \ defined(__sparcv9) || defined(__sparc_v9__) || defined(__sparc64__) || \ diff --git a/win/rules.vc b/win/rules.vc index 4f103d0..b68b6b4 100644 --- a/win/rules.vc +++ b/win/rules.vc @@ -1384,7 +1384,7 @@ OPTDEFINES = $(OPTDEFINES) /DUSE_THREAD_ALLOC=1 OPTDEFINES = $(OPTDEFINES) /DSTATIC_BUILD !elseif $(TCL_VERSION) > 86 OPTDEFINES = $(OPTDEFINES) /DTCL_WITH_EXTERNAL_TOMMATH -!if "$(MACHINE)" == "AMD64" +!if "$(MACHINE)" == "AMD64" || "$(MACHINE)" == "ARM64" OPTDEFINES = $(OPTDEFINES) /DMP_64BIT !endif !endif @@ -1412,7 +1412,7 @@ OPTDEFINES = $(OPTDEFINES) /DTCL_CFG_OPTIMIZED !if $(PROFILE) OPTDEFINES = $(OPTDEFINES) /DTCL_CFG_PROFILED !endif -!if "$(MACHINE)" == "AMD64" +!if "$(MACHINE)" == "AMD64" || "$(MACHINE)" == "ARM64" OPTDEFINES = $(OPTDEFINES) /DTCL_CFG_DO64BIT !endif !if $(VCVERSION) < 1300 @@ -1474,7 +1474,7 @@ cdebug = $(cdebug) -Zi # cwarn includes default warning levels. cwarn = $(WARNINGS) -!if "$(MACHINE)" == "AMD64" +!if "$(MACHINE)" == "AMD64" || "$(MACHINE)" == "ARM64" # Disable pointer<->int warnings related to cast between different sizes # There are a gadzillion of these due to use of ClientData and # clutter up compiler -- cgit v0.12 From 18d3a2a589b6273929881e13028b5c87b1bad96f Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 11 Feb 2022 16:34:26 +0000 Subject: Document how to cross-compile with Visual Studio --- win/README | 7 +++++++ 1 file changed, 7 insertions(+) diff --git a/win/README b/win/README index d332557..f4cdde4 100644 --- a/win/README +++ b/win/README @@ -56,6 +56,13 @@ using it, are in the comments of "makefile.vc". A quick example would be: There is also a Developer Studio workspace and project file, too, if you would like to use them. +If you want to Cross-compile with Visual Studio (e.g. for X86 or ARM64 +targets, but running on AMD64), first set up the environment for +your host machine and compile nmakehlp.exe: + C:\tcl_source\win\>nmake -f makefile.vc nmakehlp +Then go to your cross-compile environment and run the nmake +command again for whatever you want to build. + If you are building with Linux, Cygwin or Msys, you can use the configure script that lives in the win subdirectory. The Linux/Cygwin/Msys based configure/build process works just like the UNIX one, so you will want -- cgit v0.12 From a2fefd7c501decfa882cddf51b77ec0ebb289d0f Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 11 Feb 2022 16:59:53 +0000 Subject: Add more spare unused stub entries --- generic/tcl.decls | 2 +- generic/tclDecls.h | 30 +++++++++++++++++++++++++++--- generic/tclStubInit.c | 10 +++++++++- 3 files changed, 37 insertions(+), 5 deletions(-) diff --git a/generic/tcl.decls b/generic/tcl.decls index fce6fc0..cea6b93 100644 --- a/generic/tcl.decls +++ b/generic/tcl.decls @@ -2111,7 +2111,7 @@ declare 579 { # ----- BASELINE -- FOR -- 8.5.0 ----- # -declare 660 { +declare 668 { void TclUnusedStubEntry(void) } diff --git a/generic/tclDecls.h b/generic/tclDecls.h index b7f9223..7a76c4a 100644 --- a/generic/tclDecls.h +++ b/generic/tclDecls.h @@ -3492,9 +3492,17 @@ EXTERN void Tcl_AppendPrintfToObj(Tcl_Obj *objPtr, /* Slot 657 is reserved */ /* Slot 658 is reserved */ /* Slot 659 is reserved */ +/* Slot 660 is reserved */ +/* Slot 661 is reserved */ +/* Slot 662 is reserved */ +/* Slot 663 is reserved */ +/* Slot 664 is reserved */ +/* Slot 665 is reserved */ +/* Slot 666 is reserved */ +/* Slot 667 is reserved */ #ifndef TclUnusedStubEntry_TCL_DECLARED #define TclUnusedStubEntry_TCL_DECLARED -/* 660 */ +/* 668 */ EXTERN void TclUnusedStubEntry(void); #endif @@ -4192,7 +4200,15 @@ typedef struct TclStubs { VOID *reserved657; VOID *reserved658; VOID *reserved659; - void (*tclUnusedStubEntry) (void); /* 660 */ + VOID *reserved660; + VOID *reserved661; + VOID *reserved662; + VOID *reserved663; + VOID *reserved664; + VOID *reserved665; + VOID *reserved666; + VOID *reserved667; + void (*tclUnusedStubEntry) (void); /* 668 */ } TclStubs; extern TclStubs *tclStubsPtr; @@ -6625,9 +6641,17 @@ extern TclStubs *tclStubsPtr; /* Slot 657 is reserved */ /* Slot 658 is reserved */ /* Slot 659 is reserved */ +/* Slot 660 is reserved */ +/* Slot 661 is reserved */ +/* Slot 662 is reserved */ +/* Slot 663 is reserved */ +/* Slot 664 is reserved */ +/* Slot 665 is reserved */ +/* Slot 666 is reserved */ +/* Slot 667 is reserved */ #ifndef TclUnusedStubEntry #define TclUnusedStubEntry \ - (tclStubsPtr->tclUnusedStubEntry) /* 660 */ + (tclStubsPtr->tclUnusedStubEntry) /* 668 */ #endif #endif /* defined(USE_TCL_STUBS) && !defined(USE_TCL_STUB_PROCS) */ diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c index 6ef561c..1fcd92b 100644 --- a/generic/tclStubInit.c +++ b/generic/tclStubInit.c @@ -1458,7 +1458,15 @@ TclStubs tclStubs = { NULL, /* 657 */ NULL, /* 658 */ NULL, /* 659 */ - TclUnusedStubEntry, /* 660 */ + NULL, /* 660 */ + NULL, /* 661 */ + NULL, /* 662 */ + NULL, /* 663 */ + NULL, /* 664 */ + NULL, /* 665 */ + NULL, /* 666 */ + NULL, /* 667 */ + TclUnusedStubEntry, /* 668 */ }; /* !END!: Do not edit above this line. */ -- cgit v0.12 From 0a7026859d3375cd02acc21c0d0f03732040dda6 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Sat, 12 Feb 2022 18:49:45 +0000 Subject: Fix [1720242] (appears the patch was only partially applied) --- unix/configure | 4 ++-- unix/tcl.m4 | 4 ++-- 2 files changed, 4 insertions(+), 4 deletions(-) diff --git a/unix/configure b/unix/configure index 0b5fa29..11d7ca4 100755 --- a/unix/configure +++ b/unix/configure @@ -8077,11 +8077,11 @@ fi SHLIB_CFLAGS="" if test "$SHARED_BUILD" = 1; then - SHLIB_LD='ld -shared -expect_unresolved "*"' + SHLIB_LD='${CC} -shared' else - SHLIB_LD='ld -non_shared -expect_unresolved "*"' + SHLIB_LD='${CC} -non_shared' fi diff --git a/unix/tcl.m4 b/unix/tcl.m4 index 6305ef7..739dce3 100644 --- a/unix/tcl.m4 +++ b/unix/tcl.m4 @@ -1684,9 +1684,9 @@ AC_DEFUN([SC_CONFIG_CFLAGS], [ # Digital OSF/1 SHLIB_CFLAGS="" AS_IF([test "$SHARED_BUILD" = 1], [ - SHLIB_LD='ld -shared -expect_unresolved "*"' + SHLIB_LD='${CC} -shared' ], [ - SHLIB_LD='ld -non_shared -expect_unresolved "*"' + SHLIB_LD='${CC} -non_shared' ]) SHLIB_SUFFIX=".so" DL_OBJS="tclLoadDl.o" -- cgit v0.12 From 12315d87b5f80a7528bd95f37286f5a657734a1d Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Sun, 13 Feb 2022 22:29:11 +0000 Subject: Make a start supporting aarch64-w64-mingw32-clang (WIP) --- compat/zlib/win64-arm/libz.dll.a | Bin 0 -> 13002 bytes compat/zlib/win64-arm/zlib1.dll | Bin 84480 -> 92672 bytes win/README | 16 +++++----------- win/rules.vc | 9 ++++----- win/x86_64-w64-mingw32-nmakehlp.exe | Bin 0 -> 25600 bytes 5 files changed, 9 insertions(+), 16 deletions(-) create mode 100644 compat/zlib/win64-arm/libz.dll.a create mode 100755 win/x86_64-w64-mingw32-nmakehlp.exe diff --git a/compat/zlib/win64-arm/libz.dll.a b/compat/zlib/win64-arm/libz.dll.a new file mode 100644 index 0000000..b6cbde7 Binary files /dev/null and b/compat/zlib/win64-arm/libz.dll.a differ diff --git a/compat/zlib/win64-arm/zlib1.dll b/compat/zlib/win64-arm/zlib1.dll index 2abef88..7d08dd3 100755 Binary files a/compat/zlib/win64-arm/zlib1.dll and b/compat/zlib/win64-arm/zlib1.dll differ diff --git a/win/README b/win/README index f4cdde4..038a7cb 100644 --- a/win/README +++ b/win/README @@ -21,26 +21,27 @@ In order to compile Tcl for Windows, you need the following: and Visual C++ 6 or newer + (win32 or win64, for IX86/AMD64/ARM64) or Linux + MinGW-w64 [https://www.mingw-w64.org/] - (win32 or win64) + (win32 or win64, for IX86/AMD64) or Cygwin + MinGW-w64 [https://cygwin.com/install.html] - (win32 or win64) + (win32 or win64, for IX86/AMD64) or Darwin + MinGW-w64 [https://www.mingw-w64.org/] - (win32 or win64) + (win32 or win64, for IX86/AMD64) or Msys + MinGW-w64 [https://www.mingw-w64.org/] - (win32 or win64) + (win32 or win64, for IX86/AMD64) In practice, this release is built with Visual C++ 6.0 and the TEA @@ -56,13 +57,6 @@ using it, are in the comments of "makefile.vc". A quick example would be: There is also a Developer Studio workspace and project file, too, if you would like to use them. -If you want to Cross-compile with Visual Studio (e.g. for X86 or ARM64 -targets, but running on AMD64), first set up the environment for -your host machine and compile nmakehlp.exe: - C:\tcl_source\win\>nmake -f makefile.vc nmakehlp -Then go to your cross-compile environment and run the nmake -command again for whatever you want to build. - If you are building with Linux, Cygwin or Msys, you can use the configure script that lives in the win subdirectory. The Linux/Cygwin/Msys based configure/build process works just like the UNIX one, so you will want diff --git a/win/rules.vc b/win/rules.vc index b68b6b4..22aa735 100644 --- a/win/rules.vc +++ b/win/rules.vc @@ -77,7 +77,7 @@ NEED_TK_SOURCE = 0 # 2. Figure out our build structure in terms of the directory, whether # we are building Tcl or an extension, etc. # 3. Determine the compiler and linker versions -# 4. Build the nmakehlp helper application +# 4. Build the nmakehlp helper application (if not cross-compiling) # 5. Determine the supported compiler options and features # 6. Parse the OPTS macro value for user-specified build configuration # 7. Parse the STATS macro value for statistics instrumentation @@ -548,13 +548,12 @@ NMAKEHLPC = $(_TCLDIR)\win\nmakehlp.c !endif # NMAKEHLPC -nmakehlp: - $(cc32) -nologo "$(NMAKEHLPC)" -link -subsystem:console - # We always build nmakehlp even if it exists since we do not know # what source it was built from. !if "$(MACHINE)" == "$(NATIVE_ARCH)" -!if [$(cc32) -nologo "$(NMAKEHLPC)" -link -subsystem:console > nul] +!if [$(cc32) -nologo "$(NMAKEHLPC)" -link -subsystem:console >NUL] +#else +!if [COPY "$(NMAKEHLPC)$(NMAKEHLPC:nmakehlp.c=x86_64-w64-mingw32-nmakehlp.exe)" nmakehlp.exe] !endif !endif diff --git a/win/x86_64-w64-mingw32-nmakehlp.exe b/win/x86_64-w64-mingw32-nmakehlp.exe new file mode 100755 index 0000000..2564ec9 Binary files /dev/null and b/win/x86_64-w64-mingw32-nmakehlp.exe differ -- cgit v0.12 From 780dda171fc31acc8215cfa314f04c4c44875c96 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Sun, 13 Feb 2022 22:46:17 +0000 Subject: Fix determination of HAVE_CPUID with configure script --- win/configure | 2 +- win/tcl.m4 | 4 ++-- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/win/configure b/win/configure index f815682..ab9771f 100755 --- a/win/configure +++ b/win/configure @@ -3477,7 +3477,7 @@ echo "${ECHO_T}$ac_cv_win32" >&6 echo "$as_me: error: ${CC} cannot produce win32 executables." >&2;} { (exit 1); exit 1; }; } fi - if test "$MACHINE" != "ARM64"; then + if test "$do64bit" != "arm64"; then extra_cflags="$extra_cflags -DHAVE_CPUID=1" fi diff --git a/win/tcl.m4 b/win/tcl.m4 index 26702b6..ddf57f7 100644 --- a/win/tcl.m4 +++ b/win/tcl.m4 @@ -583,7 +583,7 @@ AC_DEFUN([SC_CONFIG_CFLAGS], [ RC="x86_64-w64-mingw32-windres" ;; arm64|aarch64) - CC="aarch64-w64-mingw32-${CC}" + CC="aarch64-w64-mingw32-clang" LD="aarch64-w64-mingw32-ld" AR="aarch64-w64-mingw32-ar" RANLIB="aarch64-w64-mingw32-ranlib" @@ -649,7 +649,7 @@ AC_DEFUN([SC_CONFIG_CFLAGS], [ if test "$ac_cv_win32" != "yes"; then AC_MSG_ERROR([${CC} cannot produce win32 executables.]) fi - if test "$MACHINE" != "ARM64"; then + if test "$do64bit" != "arm64"; then extra_cflags="$extra_cflags -DHAVE_CPUID=1" fi -- cgit v0.12 From 42b02c426ce627a263ba827a896f81bad0ebdb4d Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Sun, 13 Feb 2022 23:07:51 +0000 Subject: Add libtommath.dll and libtommath.dll.a for windows-arm64 --- libtommath/win64-arm/libtommath.dll | Bin 0 -> 69120 bytes libtommath/win64-arm/libtommath.dll.a | Bin 0 -> 20816 bytes 2 files changed, 0 insertions(+), 0 deletions(-) create mode 100755 libtommath/win64-arm/libtommath.dll create mode 100644 libtommath/win64-arm/libtommath.dll.a diff --git a/libtommath/win64-arm/libtommath.dll b/libtommath/win64-arm/libtommath.dll new file mode 100755 index 0000000..99c57a2 Binary files /dev/null and b/libtommath/win64-arm/libtommath.dll differ diff --git a/libtommath/win64-arm/libtommath.dll.a b/libtommath/win64-arm/libtommath.dll.a new file mode 100644 index 0000000..611522e Binary files /dev/null and b/libtommath/win64-arm/libtommath.dll.a differ -- cgit v0.12 From 7bc41fba5b8194878cdcaa64ad0c4d93e91180b6 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 14 Feb 2022 12:59:58 +0000 Subject: Fix [c59fd034fd]: zdll.lib for windows arm64 is compiled for wrong architecture --- compat/zlib/win64-arm/zdll.lib | Bin 16732 -> 16740 bytes 1 file changed, 0 insertions(+), 0 deletions(-) diff --git a/compat/zlib/win64-arm/zdll.lib b/compat/zlib/win64-arm/zdll.lib index a1b6c50..0fe0140 100755 Binary files a/compat/zlib/win64-arm/zdll.lib and b/compat/zlib/win64-arm/zdll.lib differ -- cgit v0.12 From 46007941c79dfbd5c661d1f46888db7d54730d2e Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 14 Feb 2022 13:54:14 +0000 Subject: Fix tommath.lib, which is missing some (deprecated) symbols. --- libtommath/tommath.def | 11 +++++++++++ libtommath/win64-arm/tommath.lib | Bin 26734 -> 28856 bytes 2 files changed, 11 insertions(+) diff --git a/libtommath/tommath.def b/libtommath/tommath.def index 229fae4..879767f 100644 --- a/libtommath/tommath.def +++ b/libtommath/tommath.def @@ -143,3 +143,14 @@ EXPORTS mp_unpack mp_xor mp_zero + s_mp_mul_digs + s_mp_sub + s_mp_add + s_mp_toom_mul + s_mp_mul_digs_fast + s_mp_karatsuba_mul + s_mp_sqr_fast + s_mp_reverse + s_mp_karatsuba_sqr + s_mp_toom_sqr + s_mp_sqr diff --git a/libtommath/win64-arm/tommath.lib b/libtommath/win64-arm/tommath.lib index 2721c6c..f14fbe7 100644 Binary files a/libtommath/win64-arm/tommath.lib and b/libtommath/win64-arm/tommath.lib differ -- cgit v0.12 From a6d654648aac247aba2e0877bd39aa807d5d31c7 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 14 Feb 2022 14:17:20 +0000 Subject: re-generate configure script for windows --- win/configure | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/win/configure b/win/configure index ab9771f..c553cb7 100755 --- a/win/configure +++ b/win/configure @@ -3353,7 +3353,7 @@ echo "${ECHO_T}$ac_cv_cross" >&6 RC="x86_64-w64-mingw32-windres" ;; arm64|aarch64) - CC="aarch64-w64-mingw32-${CC}" + CC="aarch64-w64-mingw32-clang" LD="aarch64-w64-mingw32-ld" AR="aarch64-w64-mingw32-ar" RANLIB="aarch64-w64-mingw32-ranlib" -- cgit v0.12 From 1335b4e324414f01c2f79058a90d4ad3c43aecf3 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 14 Feb 2022 15:28:25 +0000 Subject: Re-build zlib and libtommath for AMD64 and ARM64 to use the UCRT runtime (with llvm-clang toolset) --- compat/zlib/win64-arm/zlib1.dll | Bin 92672 -> 92672 bytes compat/zlib/win64/libz.dll.a | Bin 51638 -> 13002 bytes compat/zlib/win64/zlib1.dll | Bin 116736 -> 99840 bytes libtommath/win64-arm/libtommath.dll | Bin 69120 -> 69120 bytes libtommath/win64-arm/libtommath.dll.a | Bin 20816 -> 22478 bytes libtommath/win64/libtommath.dll | Bin 81408 -> 80896 bytes libtommath/win64/libtommath.dll.a | Bin 128166 -> 22478 bytes 7 files changed, 0 insertions(+), 0 deletions(-) diff --git a/compat/zlib/win64-arm/zlib1.dll b/compat/zlib/win64-arm/zlib1.dll index 7d08dd3..1f43308 100755 Binary files a/compat/zlib/win64-arm/zlib1.dll and b/compat/zlib/win64-arm/zlib1.dll differ diff --git a/compat/zlib/win64/libz.dll.a b/compat/zlib/win64/libz.dll.a index 93be06e..b0c8722 100644 Binary files a/compat/zlib/win64/libz.dll.a and b/compat/zlib/win64/libz.dll.a differ diff --git a/compat/zlib/win64/zlib1.dll b/compat/zlib/win64/zlib1.dll index 81195c3..e893cff 100755 Binary files a/compat/zlib/win64/zlib1.dll and b/compat/zlib/win64/zlib1.dll differ diff --git a/libtommath/win64-arm/libtommath.dll b/libtommath/win64-arm/libtommath.dll index 99c57a2..37bccf7 100755 Binary files a/libtommath/win64-arm/libtommath.dll and b/libtommath/win64-arm/libtommath.dll differ diff --git a/libtommath/win64-arm/libtommath.dll.a b/libtommath/win64-arm/libtommath.dll.a index 611522e..0108f90 100644 Binary files a/libtommath/win64-arm/libtommath.dll.a and b/libtommath/win64-arm/libtommath.dll.a differ diff --git a/libtommath/win64/libtommath.dll b/libtommath/win64/libtommath.dll index 2225faf..ace8fce 100755 Binary files a/libtommath/win64/libtommath.dll and b/libtommath/win64/libtommath.dll differ diff --git a/libtommath/win64/libtommath.dll.a b/libtommath/win64/libtommath.dll.a index 40adaf7..81be3c8 100644 Binary files a/libtommath/win64/libtommath.dll.a and b/libtommath/win64/libtommath.dll.a differ -- cgit v0.12 From 11416a8c3aba74bef614771e7e212ebcc4632e7a Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 14 Feb 2022 15:39:52 +0000 Subject: Use TCLSH_NATIVE for building the zip-file when cross-compiling --- win/makefile.vc | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/win/makefile.vc b/win/makefile.vc index 68c2aa7..ee29360 100644 --- a/win/makefile.vc +++ b/win/makefile.vc @@ -603,7 +603,7 @@ $(TCLSCRIPTZIP): $(TCLDDELIB) $(TCLREGLIB) !endif @echo file delete -force {$@} > "$(OUT_DIR)\zipper.tcl" @echo zipfs mkzip {$@} {$(LIBTCLVFS)} {$(LIBTCLVFS)} >> "$(OUT_DIR)\zipper.tcl" - @cd "$(OUT_DIR)" && $(TCLSH) zipper.tcl + @cd "$(OUT_DIR)" && $(TCLSH_NATIVE) zipper.tcl pkgs: -- cgit v0.12 From 0fdf8385dfdc3e8f0c7a529590f0e61fcfd40525 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 14 Feb 2022 15:44:03 +0000 Subject: Fix regression caused by [d109376ad]: Move nmakehlp target down, so it doesn't become the default target. --- win/rules.vc | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/win/rules.vc b/win/rules.vc index b68b6b4..f8236f4 100644 --- a/win/rules.vc +++ b/win/rules.vc @@ -548,9 +548,6 @@ NMAKEHLPC = $(_TCLDIR)\win\nmakehlp.c !endif # NMAKEHLPC -nmakehlp: - $(cc32) -nologo "$(NMAKEHLPC)" -link -subsystem:console - # We always build nmakehlp even if it exists since we do not know # what source it was built from. !if "$(MACHINE)" == "$(NATIVE_ARCH)" @@ -1613,6 +1610,9 @@ DEFAULT_BUILD_TARGET = $(PROJECT) default-target: $(DEFAULT_BUILD_TARGET) +nmakehlp: + $(cc32) -nologo "$(NMAKEHLPC)" -link -subsystem:console + !if $(MULTIPLATFORM_INSTALL) default-pkgindex: @echo if {[package vsatisfies [package provide Tcl] 9.0-]} { > $(OUT_DIR)\pkgIndex.tcl -- cgit v0.12 From 79389c01abf1f00ab5d29c677bd86acfe618bd7b Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 14 Feb 2022 17:17:05 +0000 Subject: Correct references to libtommath.dll.a/tommath.lib, depending on compiler (was OK for zlib) --- win/configure | 12 ++++++++---- win/configure.ac | 6 ++++-- 2 files changed, 12 insertions(+), 6 deletions(-) diff --git a/win/configure b/win/configure index 3ae3d41..56342c0 100755 --- a/win/configure +++ b/win/configure @@ -4958,15 +4958,17 @@ then : ZLIB_LIBS=\${ZLIB_DIR_NATIVE}/win64-arm/libz.dll.a + TOMMATH_LIBS=\${TOMMATH_DIR_NATIVE}/win64-arm/libtommath.dll.a + else $as_nop ZLIB_LIBS=\${ZLIB_DIR_NATIVE}/win64-arm/zdll.lib + TOMMATH_LIBS=\${TOMMATH_DIR_NATIVE}/win64-arm/tommath.lib -fi - TOMMATH_LIBS=\${TOMMATH_DIR_NATIVE}/win64/libtommath.dll.a +fi else $as_nop @@ -4975,15 +4977,17 @@ then : ZLIB_LIBS=\${ZLIB_DIR_NATIVE}/win64/libz.dll.a + TOMMATH_LIBS=\${TOMMATH_DIR_NATIVE}/win64/libtommath.dll.a + else $as_nop ZLIB_LIBS=\${ZLIB_DIR_NATIVE}/win64/zdll.lib + TOMMATH_LIBS=\${TOMMATH_DIR_NATIVE}/win64/tommath.lib -fi - TOMMATH_LIBS=\${TOMMATH_DIR_NATIVE}/win64/tommath.lib +fi fi diff --git a/win/configure.ac b/win/configure.ac index 87b6780..01f70b4 100644 --- a/win/configure.ac +++ b/win/configure.ac @@ -144,17 +144,19 @@ AS_IF([test "$tcl_ok" = "yes"], [ AS_IF([test "$do64bit" = "arm64"], [ AS_IF([test "$GCC" == "yes"],[ AC_SUBST(ZLIB_LIBS,[\${ZLIB_DIR_NATIVE}/win64-arm/libz.dll.a]) + AC_SUBST(TOMMATH_LIBS,[\${TOMMATH_DIR_NATIVE}/win64-arm/libtommath.dll.a]) ], [ AC_SUBST(ZLIB_LIBS,[\${ZLIB_DIR_NATIVE}/win64-arm/zdll.lib]) + AC_SUBST(TOMMATH_LIBS,[\${TOMMATH_DIR_NATIVE}/win64-arm/tommath.lib]) ]) - AC_SUBST(TOMMATH_LIBS,[\${TOMMATH_DIR_NATIVE}/win64/libtommath.dll.a]) ], [ AS_IF([test "$GCC" == "yes"],[ AC_SUBST(ZLIB_LIBS,[\${ZLIB_DIR_NATIVE}/win64/libz.dll.a]) + AC_SUBST(TOMMATH_LIBS,[\${TOMMATH_DIR_NATIVE}/win64/libtommath.dll.a]) ], [ AC_SUBST(ZLIB_LIBS,[\${ZLIB_DIR_NATIVE}/win64/zdll.lib]) + AC_SUBST(TOMMATH_LIBS,[\${TOMMATH_DIR_NATIVE}/win64/tommath.lib]) ]) - AC_SUBST(TOMMATH_LIBS,[\${TOMMATH_DIR_NATIVE}/win64/tommath.lib]) ]) ], [ AC_SUBST(ZLIB_LIBS,[\${ZLIB_DIR_NATIVE}/win32/zdll.lib]) -- cgit v0.12 From e67e9e8530f03686180b8523847e1a933db359e0 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 14 Feb 2022 17:53:01 +0000 Subject: Always produce windows binaries on windows-2019, even if windows-latest switches to windows-2022 --- .github/workflows/onefiledist.yml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.github/workflows/onefiledist.yml b/.github/workflows/onefiledist.yml index b6b3614..8bd8ed2 100644 --- a/.github/workflows/onefiledist.yml +++ b/.github/workflows/onefiledist.yml @@ -100,7 +100,7 @@ jobs: path: 1dist/*.dmg win: name: Windows - runs-on: windows-latest + runs-on: windows-2019 defaults: run: shell: msys2 {0} -- cgit v0.12 From b5898cc4d07090ca5d742abc116dd57baa086abc Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 15 Feb 2022 13:18:01 +0000 Subject: See [https://patch-diff.githubusercontent.com/raw/tcltk/tcl/pull/12.patch], but slightly better: If cross-compiling for ARM64, we must be on AMD64, so just use a pre-compile nmakehlp executable --- win/rules.vc | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/win/rules.vc b/win/rules.vc index f8236f4..372d70a 100644 --- a/win/rules.vc +++ b/win/rules.vc @@ -550,9 +550,12 @@ NMAKEHLPC = $(_TCLDIR)\win\nmakehlp.c # We always build nmakehlp even if it exists since we do not know # what source it was built from. -!if "$(MACHINE)" == "$(NATIVE_ARCH)" +!if "$(MACHINE)" == "IX86" || "$(MACHINE)" == "$(NATIVE_ARCH)" !if [$(cc32) -nologo "$(NMAKEHLPC)" -link -subsystem:console > nul] !endif +!else +!if [copy $(NMAKEHLPC:nmakehlp.c=x86_64-w64-mingw32-nmakehlp.exe) nmakehlp.exe >NUL] +!endif !endif ################################################################ @@ -1610,9 +1613,6 @@ DEFAULT_BUILD_TARGET = $(PROJECT) default-target: $(DEFAULT_BUILD_TARGET) -nmakehlp: - $(cc32) -nologo "$(NMAKEHLPC)" -link -subsystem:console - !if $(MULTIPLATFORM_INSTALL) default-pkgindex: @echo if {[package vsatisfies [package provide Tcl] 9.0-]} { > $(OUT_DIR)\pkgIndex.tcl -- cgit v0.12 From dff07b745999cb6df94a2fbe5ef2a22a9f7e24f3 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 15 Feb 2022 13:51:02 +0000 Subject: Add nmakehlp.exe (for AMD64) to distribution, and make it usable in rules-ext.vc too --- unix/Makefile.in | 3 ++- win/makefile.vc | 1 + win/rules-ext.vc | 5 +++++ 3 files changed, 8 insertions(+), 1 deletion(-) diff --git a/unix/Makefile.in b/unix/Makefile.in index 74df6fb..0ab3e9b 100644 --- a/unix/Makefile.in +++ b/unix/Makefile.in @@ -2141,7 +2141,8 @@ dist: $(UNIX_DIR)/configure $(UNIX_DIR)/tclConfig.h.in $(UNIX_DIR)/tcl.pc.in gen $(TOP_DIR)/win/tcl.m4 $(TOP_DIR)/win/aclocal.m4 \ $(TOP_DIR)/win/tclsh.exe.manifest.in $(TOP_DIR)/win/tclUuid.h.in \ $(TOP_DIR)/win/gitmanifest.in $(TOP_DIR)/win/svnmanifest.in \ - $(DISTDIR)/win + $(TOP_DIR)/win/x86_64-w64-mingw32-nmakehlp.exe $(DISTDIR)/win + chmod 775 $(DISTDIR)/win/x86_64-w64-mingw32-nmakehlp.exe cp -p $(TOP_DIR)/win/*.[ch] $(TOP_DIR)/win/*.ico $(TOP_DIR)/win/*.rc \ $(DISTDIR)/win cp -p $(TOP_DIR)/win/*.bat $(DISTDIR)/win diff --git a/win/makefile.vc b/win/makefile.vc index a4de4c2..395a9ca 100644 --- a/win/makefile.vc +++ b/win/makefile.vc @@ -945,6 +945,7 @@ install-libraries: tclConfig tcl-nmake install-msgs install-tzdata @$(CPY) "$(WIN_DIR)\rules.vc" "$(LIB_INSTALL_DIR)\nmake\" @$(CPY) "$(WIN_DIR)\targets.vc" "$(LIB_INSTALL_DIR)\nmake\" @$(CPY) "$(WIN_DIR)\nmakehlp.c" "$(LIB_INSTALL_DIR)\nmake\" + @$(CPY) "$(WIN_DIR)\x86_64-w64-mingw32-nmakehlp.exe" "$(LIB_INSTALL_DIR)\nmake\" @$(CPY) "$(OUT_DIR)\tcl.nmake" "$(LIB_INSTALL_DIR)\nmake\" @echo Installing package http 1.0 (obsolete) @$(CPY) "$(ROOT)\library\http1.0\*.tcl" \ diff --git a/win/rules-ext.vc b/win/rules-ext.vc index 6da5689..6d31a03 100644 --- a/win/rules-ext.vc +++ b/win/rules-ext.vc @@ -31,8 +31,13 @@ macro to the name of the project makefile. # We extract version numbers using the nmakehlp program. For now use # the local copy of nmakehlp. Once we locate Tcl, we will use that # one if it is newer. +!if "$(MACHINE)" == "IX86" || "$(MACHINE)" == "$(NATIVE_ARCH)" !if [$(CC) -nologo -DNDEBUG "nmakehlp.c" -link -subsystem:console > nul] !endif +!else +!if [copy x86_64-w64-mingw32-nmakehlp.exe nmakehlp.exe >NUL] +!endif +!endif # First locate the Tcl directory that we are working with. !if "$(TCLDIR)" != "" -- cgit v0.12 From bf79ff2fca084ddd73434bb646d06f73e0f8380e Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 15 Feb 2022 14:09:11 +0000 Subject: update README --- win/README | 17 ++++++++--------- 1 file changed, 8 insertions(+), 9 deletions(-) diff --git a/win/README b/win/README index f4cdde4..92cb2c6 100644 --- a/win/README +++ b/win/README @@ -42,6 +42,11 @@ In order to compile Tcl for Windows, you need the following: Msys + MinGW-w64 [https://www.mingw-w64.org/] (win32 or win64) + or + + LLVM MinGW [https://github.com/mstorsjo/llvm-mingw/] + (win32 or win64, IX86, AMD64 or ARM64) + In practice, this release is built with Visual C++ 6.0 and the TEA Makefile. @@ -56,21 +61,15 @@ using it, are in the comments of "makefile.vc". A quick example would be: There is also a Developer Studio workspace and project file, too, if you would like to use them. -If you want to Cross-compile with Visual Studio (e.g. for X86 or ARM64 -targets, but running on AMD64), first set up the environment for -your host machine and compile nmakehlp.exe: - C:\tcl_source\win\>nmake -f makefile.vc nmakehlp -Then go to your cross-compile environment and run the nmake -command again for whatever you want to build. - If you are building with Linux, Cygwin or Msys, you can use the configure script that lives in the win subdirectory. The Linux/Cygwin/Msys based configure/build process works just like the UNIX one, so you will want to refer to ../unix/README for available configure options. If you want 64-bit executables (x86_64), you need to configure using -the --enable-64bit option. Make sure that the x86_64-w64-mingw32 -compiler is present. For Cygwin this compiler can be found in the +the --enable-64bit (or --enable-64bit=arm64) option. Make sure that +the x86_64-w64-mingw32 (or aarch64-w64-mingw32) compiler is present. +For Cygwin the x86_64 compiler can be found in the "mingw64-x86_64-gcc-core" package, which can be installed through the normal Cygwin install process. If you only want 32-bit executables, the "mingw64-i686-gcc-core" package is what you need. For Linux, Darwin -- cgit v0.12 From 2cee7e53be159d0339af06053e2c02673780ad92 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 15 Feb 2022 14:31:42 +0000 Subject: Update win/README --- win/README | 23 +++++++++++------------ 1 file changed, 11 insertions(+), 12 deletions(-) diff --git a/win/README b/win/README index f4cdde4..86e9e59 100644 --- a/win/README +++ b/win/README @@ -42,6 +42,11 @@ In order to compile Tcl for Windows, you need the following: Msys + MinGW-w64 [https://www.mingw-w64.org/] (win32 or win64) + or + + LLVM MinGW [https://github.com/mstorsjo/llvm-mingw/] + (win32 or win64, IX86, AMD64 or ARM64) + In practice, this release is built with Visual C++ 6.0 and the TEA Makefile. @@ -56,21 +61,15 @@ using it, are in the comments of "makefile.vc". A quick example would be: There is also a Developer Studio workspace and project file, too, if you would like to use them. -If you want to Cross-compile with Visual Studio (e.g. for X86 or ARM64 -targets, but running on AMD64), first set up the environment for -your host machine and compile nmakehlp.exe: - C:\tcl_source\win\>nmake -f makefile.vc nmakehlp -Then go to your cross-compile environment and run the nmake -command again for whatever you want to build. - If you are building with Linux, Cygwin or Msys, you can use the configure script that lives in the win subdirectory. The Linux/Cygwin/Msys based configure/build process works just like the UNIX one, so you will want to refer to ../unix/README for available configure options. If you want 64-bit executables (x86_64), you need to configure using -the --enable-64bit option. Make sure that the x86_64-w64-mingw32 -compiler is present. For Cygwin this compiler can be found in the +the --enable-64bit (or --enable-64bit=arm64) option. Make sure that +the x86_64-w64-mingw32 (or aarch64-w64-mingw32) compiler is present. +For Cygwin the x86_64 compiler can be found in the "mingw64-x86_64-gcc-core" package, which can be installed through the normal Cygwin install process. If you only want 32-bit executables, the "mingw64-i686-gcc-core" package is what you need. For Linux, Darwin @@ -81,9 +80,9 @@ Use the Makefile "install" target to install Tcl. It will install it according to the prefix options you provided in the correct directory structure. -Note that in order to run tclsh86.exe, you must ensure that tcl86.dll is -on your path, in the system directory, or in the directory containing -tclsh86.exe. +Note that in order to run tclsh86.exe, you must ensure that tcl86.dll +and zlib1.dll are on your path, in the system directory, or in the +directory containing tclsh86.exe. Note: Tcl no longer provides support for Win32s. -- cgit v0.12 From 6cf6873784a9c4f2488341b1fbf6bc8864d24eb1 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 15 Feb 2022 15:04:48 +0000 Subject: Tcl 8.7 requires Visual Studio 2015 or newer --- win/README | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/win/README b/win/README index 3f27f66..3cfcc15 100644 --- a/win/README +++ b/win/README @@ -20,7 +20,7 @@ In order to compile Tcl for Windows, you need the following: and - Visual C++ 6 or newer + Visual Studio 2015 or newer or -- cgit v0.12 From 9d7c90707095d35a8f27a6675b2e360c3cb486d2 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 16 Feb 2022 14:33:57 +0000 Subject: Fix [7deeddb36]: signed integer overflow in Tcl_ScanObjCmd() --- generic/tclScan.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/generic/tclScan.c b/generic/tclScan.c index 6ab17bd..f6ff7a9 100644 --- a/generic/tclScan.c +++ b/generic/tclScan.c @@ -923,7 +923,7 @@ Tcl_ScanObjCmd( if (Tcl_GetWideIntFromObj(NULL, objPtr, &wideValue) != TCL_OK) { wideValue = ~(Tcl_WideUInt)0 >> 1; /* WIDE_MAX */ if (TclGetString(objPtr)[0] == '-') { - wideValue++; /* WIDE_MAX + 1 = WIDE_MIN */ + wideValue += 1U; /* WIDE_MAX + 1 = WIDE_MIN */ } } if ((flags & SCAN_UNSIGNED) && (wideValue < 0)) { -- cgit v0.12 From 530446f68e748c71bcd26835ca42576d1dbdc17e Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 16 Feb 2022 14:53:26 +0000 Subject: Fix [89de498973]: signed integer overflow in TclParseNumber() --- generic/tclStrToD.c | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/generic/tclStrToD.c b/generic/tclStrToD.c index 372fe77..1a1c2ac 100644 --- a/generic/tclStrToD.c +++ b/generic/tclStrToD.c @@ -1312,7 +1312,7 @@ TclParseNumber( objPtr->typePtr = &tclWideIntType; if (signum) { objPtr->internalRep.wideValue = - - (Tcl_WideInt) octalSignificandWide; + (Tcl_WideInt) (-octalSignificandWide); } else { objPtr->internalRep.wideValue = (Tcl_WideInt) octalSignificandWide; @@ -1327,7 +1327,7 @@ TclParseNumber( objPtr->typePtr = &tclIntType; if (signum) { objPtr->internalRep.longValue = - - (long) octalSignificandWide; + (long) (-octalSignificandWide); } else { objPtr->internalRep.longValue = (long) octalSignificandWide; @@ -1359,7 +1359,7 @@ TclParseNumber( objPtr->typePtr = &tclWideIntType; if (signum) { objPtr->internalRep.wideValue = - - (Tcl_WideInt) significandWide; + (Tcl_WideInt) (-significandWide); } else { objPtr->internalRep.wideValue = (Tcl_WideInt) significandWide; @@ -1374,7 +1374,7 @@ TclParseNumber( objPtr->typePtr = &tclIntType; if (signum) { objPtr->internalRep.longValue = - - (long) significandWide; + (long) (-significandWide); } else { objPtr->internalRep.longValue = (long) significandWide; -- cgit v0.12 From d203d159b9f52796cd28cad53f0c6d777caadf11 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 16 Feb 2022 15:24:35 +0000 Subject: Fix [c6fea6ba6]: possible signed integer overflow in Tcl_GetLongFromObj(), Tcl_GetWideIntFromObj() --- generic/tclObj.c | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/generic/tclObj.c b/generic/tclObj.c index 1fd674f..029d3c0 100644 --- a/generic/tclObj.c +++ b/generic/tclObj.c @@ -2816,7 +2816,7 @@ Tcl_GetLongFromObj( value = (value << CHAR_BIT) | *bytes++; } if (big.sign) { - *longPtr = - (long) value; + *longPtr = (long) (0-value); } else { *longPtr = (long) value; } @@ -3116,7 +3116,7 @@ Tcl_GetWideIntFromObj( value = (value << CHAR_BIT) | *bytes++; } if (big.sign) { - *wideIntPtr = - (Tcl_WideInt) value; + *wideIntPtr = (Tcl_WideInt) (0-value); } else { *wideIntPtr = (Tcl_WideInt) value; } -- cgit v0.12 From 247cb91a652499e2b90c89568c3995206148c28c Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 16 Feb 2022 16:10:22 +0000 Subject: Fix [1c60dca341]: signed integer overflow in Tcl_SetBignumObj() --- generic/tclObj.c | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/generic/tclObj.c b/generic/tclObj.c index 029d3c0..f7bb44c 100644 --- a/generic/tclObj.c +++ b/generic/tclObj.c @@ -2816,7 +2816,7 @@ Tcl_GetLongFromObj( value = (value << CHAR_BIT) | *bytes++; } if (big.sign) { - *longPtr = (long) (0-value); + *longPtr = (long) (-value); } else { *longPtr = (long) value; } @@ -3116,7 +3116,7 @@ Tcl_GetWideIntFromObj( value = (value << CHAR_BIT) | *bytes++; } if (big.sign) { - *wideIntPtr = (Tcl_WideInt) (0-value); + *wideIntPtr = (Tcl_WideInt) (-value); } else { *wideIntPtr = (Tcl_WideInt) value; } @@ -3547,7 +3547,7 @@ Tcl_SetBignumObj( goto tooLargeForLong; } if (bignumValue->sign) { - TclSetLongObj(objPtr, -(long)value); + TclSetLongObj(objPtr, (long)(-value)); } else { TclSetLongObj(objPtr, (long)value); } @@ -3573,7 +3573,7 @@ Tcl_SetBignumObj( goto tooLargeForWide; } if (bignumValue->sign) { - TclSetWideIntObj(objPtr, -(Tcl_WideInt)value); + TclSetWideIntObj(objPtr, (Tcl_WideInt)(-value)); } else { TclSetWideIntObj(objPtr, (Tcl_WideInt)value); } -- cgit v0.12 From c9599e745ab10316ab4bb48c8d129ce9f5cee15b Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 16 Feb 2022 16:18:08 +0000 Subject: Fix [7f8a3d9818]: signed integer overflow in tclExecute.c --- generic/tclExecute.c | 16 ++++++++-------- 1 file changed, 8 insertions(+), 8 deletions(-) diff --git a/generic/tclExecute.c b/generic/tclExecute.c index 2faf213..97ac1f0 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -1898,7 +1898,7 @@ TclIncrObj( if ((type1 == TCL_NUMBER_LONG) && (type2 == TCL_NUMBER_LONG)) { long augend = *((const long *) ptr1); long addend = *((const long *) ptr2); - long sum = augend + addend; + long sum = (long)((unsigned long)augend + (unsigned long)addend); /* * Overflow when (augend and sum have different sign) and (augend and @@ -1949,7 +1949,7 @@ TclIncrObj( TclGetWideIntFromObj(NULL, valuePtr, &w1); TclGetWideIntFromObj(NULL, incrPtr, &w2); - sum = w1 + w2; + sum = (Tcl_WideInt)((Tcl_WideUInt)w1 + (Tcl_WideUInt)w2); /* * Check for overflow. @@ -3929,7 +3929,7 @@ TEBCresume( if (GetNumberFromObj(NULL, objPtr, &ptr, &type) == TCL_OK) { if (type == TCL_NUMBER_LONG) { long augend = *((const long *)ptr); - long sum = augend + increment; + long sum = (long)((unsigned long)augend + (unsigned long)increment); /* * Overflow when (augend and sum have different sign) and @@ -3977,7 +3977,7 @@ TEBCresume( Tcl_WideInt sum; w = *((const Tcl_WideInt *) ptr); - sum = w + increment; + sum = (Tcl_WideInt)((Tcl_WideUInt)w + (Tcl_WideUInt)increment); /* * Check for overflow. @@ -6506,7 +6506,7 @@ TEBCresume( case INST_ADD: w1 = (Tcl_WideInt) l1; w2 = (Tcl_WideInt) l2; - wResult = w1 + w2; + wResult = (Tcl_WideInt)((Tcl_WideUInt)w1 + (Tcl_WideUInt)w2); #ifdef TCL_WIDE_INT_IS_LONG /* * Check for overflow. @@ -6521,7 +6521,7 @@ TEBCresume( case INST_SUB: w1 = (Tcl_WideInt) l1; w2 = (Tcl_WideInt) l2; - wResult = w1 - w2; + wResult = (Tcl_WideInt)((Tcl_WideUInt)w1 - (Tcl_WideUInt)w2); #ifdef TCL_WIDE_INT_IS_LONG /* * Must check for overflow. The macro tests for overflows in @@ -9146,7 +9146,7 @@ ExecuteExtendedBinaryMathOp( switch (opcode) { case INST_ADD: - wResult = w1 + w2; + wResult = (Tcl_WideInt)((Tcl_WideUInt)w1 + (Tcl_WideUInt)w2); #ifndef TCL_WIDE_INT_IS_LONG if ((type1 == TCL_NUMBER_WIDE) || (type2 == TCL_NUMBER_WIDE)) #endif @@ -9162,7 +9162,7 @@ ExecuteExtendedBinaryMathOp( break; case INST_SUB: - wResult = w1 - w2; + wResult = (Tcl_WideInt)((Tcl_WideUInt)w1 - (Tcl_WideUInt)w2); #ifndef TCL_WIDE_INT_IS_LONG if ((type1 == TCL_NUMBER_WIDE) || (type2 == TCL_NUMBER_WIDE)) #endif -- cgit v0.12 From 8fd0500bc8b2821f46d079ebc6b19bb39a25152e Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 17 Feb 2022 09:30:37 +0000 Subject: Addendum to [7deeddb36]: Use WIDE_MIN/WIDE_MAX in more places --- generic/tclObj.c | 2 +- generic/tclScan.c | 35 +++++++++++++++++++---------------- generic/tclStrToD.c | 11 +++++------ 3 files changed, 25 insertions(+), 23 deletions(-) diff --git a/generic/tclObj.c b/generic/tclObj.c index f7bb44c..9afcedb 100644 --- a/generic/tclObj.c +++ b/generic/tclObj.c @@ -3569,7 +3569,7 @@ Tcl_SetBignumObj( while (numBytes-- > 0) { value = (value << CHAR_BIT) | *bytes++; } - if (value > (((~(Tcl_WideUInt)0) >> 1) + bignumValue->sign)) { + if (value > ((UWIDE_MAX >> 1) + bignumValue->sign)) { goto tooLargeForWide; } if (bignumValue->sign) { diff --git a/generic/tclScan.c b/generic/tclScan.c index f6ff7a9..f37f596 100644 --- a/generic/tclScan.c +++ b/generic/tclScan.c @@ -28,15 +28,17 @@ * character set. */ -typedef struct CharSet { +typedef struct { + Tcl_UniChar start; + Tcl_UniChar end; +} Range; + +typedef struct { int exclude; /* 1 if this is an exclusion set. */ int nchars; Tcl_UniChar *chars; int nranges; - struct Range { - Tcl_UniChar start; - Tcl_UniChar end; - } *ranges; + Range *ranges; } CharSet; /* @@ -101,9 +103,9 @@ BuildCharSet( end += TclUtfToUniChar(end, &ch); } - cset->chars = ckalloc(sizeof(Tcl_UniChar) * (end - format - 1)); + cset->chars = (Tcl_UniChar *)ckalloc(sizeof(Tcl_UniChar) * (end - format - 1)); if (nranges > 0) { - cset->ranges = ckalloc(sizeof(struct Range) * nranges); + cset->ranges = (Range *)ckalloc(sizeof(Range) * nranges); } else { cset->ranges = NULL; } @@ -259,12 +261,12 @@ ValidateFormat( char *end; Tcl_UniChar ch = 0; int objIndex, xpgSize, nspace = numVars; - int *nassign = TclStackAlloc(interp, nspace * sizeof(int)); - char buf[TCL_UTF_MAX+1] = ""; + int *nassign = (int *)TclStackAlloc(interp, nspace * sizeof(int)); Tcl_Obj *errorMsg; /* Place to build an error messages. Note that * these are messy operations because we do * not want to use the formatting engine; * we're inside there! */ + char buf[TCL_UTF_MAX+1] = ""; /* * Initialize an array that records the number of times a variable is @@ -483,7 +485,7 @@ ValidateFormat( } else { nspace += 16; /* formerly STATIC_LIST_SIZE */ } - nassign = TclStackRealloc(interp, nassign, + nassign = (int *)TclStackRealloc(interp, nassign, nspace * sizeof(int)); for (i = value; i < nspace; i++) { nassign[i] = 0; @@ -566,7 +568,6 @@ ValidateFormat( *---------------------------------------------------------------------- */ - /* ARGSUSED */ int Tcl_ScanObjCmd( ClientData dummy, /* Not used. */ @@ -585,6 +586,7 @@ Tcl_ScanObjCmd( Tcl_UniChar ch = 0, sch = 0; Tcl_Obj **objs = NULL, *objPtr = NULL; int flags; + (void)dummy; if (objc < 3) { Tcl_WrongNumArgs(interp, 1, objv, @@ -608,7 +610,7 @@ Tcl_ScanObjCmd( */ if (totalVars > 0) { - objs = ckalloc(sizeof(Tcl_Obj *) * totalVars); + objs = (Tcl_Obj **)ckalloc(sizeof(Tcl_Obj *) * totalVars); for (i = 0; i < totalVars; i++) { objs[i] = NULL; } @@ -895,7 +897,7 @@ Tcl_ScanObjCmd( /* * Scan an unsigned or signed integer. */ - objPtr = Tcl_NewLongObj(0); + TclNewIntObj(objPtr, 0); Tcl_IncrRefCount(objPtr); if (width == 0) { width = ~0; @@ -921,9 +923,10 @@ Tcl_ScanObjCmd( } if (flags & SCAN_LONGER) { if (Tcl_GetWideIntFromObj(NULL, objPtr, &wideValue) != TCL_OK) { - wideValue = ~(Tcl_WideUInt)0 >> 1; /* WIDE_MAX */ if (TclGetString(objPtr)[0] == '-') { - wideValue += 1U; /* WIDE_MAX + 1 = WIDE_MIN */ + wideValue = WIDE_MIN; + } else { + wideValue = WIDE_MAX; } } if ((flags & SCAN_UNSIGNED) && (wideValue < 0)) { @@ -950,7 +953,7 @@ Tcl_ScanObjCmd( Tcl_SetWideIntObj(objPtr, (unsigned long)value); #endif } else { - Tcl_SetLongObj(objPtr, value); + TclSetLongObj(objPtr, value); } } objs[objIndex++] = objPtr; diff --git a/generic/tclStrToD.c b/generic/tclStrToD.c index 1a1c2ac..61162d0 100644 --- a/generic/tclStrToD.c +++ b/generic/tclStrToD.c @@ -542,8 +542,7 @@ TclParseNumber( int shift = 0; /* Amount to shift when accumulating binary */ int explicitOctal = 0; -#define ALL_BITS (~(Tcl_WideUInt)0) -#define MOST_BITS (ALL_BITS >> 1) +#define MOST_BITS (UWIDE_MAX >> 1) /* * Initialize bytes to start of the object's string rep if the caller @@ -703,7 +702,7 @@ TclParseNumber( && (((size_t)shift >= CHAR_BIT*sizeof(Tcl_WideUInt)) || (octalSignificandWide > - (~(Tcl_WideUInt)0 >> shift)))) { + (UWIDE_MAX >> shift)))) { octalSignificandOverflow = 1; TclBNInitBignumFromWideUInt(&octalSignificandBig, octalSignificandWide); @@ -829,7 +828,7 @@ TclParseNumber( if (significandWide != 0 && ((size_t)shift >= CHAR_BIT*sizeof(Tcl_WideUInt) || - significandWide > (~(Tcl_WideUInt)0 >> shift))) { + significandWide > (UWIDE_MAX >> shift))) { significandOverflow = 1; TclBNInitBignumFromWideUInt(&significandBig, significandWide); @@ -881,7 +880,7 @@ TclParseNumber( if (significandWide != 0 && ((size_t)shift >= CHAR_BIT*sizeof(Tcl_WideUInt) || - significandWide > (~(Tcl_WideUInt)0 >> shift))) { + significandWide > (UWIDE_MAX >> shift))) { significandOverflow = 1; TclBNInitBignumFromWideUInt(&significandBig, significandWide); @@ -1545,7 +1544,7 @@ AccumulateDecimalDigit( *wideRepPtr = digit; return 0; } else if (numZeros >= maxpow10_wide - || w > ((~(Tcl_WideUInt)0)-digit)/pow10_wide[numZeros+1]) { + || w > (UWIDE_MAX-digit)/pow10_wide[numZeros+1]) { /* * Wide multiplication will overflow. Expand the number to a * bignum and fall through into the bignum case. -- cgit v0.12 From 2127c83a98e1d0df1cf9df3ce6d34ae147c6bc95 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 17 Feb 2022 13:29:34 +0000 Subject: More int -> size_t in API --- generic/tcl.decls | 14 +++++++------- generic/tclBasic.c | 6 +++--- generic/tclDecls.h | 31 ++++++++++++++++--------------- generic/tclInterp.c | 6 +++--- generic/tclPipe.c | 2 +- generic/tclPkg.c | 2 +- 6 files changed, 31 insertions(+), 30 deletions(-) diff --git a/generic/tcl.decls b/generic/tcl.decls index aeed346..a831c54 100644 --- a/generic/tcl.decls +++ b/generic/tcl.decls @@ -331,12 +331,12 @@ declare 85 { } declare 86 { int Tcl_CreateAlias(Tcl_Interp *childInterp, const char *childCmd, - Tcl_Interp *target, const char *targetCmd, int argc, + Tcl_Interp *target, const char *targetCmd, size_t argc, const char *const *argv) } declare 87 { int Tcl_CreateAliasObj(Tcl_Interp *childInterp, const char *childCmd, - Tcl_Interp *target, const char *targetCmd, int objc, + Tcl_Interp *target, const char *targetCmd, size_t objc, Tcl_Obj *const objv[]) } declare 88 { @@ -725,7 +725,7 @@ declare 196 { Tcl_Obj *part2Ptr, Tcl_Obj *newValuePtr, int flags) } declare 197 { - Tcl_Channel Tcl_OpenCommandChannel(Tcl_Interp *interp, int argc, + Tcl_Channel Tcl_OpenCommandChannel(Tcl_Interp *interp, size_t argc, const char **argv, int flags) } # This is obsolete, use Tcl_FSOpenFileChannel @@ -2143,7 +2143,7 @@ declare 572 { # TIP#268 (extended version numbers and requirements) akupries declare 573 { int Tcl_PkgRequireProc(Tcl_Interp *interp, const char *name, - int objc, Tcl_Obj *const objv[], void *clientDataPtr) + size_t objc, Tcl_Obj *const objv[], void *clientDataPtr) } # TIP#270 (utility C routines for string formatting) dgp @@ -2197,11 +2197,11 @@ declare 584 { int Tcl_NREvalObj(Tcl_Interp *interp, Tcl_Obj *objPtr, int flags) } declare 585 { - int Tcl_NREvalObjv(Tcl_Interp *interp, int objc, + int Tcl_NREvalObjv(Tcl_Interp *interp, size_t objc, Tcl_Obj *const objv[], int flags) } declare 586 { - int Tcl_NRCmdSwap(Tcl_Interp *interp, Tcl_Command cmd, int objc, + int Tcl_NRCmdSwap(Tcl_Interp *interp, Tcl_Command cmd, size_t objc, Tcl_Obj *const objv[], int flags) } declare 587 { @@ -2213,7 +2213,7 @@ declare 587 { # classic objProc declare 588 { int Tcl_NRCallObjProc(Tcl_Interp *interp, Tcl_ObjCmdProc *objProc, - void *clientData, int objc, Tcl_Obj *const objv[]) + void *clientData, size_t objc, Tcl_Obj *const objv[]) } # TIP#316 (Tcl_StatBuf reader functions) dkf diff --git a/generic/tclBasic.c b/generic/tclBasic.c index c49ce34..92d8abf 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -8330,7 +8330,7 @@ Tcl_NRCallObjProc( Tcl_Interp *interp, Tcl_ObjCmdProc *objProc, void *clientData, - int objc, + size_t objc, Tcl_Obj *const objv[]) { NRE_callback *rootPtr = TOP_CB(interp); @@ -8430,7 +8430,7 @@ int Tcl_NREvalObjv( Tcl_Interp *interp, /* Interpreter in which to evaluate the * command. Also used for error reporting. */ - int objc, /* Number of words in command. */ + size_t objc, /* Number of words in command. */ Tcl_Obj *const objv[], /* An array of pointers to objects that are * the words that make up the command. */ int flags) /* Collection of OR-ed bits that control the @@ -8445,7 +8445,7 @@ int Tcl_NRCmdSwap( Tcl_Interp *interp, Tcl_Command cmd, - int objc, + size_t objc, Tcl_Obj *const objv[], int flags) { diff --git a/generic/tclDecls.h b/generic/tclDecls.h index af3c778..d899962 100644 --- a/generic/tclDecls.h +++ b/generic/tclDecls.h @@ -256,12 +256,12 @@ EXTERN size_t Tcl_ConvertCountedElement(const char *src, /* 86 */ EXTERN int Tcl_CreateAlias(Tcl_Interp *childInterp, const char *childCmd, Tcl_Interp *target, - const char *targetCmd, int argc, + const char *targetCmd, size_t argc, const char *const *argv); /* 87 */ EXTERN int Tcl_CreateAliasObj(Tcl_Interp *childInterp, const char *childCmd, Tcl_Interp *target, - const char *targetCmd, int objc, + const char *targetCmd, size_t objc, Tcl_Obj *const objv[]); /* 88 */ EXTERN Tcl_Channel Tcl_CreateChannel(const Tcl_ChannelType *typePtr, @@ -543,8 +543,8 @@ EXTERN Tcl_Obj * Tcl_ObjSetVar2(Tcl_Interp *interp, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, Tcl_Obj *newValuePtr, int flags); /* 197 */ -EXTERN Tcl_Channel Tcl_OpenCommandChannel(Tcl_Interp *interp, int argc, - const char **argv, int flags); +EXTERN Tcl_Channel Tcl_OpenCommandChannel(Tcl_Interp *interp, + size_t argc, const char **argv, int flags); /* 198 */ EXTERN Tcl_Channel Tcl_OpenFileChannel(Tcl_Interp *interp, const char *fileName, const char *modeString, @@ -1511,7 +1511,7 @@ EXTERN const char * Tcl_GetEncodingNameFromEnvironment( Tcl_DString *bufPtr); /* 573 */ EXTERN int Tcl_PkgRequireProc(Tcl_Interp *interp, - const char *name, int objc, + const char *name, size_t objc, Tcl_Obj *const objv[], void *clientDataPtr); /* 574 */ EXTERN void Tcl_AppendObjToErrorInfo(Tcl_Interp *interp, @@ -1551,11 +1551,12 @@ EXTERN Tcl_Command Tcl_NRCreateCommand(Tcl_Interp *interp, EXTERN int Tcl_NREvalObj(Tcl_Interp *interp, Tcl_Obj *objPtr, int flags); /* 585 */ -EXTERN int Tcl_NREvalObjv(Tcl_Interp *interp, int objc, +EXTERN int Tcl_NREvalObjv(Tcl_Interp *interp, size_t objc, Tcl_Obj *const objv[], int flags); /* 586 */ EXTERN int Tcl_NRCmdSwap(Tcl_Interp *interp, Tcl_Command cmd, - int objc, Tcl_Obj *const objv[], int flags); + size_t objc, Tcl_Obj *const objv[], + int flags); /* 587 */ EXTERN void Tcl_NRAddCallback(Tcl_Interp *interp, Tcl_NRPostProc *postProcPtr, void *data0, @@ -1563,7 +1564,7 @@ EXTERN void Tcl_NRAddCallback(Tcl_Interp *interp, /* 588 */ EXTERN int Tcl_NRCallObjProc(Tcl_Interp *interp, Tcl_ObjCmdProc *objProc, void *clientData, - int objc, Tcl_Obj *const objv[]); + size_t objc, Tcl_Obj *const objv[]); /* 589 */ EXTERN unsigned Tcl_GetFSDeviceFromStat(const Tcl_StatBuf *statPtr); /* 590 */ @@ -1878,8 +1879,8 @@ typedef struct TclStubs { char * (*tcl_Concat) (size_t argc, const char *const *argv); /* 83 */ size_t (*tcl_ConvertElement) (const char *src, char *dst, int flags); /* 84 */ size_t (*tcl_ConvertCountedElement) (const char *src, size_t length, char *dst, int flags); /* 85 */ - int (*tcl_CreateAlias) (Tcl_Interp *childInterp, const char *childCmd, Tcl_Interp *target, const char *targetCmd, int argc, const char *const *argv); /* 86 */ - int (*tcl_CreateAliasObj) (Tcl_Interp *childInterp, const char *childCmd, Tcl_Interp *target, const char *targetCmd, int objc, Tcl_Obj *const objv[]); /* 87 */ + int (*tcl_CreateAlias) (Tcl_Interp *childInterp, const char *childCmd, Tcl_Interp *target, const char *targetCmd, size_t argc, const char *const *argv); /* 86 */ + int (*tcl_CreateAliasObj) (Tcl_Interp *childInterp, const char *childCmd, Tcl_Interp *target, const char *targetCmd, size_t objc, Tcl_Obj *const objv[]); /* 87 */ Tcl_Channel (*tcl_CreateChannel) (const Tcl_ChannelType *typePtr, const char *chanName, void *instanceData, int mask); /* 88 */ void (*tcl_CreateChannelHandler) (Tcl_Channel chan, int mask, Tcl_ChannelProc *proc, void *clientData); /* 89 */ void (*tcl_CreateCloseHandler) (Tcl_Channel chan, Tcl_CloseProc *proc, void *clientData); /* 90 */ @@ -1989,7 +1990,7 @@ typedef struct TclStubs { void (*tcl_NotifyChannel) (Tcl_Channel channel, int mask); /* 194 */ Tcl_Obj * (*tcl_ObjGetVar2) (Tcl_Interp *interp, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, int flags); /* 195 */ Tcl_Obj * (*tcl_ObjSetVar2) (Tcl_Interp *interp, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, Tcl_Obj *newValuePtr, int flags); /* 196 */ - Tcl_Channel (*tcl_OpenCommandChannel) (Tcl_Interp *interp, int argc, const char **argv, int flags); /* 197 */ + Tcl_Channel (*tcl_OpenCommandChannel) (Tcl_Interp *interp, size_t argc, const char **argv, int flags); /* 197 */ Tcl_Channel (*tcl_OpenFileChannel) (Tcl_Interp *interp, const char *fileName, const char *modeString, int permissions); /* 198 */ Tcl_Channel (*tcl_OpenTcpClient) (Tcl_Interp *interp, int port, const char *address, const char *myaddr, int myport, int async); /* 199 */ Tcl_Channel (*tcl_OpenTcpServer) (Tcl_Interp *interp, int port, const char *host, Tcl_TcpAcceptProc *acceptProc, void *callbackData); /* 200 */ @@ -2365,7 +2366,7 @@ typedef struct TclStubs { Tcl_Obj * (*tcl_GetEncodingSearchPath) (void); /* 570 */ int (*tcl_SetEncodingSearchPath) (Tcl_Obj *searchPath); /* 571 */ const char * (*tcl_GetEncodingNameFromEnvironment) (Tcl_DString *bufPtr); /* 572 */ - int (*tcl_PkgRequireProc) (Tcl_Interp *interp, const char *name, int objc, Tcl_Obj *const objv[], void *clientDataPtr); /* 573 */ + int (*tcl_PkgRequireProc) (Tcl_Interp *interp, const char *name, size_t objc, Tcl_Obj *const objv[], void *clientDataPtr); /* 573 */ void (*tcl_AppendObjToErrorInfo) (Tcl_Interp *interp, Tcl_Obj *objPtr); /* 574 */ void (*tcl_AppendLimitedToObj) (Tcl_Obj *objPtr, const char *bytes, size_t length, size_t limit, const char *ellipsis); /* 575 */ Tcl_Obj * (*tcl_Format) (Tcl_Interp *interp, const char *format, size_t objc, Tcl_Obj *const objv[]); /* 576 */ @@ -2377,10 +2378,10 @@ typedef struct TclStubs { int (*tcl_CreatePipe) (Tcl_Interp *interp, Tcl_Channel *rchan, Tcl_Channel *wchan, int flags); /* 582 */ Tcl_Command (*tcl_NRCreateCommand) (Tcl_Interp *interp, const char *cmdName, Tcl_ObjCmdProc *proc, Tcl_ObjCmdProc *nreProc, void *clientData, Tcl_CmdDeleteProc *deleteProc); /* 583 */ int (*tcl_NREvalObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, int flags); /* 584 */ - int (*tcl_NREvalObjv) (Tcl_Interp *interp, int objc, Tcl_Obj *const objv[], int flags); /* 585 */ - int (*tcl_NRCmdSwap) (Tcl_Interp *interp, Tcl_Command cmd, int objc, Tcl_Obj *const objv[], int flags); /* 586 */ + int (*tcl_NREvalObjv) (Tcl_Interp *interp, size_t objc, Tcl_Obj *const objv[], int flags); /* 585 */ + int (*tcl_NRCmdSwap) (Tcl_Interp *interp, Tcl_Command cmd, size_t objc, Tcl_Obj *const objv[], int flags); /* 586 */ void (*tcl_NRAddCallback) (Tcl_Interp *interp, Tcl_NRPostProc *postProcPtr, void *data0, void *data1, void *data2, void *data3); /* 587 */ - int (*tcl_NRCallObjProc) (Tcl_Interp *interp, Tcl_ObjCmdProc *objProc, void *clientData, int objc, Tcl_Obj *const objv[]); /* 588 */ + int (*tcl_NRCallObjProc) (Tcl_Interp *interp, Tcl_ObjCmdProc *objProc, void *clientData, size_t objc, Tcl_Obj *const objv[]); /* 588 */ unsigned (*tcl_GetFSDeviceFromStat) (const Tcl_StatBuf *statPtr); /* 589 */ unsigned (*tcl_GetFSInodeFromStat) (const Tcl_StatBuf *statPtr); /* 590 */ unsigned (*tcl_GetModeFromStat) (const Tcl_StatBuf *statPtr); /* 591 */ diff --git a/generic/tclInterp.c b/generic/tclInterp.c index e6e552e..24118bb 100644 --- a/generic/tclInterp.c +++ b/generic/tclInterp.c @@ -1199,12 +1199,12 @@ Tcl_CreateAlias( const char *childCmd, /* Command to install in child. */ Tcl_Interp *targetInterp, /* Interpreter for target command. */ const char *targetCmd, /* Name of target command. */ - int argc, /* How many additional arguments? */ + size_t argc, /* How many additional arguments? */ const char *const *argv) /* These are the additional args. */ { Tcl_Obj *childObjPtr, *targetObjPtr; Tcl_Obj **objv; - int i; + size_t i; int result; objv = (Tcl_Obj **)TclStackAlloc(childInterp, sizeof(Tcl_Obj *) * argc); @@ -1254,7 +1254,7 @@ Tcl_CreateAliasObj( const char *childCmd, /* Command to install in child. */ Tcl_Interp *targetInterp, /* Interpreter for target command. */ const char *targetCmd, /* Name of target command. */ - int objc, /* How many additional arguments? */ + size_t objc, /* How many additional arguments? */ Tcl_Obj *const objv[]) /* Argument vector. */ { Tcl_Obj *childObjPtr, *targetObjPtr; diff --git a/generic/tclPipe.c b/generic/tclPipe.c index 84b3646..2577f1c 100644 --- a/generic/tclPipe.c +++ b/generic/tclPipe.c @@ -1020,7 +1020,7 @@ Tcl_Channel Tcl_OpenCommandChannel( Tcl_Interp *interp, /* Interpreter for error reporting. Can NOT be * NULL. */ - int argc, /* How many arguments. */ + size_t argc, /* How many arguments. */ const char **argv, /* Array of arguments for command pipe. */ int flags) /* Or'ed combination of TCL_STDIN, TCL_STDOUT, * TCL_STDERR, and TCL_ENFORCE_MODE. */ diff --git a/generic/tclPkg.c b/generic/tclPkg.c index aa81c55..348d0c0 100644 --- a/generic/tclPkg.c +++ b/generic/tclPkg.c @@ -426,7 +426,7 @@ Tcl_PkgRequireProc( Tcl_Interp *interp, /* Interpreter in which package is now * available. */ const char *name, /* Name of desired package. */ - int reqc, /* Requirements constraining the desired + size_t reqc, /* Requirements constraining the desired * version. */ Tcl_Obj *const reqv[], /* 0 means to use the latest version * available. */ -- cgit v0.12 From 932dcd87c0d852730af5a5ebcabedab58acedc19 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 17 Feb 2022 13:41:11 +0000 Subject: more int->size_t --- generic/tclInt.decls | 4 ++-- generic/tclIntDecls.h | 4 ++-- generic/tclIntPlatDecls.h | 4 ++-- generic/tclOO.c | 11 +++++++---- generic/tclOO.decls | 8 ++++---- generic/tclOODecls.h | 8 ++++---- generic/tclOOIntDecls.h | 8 ++++---- generic/tclPipe.c | 3 ++- unix/tclUnixPipe.c | 3 ++- win/tclWinPipe.c | 3 ++- 10 files changed, 31 insertions(+), 25 deletions(-) diff --git a/generic/tclInt.decls b/generic/tclInt.decls index 633233b..448cdac 100644 --- a/generic/tclInt.decls +++ b/generic/tclInt.decls @@ -39,7 +39,7 @@ declare 7 { } # TclCreatePipeline unofficially exported for use by BLT. declare 9 { - int TclCreatePipeline(Tcl_Interp *interp, int argc, const char **argv, + int TclCreatePipeline(Tcl_Interp *interp, size_t argc, const char **argv, Tcl_Pid **pidArrayPtr, TclFile *inPipePtr, TclFile *outPipePtr, TclFile *errFilePtr) } @@ -635,7 +635,7 @@ declare 11 { void TclGetAndDetachPids(Tcl_Interp *interp, Tcl_Channel chan) } declare 15 { - int TclpCreateProcess(Tcl_Interp *interp, int argc, + int TclpCreateProcess(Tcl_Interp *interp, size_t argc, const char **argv, TclFile inputFile, TclFile outputFile, TclFile errorFile, Tcl_Pid *pidPtr) } diff --git a/generic/tclIntDecls.h b/generic/tclIntDecls.h index 679ae7f..d496edf 100644 --- a/generic/tclIntDecls.h +++ b/generic/tclIntDecls.h @@ -59,7 +59,7 @@ EXTERN size_t TclCopyAndCollapse(size_t count, const char *src, char *dst); /* Slot 8 is reserved */ /* 9 */ -EXTERN int TclCreatePipeline(Tcl_Interp *interp, int argc, +EXTERN int TclCreatePipeline(Tcl_Interp *interp, size_t argc, const char **argv, Tcl_Pid **pidArrayPtr, TclFile *inPipePtr, TclFile *outPipePtr, TclFile *errFilePtr); @@ -591,7 +591,7 @@ typedef struct TclIntStubs { void (*tclCleanupCommand) (Command *cmdPtr); /* 6 */ size_t (*tclCopyAndCollapse) (size_t count, const char *src, char *dst); /* 7 */ void (*reserved8)(void); - int (*tclCreatePipeline) (Tcl_Interp *interp, int argc, const char **argv, Tcl_Pid **pidArrayPtr, TclFile *inPipePtr, TclFile *outPipePtr, TclFile *errFilePtr); /* 9 */ + int (*tclCreatePipeline) (Tcl_Interp *interp, size_t argc, const char **argv, Tcl_Pid **pidArrayPtr, TclFile *inPipePtr, TclFile *outPipePtr, TclFile *errFilePtr); /* 9 */ int (*tclCreateProc) (Tcl_Interp *interp, Namespace *nsPtr, const char *procName, Tcl_Obj *argsPtr, Tcl_Obj *bodyPtr, Proc **procPtrPtr); /* 10 */ void (*tclDeleteCompiledLocalVars) (Interp *iPtr, CallFrame *framePtr); /* 11 */ void (*tclDeleteVars) (Interp *iPtr, TclVarHashTable *tablePtr); /* 12 */ diff --git a/generic/tclIntPlatDecls.h b/generic/tclIntPlatDecls.h index 2da327f..03a009e 100644 --- a/generic/tclIntPlatDecls.h +++ b/generic/tclIntPlatDecls.h @@ -69,7 +69,7 @@ EXTERN void TclGetAndDetachPids(Tcl_Interp *interp, /* Slot 13 is reserved */ /* Slot 14 is reserved */ /* 15 */ -EXTERN int TclpCreateProcess(Tcl_Interp *interp, int argc, +EXTERN int TclpCreateProcess(Tcl_Interp *interp, size_t argc, const char **argv, TclFile inputFile, TclFile outputFile, TclFile errorFile, Tcl_Pid *pidPtr); @@ -119,7 +119,7 @@ typedef struct TclIntPlatStubs { void (*reserved12)(void); void (*reserved13)(void); void (*reserved14)(void); - int (*tclpCreateProcess) (Tcl_Interp *interp, int argc, const char **argv, TclFile inputFile, TclFile outputFile, TclFile errorFile, Tcl_Pid *pidPtr); /* 15 */ + int (*tclpCreateProcess) (Tcl_Interp *interp, size_t argc, const char **argv, TclFile inputFile, TclFile outputFile, TclFile errorFile, Tcl_Pid *pidPtr); /* 15 */ int (*tclpIsAtty) (int fd); /* 16 */ int (*tclUnixCopyFile) (const char *src, const char *dst, const Tcl_StatBuf *statBufPtr, int dontCopyAtts); /* 17 */ void (*reserved18)(void); diff --git a/generic/tclOO.c b/generic/tclOO.c index 2d741ba..da5723b 100644 --- a/generic/tclOO.c +++ b/generic/tclOO.c @@ -1667,7 +1667,7 @@ Tcl_NewObjectInstance( const char *nsNameStr, /* Name of namespace to create inside object, * or NULL to ask the code to pick its own * unique name. */ - int objc, /* Number of arguments. Negative value means + size_t objc1, /* Number of arguments. Negative value means * do not call constructor. */ Tcl_Obj *const *objv, /* Argument list. */ int skip) /* Number of arguments to _not_ pass to the @@ -1676,6 +1676,7 @@ Tcl_NewObjectInstance( Class *classPtr = (Class *) cls; Object *oPtr; ClientData clientData[4]; + int objc = objc1; oPtr = TclNewObjectInstanceCommon(interp, classPtr, nameStr, nsNameStr); if (oPtr == NULL) { @@ -2556,7 +2557,7 @@ TclOOInvokeObject( * (PRIVATE_METHOD), or a *really* private * context (any other value; conventionally * 0). */ - int objc, /* Number of arguments. */ + size_t objc, /* Number of arguments. */ Tcl_Obj *const *objv) /* Array of argument objects. It is assumed * that the name of the method to invoke will * be at index 1. */ @@ -2627,7 +2628,7 @@ int TclOOObjectCmdCore( Object *oPtr, /* The object being invoked. */ Tcl_Interp *interp, /* The interpreter containing the object. */ - int objc, /* How many arguments are being passed in. */ + size_t objc1, /* How many arguments are being passed in. */ Tcl_Obj *const *objv, /* The array of arguments. */ int flags, /* Whether this is an invocation through the * public or the private command interface. */ @@ -2642,6 +2643,7 @@ TclOOObjectCmdCore( Object *callerObjPtr = NULL; Class *callerClsPtr = NULL; int result; + int objc = objc1; /* * If we've no method name, throw this directly into the unknown @@ -2799,7 +2801,7 @@ int Tcl_ObjectContextInvokeNext( Tcl_Interp *interp, Tcl_ObjectContext context, - int objc, + size_t objc1, Tcl_Obj *const *objv, int skip) { @@ -2807,6 +2809,7 @@ Tcl_ObjectContextInvokeNext( int savedIndex = contextPtr->index; int savedSkip = contextPtr->skip; int result; + int objc = objc1; if (contextPtr->index + 1 >= contextPtr->callPtr->numChain) { /* diff --git a/generic/tclOO.decls b/generic/tclOO.decls index d0751bc..14eafe3 100644 --- a/generic/tclOO.decls +++ b/generic/tclOO.decls @@ -68,7 +68,7 @@ declare 12 { } declare 13 { Tcl_Object Tcl_NewObjectInstance(Tcl_Interp *interp, Tcl_Class cls, - const char *nameStr, const char *nsNameStr, int objc, + const char *nameStr, const char *nsNameStr, size_t objc, Tcl_Obj *const *objv, int skip) } declare 14 { @@ -104,7 +104,7 @@ declare 22 { } declare 23 { int Tcl_ObjectContextInvokeNext(Tcl_Interp *interp, - Tcl_ObjectContext context, int objc, Tcl_Obj *const *objv, + Tcl_ObjectContext context, size_t objc, Tcl_Obj *const *objv, int skip) } declare 24 { @@ -170,7 +170,7 @@ declare 4 { ProcedureMethod **pmPtrPtr) } declare 5 { - int TclOOObjectCmdCore(Object *oPtr, Tcl_Interp *interp, int objc, + int TclOOObjectCmdCore(Object *oPtr, Tcl_Interp *interp, size_t objc, Tcl_Obj *const *objv, int publicOnly, Class *startCls) } declare 6 { @@ -200,7 +200,7 @@ declare 10 { } declare 11 { int TclOOInvokeObject(Tcl_Interp *interp, Tcl_Object object, - Tcl_Class startCls, int publicPrivate, int objc, + Tcl_Class startCls, int publicPrivate, size_t objc, Tcl_Obj *const *objv) } declare 12 { diff --git a/generic/tclOODecls.h b/generic/tclOODecls.h index 90bd546..3e31bc9 100644 --- a/generic/tclOODecls.h +++ b/generic/tclOODecls.h @@ -69,7 +69,7 @@ TCLAPI Tcl_Method Tcl_NewMethod(Tcl_Interp *interp, Tcl_Class cls, /* 13 */ TCLAPI Tcl_Object Tcl_NewObjectInstance(Tcl_Interp *interp, Tcl_Class cls, const char *nameStr, - const char *nsNameStr, int objc, + const char *nsNameStr, size_t objc, Tcl_Obj *const *objv, int skip); /* 14 */ TCLAPI int Tcl_ObjectDeleted(Tcl_Object object); @@ -99,7 +99,7 @@ TCLAPI void Tcl_ObjectSetMetadata(Tcl_Object object, void *metadata); /* 23 */ TCLAPI int Tcl_ObjectContextInvokeNext(Tcl_Interp *interp, - Tcl_ObjectContext context, int objc, + Tcl_ObjectContext context, size_t objc, Tcl_Obj *const *objv, int skip); /* 24 */ TCLAPI Tcl_ObjectMapMethodNameProc * Tcl_ObjectGetMethodNameMapper( @@ -145,7 +145,7 @@ typedef struct TclOOStubs { Tcl_Obj * (*tcl_MethodName) (Tcl_Method method); /* 10 */ Tcl_Method (*tcl_NewInstanceMethod) (Tcl_Interp *interp, Tcl_Object object, Tcl_Obj *nameObj, int flags, const Tcl_MethodType *typePtr, void *clientData); /* 11 */ Tcl_Method (*tcl_NewMethod) (Tcl_Interp *interp, Tcl_Class cls, Tcl_Obj *nameObj, int flags, const Tcl_MethodType *typePtr, void *clientData); /* 12 */ - Tcl_Object (*tcl_NewObjectInstance) (Tcl_Interp *interp, Tcl_Class cls, const char *nameStr, const char *nsNameStr, int objc, Tcl_Obj *const *objv, int skip); /* 13 */ + Tcl_Object (*tcl_NewObjectInstance) (Tcl_Interp *interp, Tcl_Class cls, const char *nameStr, const char *nsNameStr, size_t objc, Tcl_Obj *const *objv, int skip); /* 13 */ int (*tcl_ObjectDeleted) (Tcl_Object object); /* 14 */ int (*tcl_ObjectContextIsFiltering) (Tcl_ObjectContext context); /* 15 */ Tcl_Method (*tcl_ObjectContextMethod) (Tcl_ObjectContext context); /* 16 */ @@ -155,7 +155,7 @@ typedef struct TclOOStubs { void (*tcl_ClassSetMetadata) (Tcl_Class clazz, const Tcl_ObjectMetadataType *typePtr, void *metadata); /* 20 */ void * (*tcl_ObjectGetMetadata) (Tcl_Object object, const Tcl_ObjectMetadataType *typePtr); /* 21 */ void (*tcl_ObjectSetMetadata) (Tcl_Object object, const Tcl_ObjectMetadataType *typePtr, void *metadata); /* 22 */ - int (*tcl_ObjectContextInvokeNext) (Tcl_Interp *interp, Tcl_ObjectContext context, int objc, Tcl_Obj *const *objv, int skip); /* 23 */ + int (*tcl_ObjectContextInvokeNext) (Tcl_Interp *interp, Tcl_ObjectContext context, size_t objc, Tcl_Obj *const *objv, int skip); /* 23 */ Tcl_ObjectMapMethodNameProc * (*tcl_ObjectGetMethodNameMapper) (Tcl_Object object); /* 24 */ void (*tcl_ObjectSetMethodNameMapper) (Tcl_Object object, Tcl_ObjectMapMethodNameProc *mapMethodNameProc); /* 25 */ void (*tcl_ClassSetConstructor) (Tcl_Interp *interp, Tcl_Class clazz, Tcl_Method method); /* 26 */ diff --git a/generic/tclOOIntDecls.h b/generic/tclOOIntDecls.h index 80ab87b..9fa90fb 100644 --- a/generic/tclOOIntDecls.h +++ b/generic/tclOOIntDecls.h @@ -42,7 +42,7 @@ TCLAPI Method * TclOONewProcMethod(Tcl_Interp *interp, Class *clsPtr, ProcedureMethod **pmPtrPtr); /* 5 */ TCLAPI int TclOOObjectCmdCore(Object *oPtr, Tcl_Interp *interp, - int objc, Tcl_Obj *const *objv, + size_t objc, Tcl_Obj *const *objv, int publicOnly, Class *startCls); /* 6 */ TCLAPI int TclOOIsReachable(Class *targetPtr, Class *startPtr); @@ -75,7 +75,7 @@ TCLAPI Tcl_Method TclOONewProcMethodEx(Tcl_Interp *interp, /* 11 */ TCLAPI int TclOOInvokeObject(Tcl_Interp *interp, Tcl_Object object, Tcl_Class startCls, - int publicPrivate, int objc, + int publicPrivate, size_t objc, Tcl_Obj *const *objv); /* 12 */ TCLAPI void TclOOObjectSetFilters(Object *oPtr, @@ -101,13 +101,13 @@ typedef struct TclOOIntStubs { Tcl_Method (*tclOOMakeProcMethod) (Tcl_Interp *interp, Class *clsPtr, int flags, Tcl_Obj *nameObj, const char *namePtr, Tcl_Obj *argsObj, Tcl_Obj *bodyObj, const Tcl_MethodType *typePtr, void *clientData, Proc **procPtrPtr); /* 2 */ Method * (*tclOONewProcInstanceMethod) (Tcl_Interp *interp, Object *oPtr, int flags, Tcl_Obj *nameObj, Tcl_Obj *argsObj, Tcl_Obj *bodyObj, ProcedureMethod **pmPtrPtr); /* 3 */ Method * (*tclOONewProcMethod) (Tcl_Interp *interp, Class *clsPtr, int flags, Tcl_Obj *nameObj, Tcl_Obj *argsObj, Tcl_Obj *bodyObj, ProcedureMethod **pmPtrPtr); /* 4 */ - int (*tclOOObjectCmdCore) (Object *oPtr, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv, int publicOnly, Class *startCls); /* 5 */ + int (*tclOOObjectCmdCore) (Object *oPtr, Tcl_Interp *interp, size_t objc, Tcl_Obj *const *objv, int publicOnly, Class *startCls); /* 5 */ int (*tclOOIsReachable) (Class *targetPtr, Class *startPtr); /* 6 */ Method * (*tclOONewForwardMethod) (Tcl_Interp *interp, Class *clsPtr, int isPublic, Tcl_Obj *nameObj, Tcl_Obj *prefixObj); /* 7 */ Method * (*tclOONewForwardInstanceMethod) (Tcl_Interp *interp, Object *oPtr, int isPublic, Tcl_Obj *nameObj, Tcl_Obj *prefixObj); /* 8 */ Tcl_Method (*tclOONewProcInstanceMethodEx) (Tcl_Interp *interp, Tcl_Object oPtr, TclOO_PreCallProc *preCallPtr, TclOO_PostCallProc *postCallPtr, ProcErrorProc *errProc, void *clientData, Tcl_Obj *nameObj, Tcl_Obj *argsObj, Tcl_Obj *bodyObj, int flags, void **internalTokenPtr); /* 9 */ Tcl_Method (*tclOONewProcMethodEx) (Tcl_Interp *interp, Tcl_Class clsPtr, TclOO_PreCallProc *preCallPtr, TclOO_PostCallProc *postCallPtr, ProcErrorProc *errProc, void *clientData, Tcl_Obj *nameObj, Tcl_Obj *argsObj, Tcl_Obj *bodyObj, int flags, void **internalTokenPtr); /* 10 */ - int (*tclOOInvokeObject) (Tcl_Interp *interp, Tcl_Object object, Tcl_Class startCls, int publicPrivate, int objc, Tcl_Obj *const *objv); /* 11 */ + int (*tclOOInvokeObject) (Tcl_Interp *interp, Tcl_Object object, Tcl_Class startCls, int publicPrivate, size_t objc, Tcl_Obj *const *objv); /* 11 */ void (*tclOOObjectSetFilters) (Object *oPtr, size_t numFilters, Tcl_Obj *const *filters); /* 12 */ void (*tclOOClassSetFilters) (Tcl_Interp *interp, Class *classPtr, size_t numFilters, Tcl_Obj *const *filters); /* 13 */ void (*tclOOObjectSetMixins) (Object *oPtr, int numMixins, Class *const *mixins); /* 14 */ diff --git a/generic/tclPipe.c b/generic/tclPipe.c index 2577f1c..3313c7a 100644 --- a/generic/tclPipe.c +++ b/generic/tclPipe.c @@ -398,7 +398,7 @@ TclCleanupChildren( int TclCreatePipeline( Tcl_Interp *interp, /* Interpreter to use for error reporting. */ - int argc, /* Number of entries in argv. */ + size_t argc1, /* Number of entries in argv. */ const char **argv, /* Array of strings describing commands in * pipeline plus I/O redirection with <, <<, * >, etc. Argv[argc] must be NULL. */ @@ -465,6 +465,7 @@ TclCreatePipeline( TclFile pipeIn; TclFile curInFile, curOutFile, curErrFile; Tcl_Channel channel; + int argc = argc1; if (inPipePtr != NULL) { *inPipePtr = NULL; diff --git a/unix/tclUnixPipe.c b/unix/tclUnixPipe.c index 85692c9..35cde8e 100644 --- a/unix/tclUnixPipe.c +++ b/unix/tclUnixPipe.c @@ -381,7 +381,7 @@ TclpCreateProcess( * occurred when creating the child process. * Error messages from the child process * itself are sent to errorFile. */ - int argc, /* Number of arguments in following array. */ + size_t argc1, /* Number of arguments in following array. */ const char **argv, /* Array of argument strings in UTF-8. * argv[0] contains the name of the executable * translated using Tcl_TranslateFileName @@ -411,6 +411,7 @@ TclpCreateProcess( Tcl_DString *dsArray; char **newArgv; int pid, i; + int argc = argc1; errPipeIn = NULL; errPipeOut = NULL; diff --git a/win/tclWinPipe.c b/win/tclWinPipe.c index baef81e..e7f00d4 100644 --- a/win/tclWinPipe.c +++ b/win/tclWinPipe.c @@ -911,7 +911,7 @@ TclpCreateProcess( * occurred when creating the child process. * Error messages from the child process * itself are sent to errorFile. */ - int argc, /* Number of arguments in following array. */ + size_t argc1, /* Number of arguments in following array. */ const char **argv, /* Array of argument strings. argv[0] contains * the name of the executable converted to * native format (using the @@ -943,6 +943,7 @@ TclpCreateProcess( HANDLE hProcess, h, inputHandle, outputHandle, errorHandle; char execPath[MAX_PATH * 3]; WinFile *filePtr; + int argc = argc1; PipeInit(); -- cgit v0.12 From bf552f0a4d5c314940d025c46551b4e5062c59ac Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 17 Feb 2022 14:16:59 +0000 Subject: More int -> size_t in internal API --- generic/tclBasic.c | 2 +- generic/tclDictObj.c | 4 ++-- generic/tclInt.decls | 20 ++++++++++---------- generic/tclIntDecls.h | 39 +++++++++++++++++++-------------------- generic/tclIntPlatDecls.h | 4 ++-- generic/tclPipe.c | 13 +++++++------ generic/tclProc.c | 3 ++- unix/tclUnixPipe.c | 5 +++-- win/tclWinPipe.c | 2 +- 9 files changed, 47 insertions(+), 45 deletions(-) diff --git a/generic/tclBasic.c b/generic/tclBasic.c index c8a285e..b277c5c 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -4245,7 +4245,7 @@ int TclNREvalObjv( Tcl_Interp *interp, /* Interpreter in which to evaluate the * command. Also used for error reporting. */ - int objc, /* Number of words in command. */ + size_t objc, /* Number of words in command. */ Tcl_Obj *const objv[], /* An array of pointers to objects that are * the words that make up the command. */ int flags, /* Collection of OR-ed bits that control the diff --git a/generic/tclDictObj.c b/generic/tclDictObj.c index 68049d0..c316d4d 100644 --- a/generic/tclDictObj.c +++ b/generic/tclDictObj.c @@ -777,12 +777,12 @@ Tcl_Obj * TclTraceDictPath( Tcl_Interp *interp, Tcl_Obj *dictPtr, - int keyc, + size_t keyc, Tcl_Obj *const keyv[], int flags) { Dict *dict, *newDict; - int i; + size_t i; DictGetInternalRep(dictPtr, dict); if (dict == NULL) { diff --git a/generic/tclInt.decls b/generic/tclInt.decls index 817aba4..ff1f546 100644 --- a/generic/tclInt.decls +++ b/generic/tclInt.decls @@ -39,7 +39,7 @@ declare 7 { } # TclCreatePipeline unofficially exported for use by BLT. declare 9 { - int TclCreatePipeline(Tcl_Interp *interp, int argc, const char **argv, + size_t TclCreatePipeline(Tcl_Interp *interp, size_t argc, const char **argv, Tcl_Pid **pidArrayPtr, TclFile *inPipePtr, TclFile *outPipePtr, TclFile *errFilePtr) } @@ -438,7 +438,7 @@ declare 224 { } declare 225 { Tcl_Obj *TclTraceDictPath(Tcl_Interp *interp, Tcl_Obj *rootPtr, - int keyc, Tcl_Obj *const keyv[], int flags) + size_t keyc, Tcl_Obj *const keyv[], int flags) } declare 226 { int TclObjBeingDeleted(Tcl_Obj *objPtr) @@ -454,7 +454,7 @@ declare 229 { declare 230 { Var *TclObjLookupVar(Tcl_Interp *interp, Tcl_Obj *part1Ptr, const char *part2, int flags, const char *msg, - const int createPart1, const int createPart2, Var **arrayPtrPtr) + int createPart1, int createPart2, Var **arrayPtrPtr) } declare 231 { int TclGetNamespaceFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr, @@ -497,7 +497,7 @@ declare 238 { } declare 239 { int TclNRInterpProcCore(Tcl_Interp *interp, Tcl_Obj *procNameObj, - int skip, ProcErrorProc *errorProc) + size_t skip, ProcErrorProc *errorProc) } declare 240 { int TclNRRunCallbacks(Tcl_Interp *interp, int result, @@ -508,7 +508,7 @@ declare 241 { const CmdFrame *invoker, int word) } declare 242 { - int TclNREvalObjv(Tcl_Interp *interp, int objc, + int TclNREvalObjv(Tcl_Interp *interp, size_t objc, Tcl_Obj *const objv[], int flags, Command *cmdPtr) } @@ -557,17 +557,17 @@ declare 251 { declare 252 { Tcl_Obj *TclPtrGetVar(Tcl_Interp *interp, Tcl_Var varPtr, Tcl_Var arrayPtr, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, - const int flags) + int flags) } declare 253 { Tcl_Obj *TclPtrSetVar(Tcl_Interp *interp, Tcl_Var varPtr, Tcl_Var arrayPtr, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, - Tcl_Obj *newValuePtr, const int flags) + Tcl_Obj *newValuePtr, int flags) } declare 254 { Tcl_Obj *TclPtrIncrObjVar(Tcl_Interp *interp, Tcl_Var varPtr, Tcl_Var arrayPtr, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, - Tcl_Obj *incrPtr, const int flags) + Tcl_Obj *incrPtr, int flags) } declare 255 { int TclPtrObjMakeUpvar(Tcl_Interp *interp, Tcl_Var otherPtr, @@ -575,7 +575,7 @@ declare 255 { } declare 256 { int TclPtrUnsetVar(Tcl_Interp *interp, Tcl_Var varPtr, Tcl_Var arrayPtr, - Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, const int flags) + Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, int flags) } declare 257 { void TclStaticLibrary(Tcl_Interp *interp, const char *prefix, @@ -635,7 +635,7 @@ declare 11 { void TclGetAndDetachPids(Tcl_Interp *interp, Tcl_Channel chan) } declare 15 { - int TclpCreateProcess(Tcl_Interp *interp, int argc, + int TclpCreateProcess(Tcl_Interp *interp, size_t argc, const char **argv, TclFile inputFile, TclFile outputFile, TclFile errorFile, Tcl_Pid *pidPtr) } diff --git a/generic/tclIntDecls.h b/generic/tclIntDecls.h index 8182676..101aedb 100644 --- a/generic/tclIntDecls.h +++ b/generic/tclIntDecls.h @@ -59,7 +59,7 @@ EXTERN size_t TclCopyAndCollapse(size_t count, const char *src, char *dst); /* Slot 8 is reserved */ /* 9 */ -EXTERN int TclCreatePipeline(Tcl_Interp *interp, int argc, +EXTERN size_t TclCreatePipeline(Tcl_Interp *interp, size_t argc, const char **argv, Tcl_Pid **pidArrayPtr, TclFile *inPipePtr, TclFile *outPipePtr, TclFile *errFilePtr); @@ -469,7 +469,7 @@ EXTERN void TclPopStackFrame(Tcl_Interp *interp); EXTERN TclPlatformType * TclGetPlatform(void); /* 225 */ EXTERN Tcl_Obj * TclTraceDictPath(Tcl_Interp *interp, - Tcl_Obj *rootPtr, int keyc, + Tcl_Obj *rootPtr, size_t keyc, Tcl_Obj *const keyv[], int flags); /* 226 */ EXTERN int TclObjBeingDeleted(Tcl_Obj *objPtr); @@ -483,9 +483,8 @@ EXTERN int TclPtrMakeUpvar(Tcl_Interp *interp, Var *otherP1Ptr, /* 230 */ EXTERN Var * TclObjLookupVar(Tcl_Interp *interp, Tcl_Obj *part1Ptr, const char *part2, - int flags, const char *msg, - const int createPart1, const int createPart2, - Var **arrayPtrPtr); + int flags, const char *msg, int createPart1, + int createPart2, Var **arrayPtrPtr); /* 231 */ EXTERN int TclGetNamespaceFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr, Tcl_Namespace **nsPtrPtr); @@ -510,7 +509,7 @@ EXTERN int TclNRInterpProc(void *clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); /* 239 */ EXTERN int TclNRInterpProcCore(Tcl_Interp *interp, - Tcl_Obj *procNameObj, int skip, + Tcl_Obj *procNameObj, size_t skip, ProcErrorProc *errorProc); /* 240 */ EXTERN int TclNRRunCallbacks(Tcl_Interp *interp, int result, @@ -519,7 +518,7 @@ EXTERN int TclNRRunCallbacks(Tcl_Interp *interp, int result, EXTERN int TclNREvalObjEx(Tcl_Interp *interp, Tcl_Obj *objPtr, int flags, const CmdFrame *invoker, int word); /* 242 */ -EXTERN int TclNREvalObjv(Tcl_Interp *interp, int objc, +EXTERN int TclNREvalObjv(Tcl_Interp *interp, size_t objc, Tcl_Obj *const objv[], int flags, Command *cmdPtr); /* 243 */ @@ -551,17 +550,17 @@ EXTERN int TclRegisterLiteral(void *envPtr, const char *bytes, /* 252 */ EXTERN Tcl_Obj * TclPtrGetVar(Tcl_Interp *interp, Tcl_Var varPtr, Tcl_Var arrayPtr, Tcl_Obj *part1Ptr, - Tcl_Obj *part2Ptr, const int flags); + Tcl_Obj *part2Ptr, int flags); /* 253 */ EXTERN Tcl_Obj * TclPtrSetVar(Tcl_Interp *interp, Tcl_Var varPtr, Tcl_Var arrayPtr, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, Tcl_Obj *newValuePtr, - const int flags); + int flags); /* 254 */ EXTERN Tcl_Obj * TclPtrIncrObjVar(Tcl_Interp *interp, Tcl_Var varPtr, Tcl_Var arrayPtr, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, Tcl_Obj *incrPtr, - const int flags); + int flags); /* 255 */ EXTERN int TclPtrObjMakeUpvar(Tcl_Interp *interp, Tcl_Var otherPtr, Tcl_Obj *myNamePtr, @@ -569,7 +568,7 @@ EXTERN int TclPtrObjMakeUpvar(Tcl_Interp *interp, /* 256 */ EXTERN int TclPtrUnsetVar(Tcl_Interp *interp, Tcl_Var varPtr, Tcl_Var arrayPtr, Tcl_Obj *part1Ptr, - Tcl_Obj *part2Ptr, const int flags); + Tcl_Obj *part2Ptr, int flags); /* 257 */ EXTERN void TclStaticLibrary(Tcl_Interp *interp, const char *prefix, @@ -592,7 +591,7 @@ typedef struct TclIntStubs { void (*tclCleanupCommand) (Command *cmdPtr); /* 6 */ size_t (*tclCopyAndCollapse) (size_t count, const char *src, char *dst); /* 7 */ void (*reserved8)(void); - int (*tclCreatePipeline) (Tcl_Interp *interp, int argc, const char **argv, Tcl_Pid **pidArrayPtr, TclFile *inPipePtr, TclFile *outPipePtr, TclFile *errFilePtr); /* 9 */ + size_t (*tclCreatePipeline) (Tcl_Interp *interp, size_t argc, const char **argv, Tcl_Pid **pidArrayPtr, TclFile *inPipePtr, TclFile *outPipePtr, TclFile *errFilePtr); /* 9 */ int (*tclCreateProc) (Tcl_Interp *interp, Namespace *nsPtr, const char *procName, Tcl_Obj *argsPtr, Tcl_Obj *bodyPtr, Proc **procPtrPtr); /* 10 */ void (*tclDeleteCompiledLocalVars) (Interp *iPtr, CallFrame *framePtr); /* 11 */ void (*tclDeleteVars) (Interp *iPtr, TclVarHashTable *tablePtr); /* 12 */ @@ -808,12 +807,12 @@ typedef struct TclIntStubs { void (*reserved222)(void); void (*reserved223)(void); TclPlatformType * (*tclGetPlatform) (void); /* 224 */ - Tcl_Obj * (*tclTraceDictPath) (Tcl_Interp *interp, Tcl_Obj *rootPtr, int keyc, Tcl_Obj *const keyv[], int flags); /* 225 */ + Tcl_Obj * (*tclTraceDictPath) (Tcl_Interp *interp, Tcl_Obj *rootPtr, size_t keyc, Tcl_Obj *const keyv[], int flags); /* 225 */ int (*tclObjBeingDeleted) (Tcl_Obj *objPtr); /* 226 */ void (*tclSetNsPath) (Namespace *nsPtr, size_t pathLength, Tcl_Namespace *pathAry[]); /* 227 */ void (*reserved228)(void); int (*tclPtrMakeUpvar) (Tcl_Interp *interp, Var *otherP1Ptr, const char *myName, int myFlags, int index); /* 229 */ - Var * (*tclObjLookupVar) (Tcl_Interp *interp, Tcl_Obj *part1Ptr, const char *part2, int flags, const char *msg, const int createPart1, const int createPart2, Var **arrayPtrPtr); /* 230 */ + Var * (*tclObjLookupVar) (Tcl_Interp *interp, Tcl_Obj *part1Ptr, const char *part2, int flags, const char *msg, int createPart1, int createPart2, Var **arrayPtrPtr); /* 230 */ int (*tclGetNamespaceFromObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, Tcl_Namespace **nsPtrPtr); /* 231 */ int (*tclEvalObjEx) (Tcl_Interp *interp, Tcl_Obj *objPtr, int flags, const CmdFrame *invoker, int word); /* 232 */ void (*tclGetSrcInfoForPc) (CmdFrame *contextPtr); /* 233 */ @@ -822,10 +821,10 @@ typedef struct TclIntStubs { void (*tclAppendUnicodeToObj) (Tcl_Obj *objPtr, const Tcl_UniChar *unicode, size_t length); /* 236 */ int (*tclResetCancellation) (Tcl_Interp *interp, int force); /* 237 */ int (*tclNRInterpProc) (void *clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); /* 238 */ - int (*tclNRInterpProcCore) (Tcl_Interp *interp, Tcl_Obj *procNameObj, int skip, ProcErrorProc *errorProc); /* 239 */ + int (*tclNRInterpProcCore) (Tcl_Interp *interp, Tcl_Obj *procNameObj, size_t skip, ProcErrorProc *errorProc); /* 239 */ int (*tclNRRunCallbacks) (Tcl_Interp *interp, int result, struct NRE_callback *rootPtr); /* 240 */ int (*tclNREvalObjEx) (Tcl_Interp *interp, Tcl_Obj *objPtr, int flags, const CmdFrame *invoker, int word); /* 241 */ - int (*tclNREvalObjv) (Tcl_Interp *interp, int objc, Tcl_Obj *const objv[], int flags, Command *cmdPtr); /* 242 */ + int (*tclNREvalObjv) (Tcl_Interp *interp, size_t objc, Tcl_Obj *const objv[], int flags, Command *cmdPtr); /* 242 */ void (*tclDbDumpActiveObjects) (FILE *outFile); /* 243 */ Tcl_HashTable * (*tclGetNamespaceChildTable) (Tcl_Namespace *nsPtr); /* 244 */ Tcl_HashTable * (*tclGetNamespaceCommandTable) (Tcl_Namespace *nsPtr); /* 245 */ @@ -835,11 +834,11 @@ typedef struct TclIntStubs { char * (*tclDoubleDigits) (double dv, int ndigits, int flags, int *decpt, int *signum, char **endPtr); /* 249 */ void (*tclSetChildCancelFlags) (Tcl_Interp *interp, int flags, int force); /* 250 */ int (*tclRegisterLiteral) (void *envPtr, const char *bytes, size_t length, int flags); /* 251 */ - Tcl_Obj * (*tclPtrGetVar) (Tcl_Interp *interp, Tcl_Var varPtr, Tcl_Var arrayPtr, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, const int flags); /* 252 */ - Tcl_Obj * (*tclPtrSetVar) (Tcl_Interp *interp, Tcl_Var varPtr, Tcl_Var arrayPtr, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, Tcl_Obj *newValuePtr, const int flags); /* 253 */ - Tcl_Obj * (*tclPtrIncrObjVar) (Tcl_Interp *interp, Tcl_Var varPtr, Tcl_Var arrayPtr, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, Tcl_Obj *incrPtr, const int flags); /* 254 */ + Tcl_Obj * (*tclPtrGetVar) (Tcl_Interp *interp, Tcl_Var varPtr, Tcl_Var arrayPtr, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, int flags); /* 252 */ + Tcl_Obj * (*tclPtrSetVar) (Tcl_Interp *interp, Tcl_Var varPtr, Tcl_Var arrayPtr, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, Tcl_Obj *newValuePtr, int flags); /* 253 */ + Tcl_Obj * (*tclPtrIncrObjVar) (Tcl_Interp *interp, Tcl_Var varPtr, Tcl_Var arrayPtr, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, Tcl_Obj *incrPtr, int flags); /* 254 */ int (*tclPtrObjMakeUpvar) (Tcl_Interp *interp, Tcl_Var otherPtr, Tcl_Obj *myNamePtr, int myFlags); /* 255 */ - int (*tclPtrUnsetVar) (Tcl_Interp *interp, Tcl_Var varPtr, Tcl_Var arrayPtr, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, const int flags); /* 256 */ + int (*tclPtrUnsetVar) (Tcl_Interp *interp, Tcl_Var varPtr, Tcl_Var arrayPtr, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, int flags); /* 256 */ void (*tclStaticLibrary) (Tcl_Interp *interp, const char *prefix, Tcl_LibraryInitProc *initProc, Tcl_LibraryInitProc *safeInitProc); /* 257 */ Tcl_Obj * (*tclpCreateTemporaryDirectory) (Tcl_Obj *dirObj, Tcl_Obj *basenameObj); /* 258 */ } TclIntStubs; diff --git a/generic/tclIntPlatDecls.h b/generic/tclIntPlatDecls.h index 2da327f..03a009e 100644 --- a/generic/tclIntPlatDecls.h +++ b/generic/tclIntPlatDecls.h @@ -69,7 +69,7 @@ EXTERN void TclGetAndDetachPids(Tcl_Interp *interp, /* Slot 13 is reserved */ /* Slot 14 is reserved */ /* 15 */ -EXTERN int TclpCreateProcess(Tcl_Interp *interp, int argc, +EXTERN int TclpCreateProcess(Tcl_Interp *interp, size_t argc, const char **argv, TclFile inputFile, TclFile outputFile, TclFile errorFile, Tcl_Pid *pidPtr); @@ -119,7 +119,7 @@ typedef struct TclIntPlatStubs { void (*reserved12)(void); void (*reserved13)(void); void (*reserved14)(void); - int (*tclpCreateProcess) (Tcl_Interp *interp, int argc, const char **argv, TclFile inputFile, TclFile outputFile, TclFile errorFile, Tcl_Pid *pidPtr); /* 15 */ + int (*tclpCreateProcess) (Tcl_Interp *interp, size_t argc, const char **argv, TclFile inputFile, TclFile outputFile, TclFile errorFile, Tcl_Pid *pidPtr); /* 15 */ int (*tclpIsAtty) (int fd); /* 16 */ int (*tclUnixCopyFile) (const char *src, const char *dst, const Tcl_StatBuf *statBufPtr, int dontCopyAtts); /* 17 */ void (*reserved18)(void); diff --git a/generic/tclPipe.c b/generic/tclPipe.c index 84b3646..b9c37e0 100644 --- a/generic/tclPipe.c +++ b/generic/tclPipe.c @@ -378,7 +378,7 @@ TclCleanupChildren( * * Results: * The return value is a count of the number of new processes created, or - * -1 if an error occurred while creating the pipeline. *pidArrayPtr is + * TCL_INDEX_NONE if an error occurred while creating the pipeline. *pidArrayPtr is * filled in with the address of a dynamically allocated array giving the * ids of all of the processes. It is up to the caller to free this array * when it isn't needed anymore. If inPipePtr is non-NULL, *inPipePtr is @@ -395,10 +395,10 @@ TclCleanupChildren( *---------------------------------------------------------------------- */ -int +size_t TclCreatePipeline( Tcl_Interp *interp, /* Interpreter to use for error reporting. */ - int argc, /* Number of entries in argv. */ + size_t argc, /* Number of entries in argv. */ const char **argv, /* Array of strings describing commands in * pipeline plus I/O redirection with <, <<, * >, etc. Argv[argc] must be NULL. */ @@ -431,7 +431,7 @@ TclCreatePipeline( { Tcl_Pid *pidPtr = NULL; /* Points to malloc-ed array holding all the * pids of child processes. */ - int numPids; /* Actual number of processes that exist at + size_t numPids; /* Actual number of processes that exist at * *pidPtr right now. */ int cmdCount; /* Count of number of distinct commands found * in argc/argv. */ @@ -460,7 +460,8 @@ TclCreatePipeline( int errorRelease = 0; const char *p; const char *nextArg; - int skip, lastBar, lastArg, i, j, atOK, flags, needCmd, errorToOutput = 0; + int skip, atOK, flags, needCmd, errorToOutput = 0; + size_t i, j, lastArg, lastBar; Tcl_DString execBuffer; TclFile pipeIn; TclFile curInFile, curOutFile, curErrFile; @@ -496,7 +497,7 @@ TclCreatePipeline( * list. */ - lastBar = -1; + lastBar = TCL_INDEX_NONE; cmdCount = 1; needCmd = 1; for (i = 0; i < argc; i++) { diff --git a/generic/tclProc.c b/generic/tclProc.c index 4efcf48..9b5d163 100644 --- a/generic/tclProc.c +++ b/generic/tclProc.c @@ -1649,7 +1649,7 @@ TclNRInterpProcCore( Tcl_Interp *interp,/* Interpreter in which procedure was * invoked. */ Tcl_Obj *procNameObj, /* Procedure name for error reporting. */ - int skip, /* Number of initial arguments to be skipped, + size_t skip1, /* Number of initial arguments to be skipped, * i.e., words in the "command name". */ ProcErrorProc *errorProc) /* How to convert results from the script into * results of the overall procedure. */ @@ -1659,6 +1659,7 @@ TclNRInterpProcCore( int result; CallFrame *freePtr; ByteCode *codePtr; + int skip = skip1; result = InitArgsAndLocals(interp, skip); if (result != TCL_OK) { diff --git a/unix/tclUnixPipe.c b/unix/tclUnixPipe.c index 85692c9..e1825c7 100644 --- a/unix/tclUnixPipe.c +++ b/unix/tclUnixPipe.c @@ -381,7 +381,7 @@ TclpCreateProcess( * occurred when creating the child process. * Error messages from the child process * itself are sent to errorFile. */ - int argc, /* Number of arguments in following array. */ + size_t argc, /* Number of arguments in following array. */ const char **argv, /* Array of argument strings in UTF-8. * argv[0] contains the name of the executable * translated using Tcl_TranslateFileName @@ -410,7 +410,8 @@ TclpCreateProcess( char errSpace[200 + TCL_INTEGER_SPACE]; Tcl_DString *dsArray; char **newArgv; - int pid, i; + int pid; + size_t i; errPipeIn = NULL; errPipeOut = NULL; diff --git a/win/tclWinPipe.c b/win/tclWinPipe.c index baef81e..2477778 100644 --- a/win/tclWinPipe.c +++ b/win/tclWinPipe.c @@ -911,7 +911,7 @@ TclpCreateProcess( * occurred when creating the child process. * Error messages from the child process * itself are sent to errorFile. */ - int argc, /* Number of arguments in following array. */ + size_t argc, /* Number of arguments in following array. */ const char **argv, /* Array of argument strings. argv[0] contains * the name of the executable converted to * native format (using the -- cgit v0.12 From e246b44499e406683adac8035e53d08b4dc0192a Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 17 Feb 2022 17:30:13 +0000 Subject: Deprecate internal macro's TclIsInfinite() and TclIsNan(), since C99 has isinf() and isnan() --- generic/tclBasic.c | 6 +++--- generic/tclExecute.c | 12 ++++++------ generic/tclInt.h | 15 ++++----------- generic/tclLink.c | 6 +++--- generic/tclObj.c | 4 ++-- generic/tclStrToD.c | 2 +- generic/tclTest.c | 2 +- generic/tclUtil.c | 4 ++-- unix/configure | 41 ----------------------------------------- unix/configure.ac | 12 ------------ unix/tclConfig.h.in | 3 --- 11 files changed, 22 insertions(+), 85 deletions(-) diff --git a/generic/tclBasic.c b/generic/tclBasic.c index 714bd80..ae7a3dc 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -7841,7 +7841,7 @@ ExprSqrtFunc( if (code != TCL_OK) { return TCL_ERROR; } - if ((d >= 0.0) && TclIsInfinite(d) + if ((d >= 0.0) && isinf(d) && (Tcl_GetBignumFromObj(NULL, objv[1], &big) == TCL_OK)) { mp_int root; mp_err err; @@ -7906,12 +7906,12 @@ CheckDoubleResult( double dResult) { #ifndef ACCEPT_NAN - if (TclIsNaN(dResult)) { + if (isnan(dResult)) { TclExprFloatError(interp, dResult); return TCL_ERROR; } #endif - if ((errno == ERANGE) && ((dResult == 0.0) || TclIsInfinite(dResult))) { + if ((errno == ERANGE) && ((dResult == 0.0) || isinf(dResult))) { /* * When ERANGE signals under/overflow, just accept 0.0 or +/-Inf */ diff --git a/generic/tclExecute.c b/generic/tclExecute.c index 403f3c9..dfb195a 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -514,7 +514,7 @@ VarHashCreateVar( *(ptrPtr) = (ClientData) \ (&((objPtr)->internalRep.wideValue)), TCL_OK) : \ TclHasInternalRep((objPtr), &tclDoubleType) \ - ? (((TclIsNaN((objPtr)->internalRep.doubleValue)) \ + ? (((isnan((objPtr)->internalRep.doubleValue)) \ ? (*(tPtr) = TCL_NUMBER_NAN) \ : (*(tPtr) = TCL_NUMBER_DOUBLE)), \ *(ptrPtr) = (ClientData) \ @@ -8653,7 +8653,7 @@ ExecuteExtendedBinaryMathOp( * Check now for IEEE floating-point error. */ - if (TclIsNaN(dResult)) { + if (isnan(dResult)) { TclExprFloatError(interp, dResult); return GENERAL_ARITHMETIC_ERROR; } @@ -8966,7 +8966,7 @@ TclCompareTwoNumbers( w1 = (Tcl_WideInt)d1; goto wideCompare; case TCL_NUMBER_BIG: - if (TclIsInfinite(d1)) { + if (isinf(d1)) { return (d1 > 0.0) ? MP_GT : MP_LT; } Tcl_TakeBignumFromObj(NULL, value2Ptr, &big2); @@ -8999,7 +8999,7 @@ TclCompareTwoNumbers( return compare; case TCL_NUMBER_DOUBLE: d2 = *((const double *)ptr2); - if (TclIsInfinite(d2)) { + if (isinf(d2)) { compare = (d2 > 0.0) ? MP_LT : MP_GT; mp_clear(&big1); return compare; @@ -9602,11 +9602,11 @@ TclExprFloatError( { const char *s; - if ((errno == EDOM) || TclIsNaN(value)) { + if ((errno == EDOM) || isnan(value)) { s = "domain error: argument not in valid range"; Tcl_SetObjResult(interp, Tcl_NewStringObj(s, -1)); Tcl_SetErrorCode(interp, "ARITH", "DOMAIN", s, NULL); - } else if ((errno == ERANGE) || TclIsInfinite(value)) { + } else if ((errno == ERANGE) || isinf(value)) { if (value == 0.0) { s = "floating-point value too small to represent"; Tcl_SetObjResult(interp, Tcl_NewStringObj(s, -1)); diff --git a/generic/tclInt.h b/generic/tclInt.h index b82a473..75cd6e5 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -4965,22 +4965,15 @@ MODULE_SCOPE Tcl_LibraryInitProc Procbodytest_SafeInit; /* *---------------------------------------------------------------- * Macros used by the Tcl core to test for some special double values. - * The ANSI C "prototypes" for these macros are: + * (deprecated) The ANSI C "prototypes" for these macros are: * * MODULE_SCOPE int TclIsInfinite(double d); * MODULE_SCOPE int TclIsNaN(double d); */ -#ifdef _MSC_VER -# define TclIsInfinite(d) (!(_finite((d)))) -# define TclIsNaN(d) (_isnan((d))) -#else -# define TclIsInfinite(d) ((d) > DBL_MAX || (d) < -DBL_MAX) -# ifdef NO_ISNAN -# define TclIsNaN(d) ((d) != (d)) -# else -# define TclIsNaN(d) (isnan(d)) -# endif +#if !defined(TCL_NO_DEPRECATED) && !defined(BUILD_tcl) +# define TclIsInfinite(d) isinf(d) +# define TclIsNaN(d) isnan(d) #endif /* diff --git a/generic/tclLink.c b/generic/tclLink.c index 5baa092..39f5345 100644 --- a/generic/tclLink.c +++ b/generic/tclLink.c @@ -606,7 +606,7 @@ EqualDouble( { return (a == b) #ifdef ACCEPT_NAN - || (TclIsNaN(a) && TclIsNaN(b)) + || (isnan(a) && isnan(b)) #endif /* ACCEPT_NAN */ ; } @@ -615,9 +615,9 @@ static inline int IsSpecial( double a) { - return TclIsInfinite(a) + return isinf(a) #ifdef ACCEPT_NAN - || TclIsNaN(a) + || isnan(a) #endif /* ACCEPT_NAN */ ; } diff --git a/generic/tclObj.c b/generic/tclObj.c index 4ac9936..a06b8fd 100644 --- a/generic/tclObj.c +++ b/generic/tclObj.c @@ -2547,7 +2547,7 @@ Tcl_GetDoubleFromObj( { do { if (objPtr->typePtr == &tclDoubleType) { - if (TclIsNaN(objPtr->internalRep.doubleValue)) { + if (isnan(objPtr->internalRep.doubleValue)) { if (interp != NULL) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "floating point value is Not a Number", -1)); @@ -3880,7 +3880,7 @@ TclGetNumberFromObj( { do { if (objPtr->typePtr == &tclDoubleType) { - if (TclIsNaN(objPtr->internalRep.doubleValue)) { + if (isnan(objPtr->internalRep.doubleValue)) { *typePtr = TCL_NUMBER_NAN; } else { *typePtr = TCL_NUMBER_DOUBLE; diff --git a/generic/tclStrToD.c b/generic/tclStrToD.c index 5ee5945..a7986b0 100644 --- a/generic/tclStrToD.c +++ b/generic/tclStrToD.c @@ -4832,7 +4832,7 @@ Tcl_InitBignumFromDouble( * Infinite values can't convert to bignum. */ - if (TclIsInfinite(d)) { + if (isinf(d)) { if (interp != NULL) { const char *s = "integer value too large to represent"; diff --git a/generic/tclTest.c b/generic/tclTest.c index 0db8587..009c95f 100644 --- a/generic/tclTest.c +++ b/generic/tclTest.c @@ -1652,7 +1652,7 @@ TestdoubledigitsObjCmd( if (status != TCL_OK) { doubleType = Tcl_GetObjType("double"); if (Tcl_FetchInternalRep(objv[1], doubleType) - && TclIsNaN(objv[1]->internalRep.doubleValue)) { + && isnan(objv[1]->internalRep.doubleValue)) { status = TCL_OK; memcpy(&d, &(objv[1]->internalRep.doubleValue), sizeof(double)); } diff --git a/generic/tclUtil.c b/generic/tclUtil.c index a96c752..66d1009 100644 --- a/generic/tclUtil.c +++ b/generic/tclUtil.c @@ -3231,7 +3231,7 @@ Tcl_PrintDouble( * Handle NaN. */ - if (TclIsNaN(value)) { + if (isnan(value)) { TclFormatNaN(value, dst); return; } @@ -3240,7 +3240,7 @@ Tcl_PrintDouble( * Handle infinities. */ - if (TclIsInfinite(value)) { + if (isinf(value)) { /* * Remember to copy the terminating NUL too. */ diff --git a/unix/configure b/unix/configure index 452d5da..5d18196 100755 --- a/unix/configure +++ b/unix/configure @@ -10341,47 +10341,6 @@ fi #-------------------------------------------------------------------- -# Check for support of isnan() function or macro -#-------------------------------------------------------------------- - -{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking isnan" >&5 -printf %s "checking isnan... " >&6; } -if test ${tcl_cv_isnan+y} -then : - printf %s "(cached) " >&6 -else $as_nop - - cat confdefs.h - <<_ACEOF >conftest.$ac_ext -/* end confdefs.h. */ -#include -int -main (void) -{ - -isnan(0.0); /* Generates an error if isnan is missing */ - - ; - return 0; -} -_ACEOF -if ac_fn_c_try_link "$LINENO" -then : - tcl_cv_isnan=yes -else $as_nop - tcl_cv_isnan=no -fi -rm -f core conftest.err conftest.$ac_objext conftest.beam \ - conftest$ac_exeext conftest.$ac_ext -fi -{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_isnan" >&5 -printf "%s\n" "$tcl_cv_isnan" >&6; } -if test $tcl_cv_isnan = no; then - -printf "%s\n" "#define NO_ISNAN 1" >>confdefs.h - -fi - -#-------------------------------------------------------------------- # Darwin specific API checks and defines #-------------------------------------------------------------------- diff --git a/unix/configure.ac b/unix/configure.ac index 335c5a2..7acb5ce 100644 --- a/unix/configure.ac +++ b/unix/configure.ac @@ -562,18 +562,6 @@ SC_ENABLE_LANGINFO AC_CHECK_FUNCS(cfmakeraw chflags mkstemps) #-------------------------------------------------------------------- -# Check for support of isnan() function or macro -#-------------------------------------------------------------------- - -AC_CACHE_CHECK([isnan], tcl_cv_isnan, [ - AC_LINK_IFELSE([AC_LANG_PROGRAM([[#include ]], [[ -isnan(0.0); /* Generates an error if isnan is missing */ -]])],[tcl_cv_isnan=yes],[tcl_cv_isnan=no])]) -if test $tcl_cv_isnan = no; then - AC_DEFINE(NO_ISNAN, 1, [Do we have a usable 'isnan'?]) -fi - -#-------------------------------------------------------------------- # Darwin specific API checks and defines #-------------------------------------------------------------------- diff --git a/unix/tclConfig.h.in b/unix/tclConfig.h.in index 5c24d40..1acc55d 100644 --- a/unix/tclConfig.h.in +++ b/unix/tclConfig.h.in @@ -349,9 +349,6 @@ /* Do we have getwd() */ #undef NO_GETWD -/* Do we have a usable 'isnan'? */ -#undef NO_ISNAN - /* Do we have memmove()? */ #undef NO_MEMMOVE -- cgit v0.12 From ff710528dbb61e071fac856e1923f8a59c689a2a Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 18 Feb 2022 16:31:26 +0000 Subject: Eliminate aarch64-w64-mingw32-clang warning --- win/tclWin32Dll.c | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/win/tclWin32Dll.c b/win/tclWin32Dll.c index 8620a08..9e83b46 100644 --- a/win/tclWin32Dll.c +++ b/win/tclWin32Dll.c @@ -90,7 +90,7 @@ BOOL APIENTRY DllEntryPoint( HINSTANCE hInst, /* Library instance handle. */ DWORD reason, /* Reason this function is being called. */ - LPVOID reserved) /* Not used. */ + LPVOID reserved) { return DllMain(hInst, reason, reserved); } @@ -837,6 +837,8 @@ TclWinCPUID( # endif #else + (void)index; + (void)regsPtr; /* * Don't know how to do assembly code for this compiler and/or * architecture. -- cgit v0.12 From 058d08c66ff3c104f9fbc29919b0220f888374f3 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 18 Feb 2022 16:57:01 +0000 Subject: Fix [22547f9053]: TIP 519 compiler warning --- generic/tclOODefineCmds.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/generic/tclOODefineCmds.c b/generic/tclOODefineCmds.c index cadfee5..4af23c2 100644 --- a/generic/tclOODefineCmds.c +++ b/generic/tclOODefineCmds.c @@ -2002,7 +2002,7 @@ TclOODefineMethodObjCmd( } if (objc == 5) { if (Tcl_GetIndexFromObj(interp, objv[2], exportModes, "export flag", - 0, (int *) &exportMode) != TCL_OK) { + 0, &exportMode) != TCL_OK) { return TCL_ERROR; } switch (exportMode) { -- cgit v0.12 From 25560ed141b47b6a80a25134b44b6b174aa2f84d Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Sun, 20 Feb 2022 19:57:04 +0000 Subject: Eliminate dead code and fix a comment --- generic/tclBasic.c | 11 ----------- generic/tclProc.c | 2 +- win/tclWinInit.c | 14 -------------- 3 files changed, 1 insertion(+), 26 deletions(-) diff --git a/generic/tclBasic.c b/generic/tclBasic.c index a21f633..2d86e9c 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -1220,17 +1220,6 @@ Tcl_CreateInterp(void) Tcl_SetVar2(interp, "tcl_version", NULL, TCL_VERSION, TCL_GLOBAL_ONLY); TclpSetVariables(interp); -#if TCL_THREADS && !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9 - /* - * The existence of the "threaded" element of the tcl_platform array - * indicates that this particular Tcl shell has been compiled with threads - * turned on. Using "info exists tcl_platform(threaded)" a Tcl script can - * introspect on the interpreter level of thread safety. - */ - - Tcl_SetVar2(interp, "tcl_platform", "threaded", "1", TCL_GLOBAL_ONLY); -#endif - /* * Register Tcl's version number. * TIP #268: Full patchlevel instead of just major.minor diff --git a/generic/tclProc.c b/generic/tclProc.c index 9b5d163..adc015f 100644 --- a/generic/tclProc.c +++ b/generic/tclProc.c @@ -84,7 +84,7 @@ const Tcl_ObjType tclProcBodyType = { } while (0) /* - * The [upvar]/[uplevel] level reference type. Uses the longValue field + * The [upvar]/[uplevel] level reference type. Uses the wideValue field * to remember the integer value of a parsed # format. * * Uses the default behaviour throughout, and never disposes of the string diff --git a/win/tclWinInit.c b/win/tclWinInit.c index 64b3b5a..1ddd518 100644 --- a/win/tclWinInit.c +++ b/win/tclWinInit.c @@ -493,20 +493,6 @@ TclpSetVariables( TCL_GLOBAL_ONLY); } -#if !defined(NDEBUG) && !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9 - - /* - * The existence of the "debug" element of the tcl_platform array - * indicates that this particular Tcl shell has been compiled with debug - * information. Using "info exists tcl_platform(debug)" a Tcl script can - * direct the interpreter to load debug versions of DLLs with the load - * command. - */ - - Tcl_SetVar2(interp, "tcl_platform", "debug", "1", - TCL_GLOBAL_ONLY); -#endif - /* * Set up the HOME environment variable from the HOMEDRIVE & HOMEPATH * environment variables, if necessary. -- cgit v0.12 From 7cf923e3adf17c1cc0d46d43914ff567a7910ff4 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 21 Feb 2022 13:49:39 +0000 Subject: Some more int -> size_t --- generic/tcl.decls | 6 +++--- generic/tclDecls.h | 12 ++++++------ generic/tclIO.c | 20 +++++++++++++++----- generic/tclInterp.c | 2 +- generic/tclPipe.c | 4 ++-- 5 files changed, 27 insertions(+), 17 deletions(-) diff --git a/generic/tcl.decls b/generic/tcl.decls index a831c54..ba0c122 100644 --- a/generic/tcl.decls +++ b/generic/tcl.decls @@ -427,7 +427,7 @@ declare 110 { void Tcl_DeleteInterp(Tcl_Interp *interp) } declare 111 { - void Tcl_DetachPids(int numPids, Tcl_Pid *pidPtr) + void Tcl_DetachPids(size_t numPids, Tcl_Pid *pidPtr) } declare 112 { void Tcl_DeleteTimerHandler(Tcl_TimerToken token) @@ -817,7 +817,7 @@ declare 223 { Tcl_InterpDeleteProc *proc, void *clientData) } declare 224 { - void Tcl_SetChannelBufferSize(Tcl_Channel chan, int sz) + void Tcl_SetChannelBufferSize(Tcl_Channel chan, size_t sz) } declare 225 { int Tcl_SetChannelOption(Tcl_Interp *interp, Tcl_Channel chan, @@ -1954,7 +1954,7 @@ declare 524 { int Tcl_LimitExceeded(Tcl_Interp *interp) } declare 525 { - void Tcl_LimitSetCommands(Tcl_Interp *interp, int commandLimit) + void Tcl_LimitSetCommands(Tcl_Interp *interp, size_t commandLimit) } declare 526 { void Tcl_LimitSetTime(Tcl_Interp *interp, Tcl_Time *timeLimitPtr) diff --git a/generic/tclDecls.h b/generic/tclDecls.h index d899962..700f4df 100644 --- a/generic/tclDecls.h +++ b/generic/tclDecls.h @@ -334,7 +334,7 @@ EXTERN void Tcl_DeleteHashTable(Tcl_HashTable *tablePtr); /* 110 */ EXTERN void Tcl_DeleteInterp(Tcl_Interp *interp); /* 111 */ -EXTERN void Tcl_DetachPids(int numPids, Tcl_Pid *pidPtr); +EXTERN void Tcl_DetachPids(size_t numPids, Tcl_Pid *pidPtr); /* 112 */ EXTERN void Tcl_DeleteTimerHandler(Tcl_TimerToken token); /* 113 */ @@ -617,7 +617,7 @@ EXTERN void Tcl_SetAssocData(Tcl_Interp *interp, const char *name, Tcl_InterpDeleteProc *proc, void *clientData); /* 224 */ -EXTERN void Tcl_SetChannelBufferSize(Tcl_Channel chan, int sz); +EXTERN void Tcl_SetChannelBufferSize(Tcl_Channel chan, size_t sz); /* 225 */ EXTERN int Tcl_SetChannelOption(Tcl_Interp *interp, Tcl_Channel chan, const char *optionName, @@ -1379,7 +1379,7 @@ EXTERN int Tcl_LimitCheck(Tcl_Interp *interp); EXTERN int Tcl_LimitExceeded(Tcl_Interp *interp); /* 525 */ EXTERN void Tcl_LimitSetCommands(Tcl_Interp *interp, - int commandLimit); + size_t commandLimit); /* 526 */ EXTERN void Tcl_LimitSetTime(Tcl_Interp *interp, Tcl_Time *timeLimitPtr); @@ -1904,7 +1904,7 @@ typedef struct TclStubs { void (*tcl_DeleteHashEntry) (Tcl_HashEntry *entryPtr); /* 108 */ void (*tcl_DeleteHashTable) (Tcl_HashTable *tablePtr); /* 109 */ void (*tcl_DeleteInterp) (Tcl_Interp *interp); /* 110 */ - void (*tcl_DetachPids) (int numPids, Tcl_Pid *pidPtr); /* 111 */ + void (*tcl_DetachPids) (size_t numPids, Tcl_Pid *pidPtr); /* 111 */ void (*tcl_DeleteTimerHandler) (Tcl_TimerToken token); /* 112 */ void (*tcl_DeleteTrace) (Tcl_Interp *interp, Tcl_Trace trace); /* 113 */ void (*tcl_DontCallWhenDeleted) (Tcl_Interp *interp, Tcl_InterpDeleteProc *proc, void *clientData); /* 114 */ @@ -2017,7 +2017,7 @@ typedef struct TclStubs { int (*tcl_ServiceAll) (void); /* 221 */ int (*tcl_ServiceEvent) (int flags); /* 222 */ void (*tcl_SetAssocData) (Tcl_Interp *interp, const char *name, Tcl_InterpDeleteProc *proc, void *clientData); /* 223 */ - void (*tcl_SetChannelBufferSize) (Tcl_Channel chan, int sz); /* 224 */ + void (*tcl_SetChannelBufferSize) (Tcl_Channel chan, size_t sz); /* 224 */ int (*tcl_SetChannelOption) (Tcl_Interp *interp, Tcl_Channel chan, const char *optionName, const char *newValue); /* 225 */ int (*tcl_SetCommandInfo) (Tcl_Interp *interp, const char *cmdName, const Tcl_CmdInfo *infoPtr); /* 226 */ void (*tcl_SetErrno) (int err); /* 227 */ @@ -2318,7 +2318,7 @@ typedef struct TclStubs { int (*tcl_LimitReady) (Tcl_Interp *interp); /* 522 */ int (*tcl_LimitCheck) (Tcl_Interp *interp); /* 523 */ int (*tcl_LimitExceeded) (Tcl_Interp *interp); /* 524 */ - void (*tcl_LimitSetCommands) (Tcl_Interp *interp, int commandLimit); /* 525 */ + void (*tcl_LimitSetCommands) (Tcl_Interp *interp, size_t commandLimit); /* 525 */ void (*tcl_LimitSetTime) (Tcl_Interp *interp, Tcl_Time *timeLimitPtr); /* 526 */ void (*tcl_LimitSetGranularity) (Tcl_Interp *interp, int type, int granularity); /* 527 */ int (*tcl_LimitTypeEnabled) (Tcl_Interp *interp, int type); /* 528 */ diff --git a/generic/tclIO.c b/generic/tclIO.c index 8745b09..882444f 100644 --- a/generic/tclIO.c +++ b/generic/tclIO.c @@ -7555,7 +7555,7 @@ Tcl_ChannelBuffered( void Tcl_SetChannelBufferSize( Tcl_Channel chan, /* The channel whose buffer size to set. */ - int sz) /* The size to set. */ + size_t sz) /* The size to set. */ { ChannelState *statePtr; /* State of real channel structure. */ @@ -7563,7 +7563,7 @@ Tcl_SetChannelBufferSize( * Clip the buffer size to force it into the [1,1M] range */ - if (sz < 1) { + if (sz < 1 || sz > (TCL_INDEX_NONE>>1)) { sz = 1; } else if (sz > MAX_CHANNEL_BUFFER_SIZE) { sz = MAX_CHANNEL_BUFFER_SIZE; @@ -7571,7 +7571,7 @@ Tcl_SetChannelBufferSize( statePtr = ((Channel *) chan)->state; - if (statePtr->bufSize == sz) { + if ((size_t)statePtr->bufSize == sz) { return; } statePtr->bufSize = sz; @@ -8019,9 +8019,19 @@ Tcl_SetChannelOption( } return TCL_OK; } else if (HaveOpt(7, "-buffersize")) { - int newBufferSize; + Tcl_WideInt newBufferSize; + Tcl_Obj obj; + int code; + + obj.refCount = 1; + obj.bytes = (char *)newValue; + obj.length = strlen(newValue); + obj.typePtr = NULL; - if (Tcl_GetInt(interp, newValue, &newBufferSize) == TCL_ERROR) { + code = Tcl_GetWideIntFromObj(interp, &obj, &newBufferSize); + TclFreeInternalRep(&obj); + + if (code == TCL_ERROR) { return TCL_ERROR; } Tcl_SetChannelBufferSize(chan, newBufferSize); diff --git a/generic/tclInterp.c b/generic/tclInterp.c index 24118bb..43543c5 100644 --- a/generic/tclInterp.c +++ b/generic/tclInterp.c @@ -3984,7 +3984,7 @@ Tcl_LimitTypeReset( void Tcl_LimitSetCommands( Tcl_Interp *interp, - int commandLimit) + size_t commandLimit) { Interp *iPtr = (Interp *) interp; diff --git a/generic/tclPipe.c b/generic/tclPipe.c index aac031b..f8e02ae 100644 --- a/generic/tclPipe.c +++ b/generic/tclPipe.c @@ -179,12 +179,12 @@ FileForRedirect( void Tcl_DetachPids( - int numPids, /* Number of pids to detach: gives size of + size_t numPids, /* Number of pids to detach: gives size of * array pointed to by pidPtr. */ Tcl_Pid *pidPtr) /* Array of pids to detach. */ { Detached *detPtr; - int i; + size_t i; Tcl_MutexLock(&pipeMutex); for (i = 0; i < numPids; i++) { -- cgit v0.12 From 21134c44f3434c701ef4f166be74f389cd3425bd Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 21 Feb 2022 14:57:50 +0000 Subject: some more --- generic/tclOO.decls | 4 ++-- generic/tclOODefineCmds.c | 4 ++-- generic/tclOOIntDecls.h | 8 ++++---- 3 files changed, 8 insertions(+), 8 deletions(-) diff --git a/generic/tclOO.decls b/generic/tclOO.decls index 14eafe3..5a1cff2 100644 --- a/generic/tclOO.decls +++ b/generic/tclOO.decls @@ -212,12 +212,12 @@ declare 13 { size_t numFilters, Tcl_Obj *const *filters) } declare 14 { - void TclOOObjectSetMixins(Object *oPtr, int numMixins, + void TclOOObjectSetMixins(Object *oPtr, size_t numMixins, Class *const *mixins) } declare 15 { void TclOOClassSetMixins(Tcl_Interp *interp, Class *classPtr, - int numMixins, Class *const *mixins) + size_t numMixins, Class *const *mixins) } return diff --git a/generic/tclOODefineCmds.c b/generic/tclOODefineCmds.c index e0819ed..e897778 100644 --- a/generic/tclOODefineCmds.c +++ b/generic/tclOODefineCmds.c @@ -371,7 +371,7 @@ TclOOClassSetFilters( void TclOOObjectSetMixins( Object *oPtr, - int numMixins, + size_t numMixins, Class *const *mixins) { Class *mixinPtr; @@ -432,7 +432,7 @@ void TclOOClassSetMixins( Tcl_Interp *interp, Class *classPtr, - int numMixins, + size_t numMixins, Class *const *mixins) { Class *mixinPtr; diff --git a/generic/tclOOIntDecls.h b/generic/tclOOIntDecls.h index 9fa90fb..53c2a6f 100644 --- a/generic/tclOOIntDecls.h +++ b/generic/tclOOIntDecls.h @@ -85,11 +85,11 @@ TCLAPI void TclOOClassSetFilters(Tcl_Interp *interp, Class *classPtr, size_t numFilters, Tcl_Obj *const *filters); /* 14 */ -TCLAPI void TclOOObjectSetMixins(Object *oPtr, int numMixins, +TCLAPI void TclOOObjectSetMixins(Object *oPtr, size_t numMixins, Class *const *mixins); /* 15 */ TCLAPI void TclOOClassSetMixins(Tcl_Interp *interp, - Class *classPtr, int numMixins, + Class *classPtr, size_t numMixins, Class *const *mixins); typedef struct TclOOIntStubs { @@ -110,8 +110,8 @@ typedef struct TclOOIntStubs { int (*tclOOInvokeObject) (Tcl_Interp *interp, Tcl_Object object, Tcl_Class startCls, int publicPrivate, size_t objc, Tcl_Obj *const *objv); /* 11 */ void (*tclOOObjectSetFilters) (Object *oPtr, size_t numFilters, Tcl_Obj *const *filters); /* 12 */ void (*tclOOClassSetFilters) (Tcl_Interp *interp, Class *classPtr, size_t numFilters, Tcl_Obj *const *filters); /* 13 */ - void (*tclOOObjectSetMixins) (Object *oPtr, int numMixins, Class *const *mixins); /* 14 */ - void (*tclOOClassSetMixins) (Tcl_Interp *interp, Class *classPtr, int numMixins, Class *const *mixins); /* 15 */ + void (*tclOOObjectSetMixins) (Object *oPtr, size_t numMixins, Class *const *mixins); /* 14 */ + void (*tclOOClassSetMixins) (Tcl_Interp *interp, Class *classPtr, size_t numMixins, Class *const *mixins); /* 15 */ } TclOOIntStubs; extern const TclOOIntStubs *tclOOIntStubsPtr; -- cgit v0.12 From c736c693049e659603b5cc2efb22092d921cc250 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 21 Feb 2022 16:18:10 +0000 Subject: Fix [fb4a0a6675]: signed integer overflow in TclpGetClicks() --- unix/tclUnixTime.c | 4 ++-- win/tclWinTime.c | 2 +- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/unix/tclUnixTime.c b/unix/tclUnixTime.c index 0fc87ea..3694ba2 100644 --- a/unix/tclUnixTime.c +++ b/unix/tclUnixTime.c @@ -136,7 +136,7 @@ TclpGetClicks(void) Tcl_Time time; tclGetTimeProcPtr(&time, tclTimeClientData); - now = time.sec*1000000 + time.usec; + now = ((unsigned long)(time.sec)*1000000UL) + (unsigned long)(time.usec); } else { /* * A semi-NativeGetTime, specialized to clicks. @@ -149,7 +149,7 @@ TclpGetClicks(void) Tcl_Time time; tclGetTimeProcPtr(&time, tclTimeClientData); - now = time.sec*1000000 + time.usec; + now = ((unsigned long)(time.sec)*1000000UL) + (unsigned long)(time.usec); #endif return now; diff --git a/win/tclWinTime.c b/win/tclWinTime.c index f75567e..ed58824 100644 --- a/win/tclWinTime.c +++ b/win/tclWinTime.c @@ -225,7 +225,7 @@ TclpGetClicks(void) Tcl_Time now; /* Current Tcl time */ tclGetTimeProcPtr(&now, tclTimeClientData); /* Tcl_GetTime inlined */ - return (unsigned long)(now.sec * 1000000) + now.usec; + return ((unsigned long)(now.sec)*1000000UL) + (unsigned long)(now.usec); } } -- cgit v0.12 From 9c0c7d79d571cf394dc28853bc3c19938c8c8953 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 23 Feb 2022 13:45:25 +0000 Subject: More int -> size_t --- generic/tclIOSock.c | 6 +++++- generic/tclInt.decls | 10 +++++----- generic/tclIntDecls.h | 19 ++++++++++--------- generic/tclIntPlatDecls.h | 4 ++-- generic/tclPipe.c | 8 ++++---- generic/tclTrace.c | 4 ++-- unix/tclUnixPipe.c | 8 ++++---- win/tclWinPipe.c | 8 ++++---- 8 files changed, 36 insertions(+), 31 deletions(-) diff --git a/generic/tclIOSock.c b/generic/tclIOSock.c index cfb0454..8f86257 100644 --- a/generic/tclIOSock.c +++ b/generic/tclIOSock.c @@ -117,11 +117,15 @@ TclSockGetPort( int TclSockMinimumBuffers( void *sock, /* Socket file descriptor */ - int size) /* Minimum buffer size */ + size_t size1) /* Minimum buffer size */ { int current; socklen_t len; + int size = size1; + if ((size_t)size != size1) { + return TCL_ERROR; + } len = sizeof(int); getsockopt((SOCKET)(size_t) sock, SOL_SOCKET, SO_SNDBUF, (char *) ¤t, &len); diff --git a/generic/tclInt.decls b/generic/tclInt.decls index 1c05eeb..5d5327a 100644 --- a/generic/tclInt.decls +++ b/generic/tclInt.decls @@ -28,7 +28,7 @@ declare 3 { void TclAllocateFreeObjects(void) } declare 5 { - int TclCleanupChildren(Tcl_Interp *interp, int numPids, Tcl_Pid *pidPtr, + int TclCleanupChildren(Tcl_Interp *interp, size_t numPids, Tcl_Pid *pidPtr, Tcl_Channel errorChan) } declare 6 { @@ -203,7 +203,7 @@ declare 109 { int TclUpdateReturnInfo(Interp *iPtr) } declare 110 { - int TclSockMinimumBuffers(void *sock, int size) + int TclSockMinimumBuffers(void *sock, size_t size) } # Removed in 8.1: # declare 110 { @@ -349,12 +349,12 @@ declare 169 { declare 170 { int TclCheckInterpTraces(Tcl_Interp *interp, const char *command, size_t numChars, Command *cmdPtr, int result, int traceFlags, - int objc, Tcl_Obj *const objv[]) + size_t objc, Tcl_Obj *const objv[]) } declare 171 { int TclCheckExecutionTraces(Tcl_Interp *interp, const char *command, size_t numChars, Command *cmdPtr, int result, int traceFlags, - int objc, Tcl_Obj *const objv[]) + size_t objc, Tcl_Obj *const objv[]) } declare 172 { int TclInThreadExit(void) @@ -608,7 +608,7 @@ declare 1 { } declare 2 { Tcl_Channel TclpCreateCommandChannel(TclFile readFile, - TclFile writeFile, TclFile errorFile, int numPids, Tcl_Pid *pidPtr) + TclFile writeFile, TclFile errorFile, size_t numPids, Tcl_Pid *pidPtr) } declare 3 { int TclpCreatePipe(TclFile *readPipe, TclFile *writePipe) diff --git a/generic/tclIntDecls.h b/generic/tclIntDecls.h index 5dd8196..df65e0f 100644 --- a/generic/tclIntDecls.h +++ b/generic/tclIntDecls.h @@ -50,8 +50,9 @@ extern "C" { EXTERN void TclAllocateFreeObjects(void); /* Slot 4 is reserved */ /* 5 */ -EXTERN int TclCleanupChildren(Tcl_Interp *interp, int numPids, - Tcl_Pid *pidPtr, Tcl_Channel errorChan); +EXTERN int TclCleanupChildren(Tcl_Interp *interp, + size_t numPids, Tcl_Pid *pidPtr, + Tcl_Channel errorChan); /* 6 */ EXTERN void TclCleanupCommand(Command *cmdPtr); /* 7 */ @@ -242,7 +243,7 @@ EXTERN void TclTeardownNamespace(Namespace *nsPtr); /* 109 */ EXTERN int TclUpdateReturnInfo(Interp *iPtr); /* 110 */ -EXTERN int TclSockMinimumBuffers(void *sock, int size); +EXTERN int TclSockMinimumBuffers(void *sock, size_t size); /* 111 */ EXTERN void Tcl_AddInterpResolvers(Tcl_Interp *interp, const char *name, @@ -368,12 +369,12 @@ EXTERN int TclpUtfNcmp2(const char *s1, const char *s2, EXTERN int TclCheckInterpTraces(Tcl_Interp *interp, const char *command, size_t numChars, Command *cmdPtr, int result, int traceFlags, - int objc, Tcl_Obj *const objv[]); + size_t objc, Tcl_Obj *const objv[]); /* 171 */ EXTERN int TclCheckExecutionTraces(Tcl_Interp *interp, const char *command, size_t numChars, Command *cmdPtr, int result, int traceFlags, - int objc, Tcl_Obj *const objv[]); + size_t objc, Tcl_Obj *const objv[]); /* 172 */ EXTERN int TclInThreadExit(void); /* 173 */ @@ -587,7 +588,7 @@ typedef struct TclIntStubs { void (*reserved2)(void); void (*tclAllocateFreeObjects) (void); /* 3 */ void (*reserved4)(void); - int (*tclCleanupChildren) (Tcl_Interp *interp, int numPids, Tcl_Pid *pidPtr, Tcl_Channel errorChan); /* 5 */ + int (*tclCleanupChildren) (Tcl_Interp *interp, size_t numPids, Tcl_Pid *pidPtr, Tcl_Channel errorChan); /* 5 */ void (*tclCleanupCommand) (Command *cmdPtr); /* 6 */ size_t (*tclCopyAndCollapse) (size_t count, const char *src, char *dst); /* 7 */ void (*reserved8)(void); @@ -692,7 +693,7 @@ typedef struct TclIntStubs { void (*reserved107)(void); void (*tclTeardownNamespace) (Namespace *nsPtr); /* 108 */ int (*tclUpdateReturnInfo) (Interp *iPtr); /* 109 */ - int (*tclSockMinimumBuffers) (void *sock, int size); /* 110 */ + int (*tclSockMinimumBuffers) (void *sock, size_t size); /* 110 */ void (*tcl_AddInterpResolvers) (Tcl_Interp *interp, const char *name, Tcl_ResolveCmdProc *cmdProc, Tcl_ResolveVarProc *varProc, Tcl_ResolveCompiledVarProc *compiledVarProc); /* 111 */ void (*reserved112)(void); void (*reserved113)(void); @@ -752,8 +753,8 @@ typedef struct TclIntStubs { void (*reserved167)(void); void (*reserved168)(void); int (*tclpUtfNcmp2) (const char *s1, const char *s2, size_t n); /* 169 */ - int (*tclCheckInterpTraces) (Tcl_Interp *interp, const char *command, size_t numChars, Command *cmdPtr, int result, int traceFlags, int objc, Tcl_Obj *const objv[]); /* 170 */ - int (*tclCheckExecutionTraces) (Tcl_Interp *interp, const char *command, size_t numChars, Command *cmdPtr, int result, int traceFlags, int objc, Tcl_Obj *const objv[]); /* 171 */ + int (*tclCheckInterpTraces) (Tcl_Interp *interp, const char *command, size_t numChars, Command *cmdPtr, int result, int traceFlags, size_t objc, Tcl_Obj *const objv[]); /* 170 */ + int (*tclCheckExecutionTraces) (Tcl_Interp *interp, const char *command, size_t numChars, Command *cmdPtr, int result, int traceFlags, size_t objc, Tcl_Obj *const objv[]); /* 171 */ int (*tclInThreadExit) (void); /* 172 */ int (*tclUniCharMatch) (const Tcl_UniChar *string, size_t strLen, const Tcl_UniChar *pattern, size_t ptnLen, int flags); /* 173 */ void (*reserved174)(void); diff --git a/generic/tclIntPlatDecls.h b/generic/tclIntPlatDecls.h index 03a009e..0e51eef 100644 --- a/generic/tclIntPlatDecls.h +++ b/generic/tclIntPlatDecls.h @@ -46,7 +46,7 @@ EXTERN int TclpCloseFile(TclFile file); /* 2 */ EXTERN Tcl_Channel TclpCreateCommandChannel(TclFile readFile, TclFile writeFile, TclFile errorFile, - int numPids, Tcl_Pid *pidPtr); + size_t numPids, Tcl_Pid *pidPtr); /* 3 */ EXTERN int TclpCreatePipe(TclFile *readPipe, TclFile *writePipe); /* 4 */ @@ -106,7 +106,7 @@ typedef struct TclIntPlatStubs { void (*reserved0)(void); int (*tclpCloseFile) (TclFile file); /* 1 */ - Tcl_Channel (*tclpCreateCommandChannel) (TclFile readFile, TclFile writeFile, TclFile errorFile, int numPids, Tcl_Pid *pidPtr); /* 2 */ + Tcl_Channel (*tclpCreateCommandChannel) (TclFile readFile, TclFile writeFile, TclFile errorFile, size_t numPids, Tcl_Pid *pidPtr); /* 2 */ int (*tclpCreatePipe) (TclFile *readPipe, TclFile *writePipe); /* 3 */ void * (*tclWinGetTclInstance) (void); /* 4 */ int (*tclUnixWaitForFile) (int fd, int mask, int timeout); /* 5 */ diff --git a/generic/tclPipe.c b/generic/tclPipe.c index f8e02ae..1f5e4f1 100644 --- a/generic/tclPipe.c +++ b/generic/tclPipe.c @@ -269,16 +269,16 @@ Tcl_ReapDetachedProcs(void) int TclCleanupChildren( Tcl_Interp *interp, /* Used for error messages. */ - int numPids, /* Number of entries in pidPtr array. */ + size_t numPids, /* Number of entries in pidPtr array. */ Tcl_Pid *pidPtr, /* Array of process ids of children. */ Tcl_Channel errorChan) /* Channel for file containing stderr output * from pipeline. NULL means there isn't any * stderr output. */ { int result = TCL_OK; - int i, abnormalExit, anyErrorInfo; + int code, abnormalExit, anyErrorInfo; TclProcessWaitStatus waitStatus; - int code; + size_t i; Tcl_Obj *msg, *error; abnormalExit = 0; @@ -1028,7 +1028,7 @@ Tcl_OpenCommandChannel( { TclFile *inPipePtr, *outPipePtr, *errFilePtr; TclFile inPipe, outPipe, errFile; - int numPids; + size_t numPids; Tcl_Pid *pidPtr; Tcl_Channel channel; diff --git a/generic/tclTrace.c b/generic/tclTrace.c index 69b40d7..25a4739 100644 --- a/generic/tclTrace.c +++ b/generic/tclTrace.c @@ -1423,7 +1423,7 @@ TclCheckExecutionTraces( Command *cmdPtr, /* Points to command's Command struct. */ int code, /* The current result code. */ int traceFlags, /* Current tracing situation. */ - int objc, /* Number of arguments for the command. */ + size_t objc, /* Number of arguments for the command. */ Tcl_Obj *const objv[]) /* Pointers to Tcl_Obj of each argument. */ { Interp *iPtr = (Interp *) interp; @@ -1529,7 +1529,7 @@ TclCheckInterpTraces( Command *cmdPtr, /* Points to command's Command struct. */ int code, /* The current result code. */ int traceFlags, /* Current tracing situation. */ - int objc, /* Number of arguments for the command. */ + size_t objc, /* Number of arguments for the command. */ Tcl_Obj *const objv[]) /* Pointers to Tcl_Obj of each argument. */ { Interp *iPtr = (Interp *) interp; diff --git a/unix/tclUnixPipe.c b/unix/tclUnixPipe.c index 35cde8e..bb0943a 100644 --- a/unix/tclUnixPipe.c +++ b/unix/tclUnixPipe.c @@ -35,7 +35,7 @@ typedef struct { TclFile inFile; /* Output from pipe. */ TclFile outFile; /* Input to pipe. */ TclFile errorFile; /* Error output from pipe. */ - int numPids; /* How many processes are attached to this + size_t numPids; /* How many processes are attached to this * pipe? */ Tcl_Pid *pidPtr; /* The process IDs themselves. Allocated by * the creator of the pipe. */ @@ -737,7 +737,7 @@ TclpCreateCommandChannel( TclFile writeFile, /* If non-null, gives the file for writing. */ TclFile errorFile, /* If non-null, gives the file where errors * can be read. */ - int numPids, /* The number of pids in the pid array. */ + size_t numPids, /* The number of pids in the pid array. */ Tcl_Pid *pidPtr) /* An array of process identifiers. Allocated * by the caller, freed when the channel is * closed or the processes are detached (in a @@ -859,7 +859,7 @@ TclGetAndDetachPids( PipeState *pipePtr; const Tcl_ChannelType *chanTypePtr; Tcl_Obj *pidsObj; - int i; + size_t i; /* * Punt if the channel is not a command channel. @@ -1258,7 +1258,7 @@ Tcl_PidObjCmd( { Tcl_Channel chan; PipeState *pipePtr; - int i; + size_t i; Tcl_Obj *resultPtr; if (objc > 2) { diff --git a/win/tclWinPipe.c b/win/tclWinPipe.c index e7f00d4..41692a5 100644 --- a/win/tclWinPipe.c +++ b/win/tclWinPipe.c @@ -104,7 +104,7 @@ typedef struct PipeInfo { TclFile readFile; /* Output from pipe. */ TclFile writeFile; /* Input from pipe. */ TclFile errorFile; /* Error output from pipe. */ - int numPids; /* Number of processes attached to pipe. */ + size_t numPids; /* Number of processes attached to pipe. */ Tcl_Pid *pidPtr; /* Pids of attached processes. */ Tcl_ThreadId threadId; /* Thread to which events should be reported. * This value is used by the reader/writer @@ -1760,7 +1760,7 @@ TclpCreateCommandChannel( TclFile writeFile, /* If non-null, gives the file for writing. */ TclFile errorFile, /* If non-null, gives the file where errors * can be read. */ - int numPids, /* The number of pids in the pid array. */ + size_t numPids, /* The number of pids in the pid array. */ Tcl_Pid *pidPtr) /* An array of process identifiers. */ { char channelName[16 + TCL_INTEGER_SPACE]; @@ -1907,7 +1907,7 @@ TclGetAndDetachPids( PipeInfo *pipePtr; const Tcl_ChannelType *chanTypePtr; Tcl_Obj *pidsObj; - int i; + size_t i; /* * Punt if the channel is not a command channel. @@ -2751,7 +2751,7 @@ Tcl_PidObjCmd( Tcl_Channel chan; const Tcl_ChannelType *chanTypePtr; PipeInfo *pipePtr; - int i; + size_t i; Tcl_Obj *resultPtr; if (objc > 2) { -- cgit v0.12 From ac7d65a8345455832dbb0ba384437e2953e23bdd Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 23 Feb 2022 14:04:36 +0000 Subject: Some more int -> size_t in internal API --- generic/tclIOSock.c | 6 +++++- generic/tclInt.decls | 10 +++++----- generic/tclIntDecls.h | 19 ++++++++++--------- generic/tclIntPlatDecls.h | 4 ++-- generic/tclPipe.c | 6 +++--- generic/tclTrace.c | 4 ++-- unix/tclUnixPipe.c | 14 +++++++------- win/tclWinPipe.c | 11 ++++++----- 8 files changed, 40 insertions(+), 34 deletions(-) diff --git a/generic/tclIOSock.c b/generic/tclIOSock.c index cfb0454..8f86257 100644 --- a/generic/tclIOSock.c +++ b/generic/tclIOSock.c @@ -117,11 +117,15 @@ TclSockGetPort( int TclSockMinimumBuffers( void *sock, /* Socket file descriptor */ - int size) /* Minimum buffer size */ + size_t size1) /* Minimum buffer size */ { int current; socklen_t len; + int size = size1; + if ((size_t)size != size1) { + return TCL_ERROR; + } len = sizeof(int); getsockopt((SOCKET)(size_t) sock, SOL_SOCKET, SO_SNDBUF, (char *) ¤t, &len); diff --git a/generic/tclInt.decls b/generic/tclInt.decls index ff1f546..2d91d0a 100644 --- a/generic/tclInt.decls +++ b/generic/tclInt.decls @@ -28,7 +28,7 @@ declare 3 { void TclAllocateFreeObjects(void) } declare 5 { - int TclCleanupChildren(Tcl_Interp *interp, int numPids, Tcl_Pid *pidPtr, + int TclCleanupChildren(Tcl_Interp *interp, size_t numPids, Tcl_Pid *pidPtr, Tcl_Channel errorChan) } declare 6 { @@ -203,7 +203,7 @@ declare 109 { int TclUpdateReturnInfo(Interp *iPtr) } declare 110 { - int TclSockMinimumBuffers(void *sock, int size) + int TclSockMinimumBuffers(void *sock, size_t size) } # Removed in 8.1: # declare 110 { @@ -349,12 +349,12 @@ declare 169 { declare 170 { int TclCheckInterpTraces(Tcl_Interp *interp, const char *command, size_t numChars, Command *cmdPtr, int result, int traceFlags, - int objc, Tcl_Obj *const objv[]) + size_t objc, Tcl_Obj *const objv[]) } declare 171 { int TclCheckExecutionTraces(Tcl_Interp *interp, const char *command, size_t numChars, Command *cmdPtr, int result, int traceFlags, - int objc, Tcl_Obj *const objv[]) + size_t objc, Tcl_Obj *const objv[]) } declare 172 { int TclInThreadExit(void) @@ -608,7 +608,7 @@ declare 1 { } declare 2 { Tcl_Channel TclpCreateCommandChannel(TclFile readFile, - TclFile writeFile, TclFile errorFile, int numPids, Tcl_Pid *pidPtr) + TclFile writeFile, TclFile errorFile, size_t numPids, Tcl_Pid *pidPtr) } declare 3 { int TclpCreatePipe(TclFile *readPipe, TclFile *writePipe) diff --git a/generic/tclIntDecls.h b/generic/tclIntDecls.h index 101aedb..48cec3d 100644 --- a/generic/tclIntDecls.h +++ b/generic/tclIntDecls.h @@ -50,8 +50,9 @@ extern "C" { EXTERN void TclAllocateFreeObjects(void); /* Slot 4 is reserved */ /* 5 */ -EXTERN int TclCleanupChildren(Tcl_Interp *interp, int numPids, - Tcl_Pid *pidPtr, Tcl_Channel errorChan); +EXTERN int TclCleanupChildren(Tcl_Interp *interp, + size_t numPids, Tcl_Pid *pidPtr, + Tcl_Channel errorChan); /* 6 */ EXTERN void TclCleanupCommand(Command *cmdPtr); /* 7 */ @@ -242,7 +243,7 @@ EXTERN void TclTeardownNamespace(Namespace *nsPtr); /* 109 */ EXTERN int TclUpdateReturnInfo(Interp *iPtr); /* 110 */ -EXTERN int TclSockMinimumBuffers(void *sock, int size); +EXTERN int TclSockMinimumBuffers(void *sock, size_t size); /* 111 */ EXTERN void Tcl_AddInterpResolvers(Tcl_Interp *interp, const char *name, @@ -368,12 +369,12 @@ EXTERN int TclpUtfNcmp2(const char *s1, const char *s2, EXTERN int TclCheckInterpTraces(Tcl_Interp *interp, const char *command, size_t numChars, Command *cmdPtr, int result, int traceFlags, - int objc, Tcl_Obj *const objv[]); + size_t objc, Tcl_Obj *const objv[]); /* 171 */ EXTERN int TclCheckExecutionTraces(Tcl_Interp *interp, const char *command, size_t numChars, Command *cmdPtr, int result, int traceFlags, - int objc, Tcl_Obj *const objv[]); + size_t objc, Tcl_Obj *const objv[]); /* 172 */ EXTERN int TclInThreadExit(void); /* 173 */ @@ -587,7 +588,7 @@ typedef struct TclIntStubs { void (*reserved2)(void); void (*tclAllocateFreeObjects) (void); /* 3 */ void (*reserved4)(void); - int (*tclCleanupChildren) (Tcl_Interp *interp, int numPids, Tcl_Pid *pidPtr, Tcl_Channel errorChan); /* 5 */ + int (*tclCleanupChildren) (Tcl_Interp *interp, size_t numPids, Tcl_Pid *pidPtr, Tcl_Channel errorChan); /* 5 */ void (*tclCleanupCommand) (Command *cmdPtr); /* 6 */ size_t (*tclCopyAndCollapse) (size_t count, const char *src, char *dst); /* 7 */ void (*reserved8)(void); @@ -692,7 +693,7 @@ typedef struct TclIntStubs { void (*reserved107)(void); void (*tclTeardownNamespace) (Namespace *nsPtr); /* 108 */ int (*tclUpdateReturnInfo) (Interp *iPtr); /* 109 */ - int (*tclSockMinimumBuffers) (void *sock, int size); /* 110 */ + int (*tclSockMinimumBuffers) (void *sock, size_t size); /* 110 */ void (*tcl_AddInterpResolvers) (Tcl_Interp *interp, const char *name, Tcl_ResolveCmdProc *cmdProc, Tcl_ResolveVarProc *varProc, Tcl_ResolveCompiledVarProc *compiledVarProc); /* 111 */ void (*reserved112)(void); void (*reserved113)(void); @@ -752,8 +753,8 @@ typedef struct TclIntStubs { void (*reserved167)(void); void (*reserved168)(void); int (*tclpUtfNcmp2) (const char *s1, const char *s2, size_t n); /* 169 */ - int (*tclCheckInterpTraces) (Tcl_Interp *interp, const char *command, size_t numChars, Command *cmdPtr, int result, int traceFlags, int objc, Tcl_Obj *const objv[]); /* 170 */ - int (*tclCheckExecutionTraces) (Tcl_Interp *interp, const char *command, size_t numChars, Command *cmdPtr, int result, int traceFlags, int objc, Tcl_Obj *const objv[]); /* 171 */ + int (*tclCheckInterpTraces) (Tcl_Interp *interp, const char *command, size_t numChars, Command *cmdPtr, int result, int traceFlags, size_t objc, Tcl_Obj *const objv[]); /* 170 */ + int (*tclCheckExecutionTraces) (Tcl_Interp *interp, const char *command, size_t numChars, Command *cmdPtr, int result, int traceFlags, size_t objc, Tcl_Obj *const objv[]); /* 171 */ int (*tclInThreadExit) (void); /* 172 */ int (*tclUniCharMatch) (const Tcl_UniChar *string, size_t strLen, const Tcl_UniChar *pattern, size_t ptnLen, int flags); /* 173 */ void (*reserved174)(void); diff --git a/generic/tclIntPlatDecls.h b/generic/tclIntPlatDecls.h index 03a009e..0e51eef 100644 --- a/generic/tclIntPlatDecls.h +++ b/generic/tclIntPlatDecls.h @@ -46,7 +46,7 @@ EXTERN int TclpCloseFile(TclFile file); /* 2 */ EXTERN Tcl_Channel TclpCreateCommandChannel(TclFile readFile, TclFile writeFile, TclFile errorFile, - int numPids, Tcl_Pid *pidPtr); + size_t numPids, Tcl_Pid *pidPtr); /* 3 */ EXTERN int TclpCreatePipe(TclFile *readPipe, TclFile *writePipe); /* 4 */ @@ -106,7 +106,7 @@ typedef struct TclIntPlatStubs { void (*reserved0)(void); int (*tclpCloseFile) (TclFile file); /* 1 */ - Tcl_Channel (*tclpCreateCommandChannel) (TclFile readFile, TclFile writeFile, TclFile errorFile, int numPids, Tcl_Pid *pidPtr); /* 2 */ + Tcl_Channel (*tclpCreateCommandChannel) (TclFile readFile, TclFile writeFile, TclFile errorFile, size_t numPids, Tcl_Pid *pidPtr); /* 2 */ int (*tclpCreatePipe) (TclFile *readPipe, TclFile *writePipe); /* 3 */ void * (*tclWinGetTclInstance) (void); /* 4 */ int (*tclUnixWaitForFile) (int fd, int mask, int timeout); /* 5 */ diff --git a/generic/tclPipe.c b/generic/tclPipe.c index b9c37e0..5a71446 100644 --- a/generic/tclPipe.c +++ b/generic/tclPipe.c @@ -269,16 +269,16 @@ Tcl_ReapDetachedProcs(void) int TclCleanupChildren( Tcl_Interp *interp, /* Used for error messages. */ - int numPids, /* Number of entries in pidPtr array. */ + size_t numPids, /* Number of entries in pidPtr array. */ Tcl_Pid *pidPtr, /* Array of process ids of children. */ Tcl_Channel errorChan) /* Channel for file containing stderr output * from pipeline. NULL means there isn't any * stderr output. */ { int result = TCL_OK; - int i, abnormalExit, anyErrorInfo; + int code, abnormalExit, anyErrorInfo; TclProcessWaitStatus waitStatus; - int code; + size_t i; Tcl_Obj *msg, *error; abnormalExit = 0; diff --git a/generic/tclTrace.c b/generic/tclTrace.c index 1794723..bc4cbfc 100644 --- a/generic/tclTrace.c +++ b/generic/tclTrace.c @@ -1423,7 +1423,7 @@ TclCheckExecutionTraces( Command *cmdPtr, /* Points to command's Command struct. */ int code, /* The current result code. */ int traceFlags, /* Current tracing situation. */ - int objc, /* Number of arguments for the command. */ + size_t objc, /* Number of arguments for the command. */ Tcl_Obj *const objv[]) /* Pointers to Tcl_Obj of each argument. */ { Interp *iPtr = (Interp *) interp; @@ -1529,7 +1529,7 @@ TclCheckInterpTraces( Command *cmdPtr, /* Points to command's Command struct. */ int code, /* The current result code. */ int traceFlags, /* Current tracing situation. */ - int objc, /* Number of arguments for the command. */ + size_t objc, /* Number of arguments for the command. */ Tcl_Obj *const objv[]) /* Pointers to Tcl_Obj of each argument. */ { Interp *iPtr = (Interp *) interp; diff --git a/unix/tclUnixPipe.c b/unix/tclUnixPipe.c index e1825c7..bb0943a 100644 --- a/unix/tclUnixPipe.c +++ b/unix/tclUnixPipe.c @@ -35,7 +35,7 @@ typedef struct { TclFile inFile; /* Output from pipe. */ TclFile outFile; /* Input to pipe. */ TclFile errorFile; /* Error output from pipe. */ - int numPids; /* How many processes are attached to this + size_t numPids; /* How many processes are attached to this * pipe? */ Tcl_Pid *pidPtr; /* The process IDs themselves. Allocated by * the creator of the pipe. */ @@ -381,7 +381,7 @@ TclpCreateProcess( * occurred when creating the child process. * Error messages from the child process * itself are sent to errorFile. */ - size_t argc, /* Number of arguments in following array. */ + size_t argc1, /* Number of arguments in following array. */ const char **argv, /* Array of argument strings in UTF-8. * argv[0] contains the name of the executable * translated using Tcl_TranslateFileName @@ -410,8 +410,8 @@ TclpCreateProcess( char errSpace[200 + TCL_INTEGER_SPACE]; Tcl_DString *dsArray; char **newArgv; - int pid; - size_t i; + int pid, i; + int argc = argc1; errPipeIn = NULL; errPipeOut = NULL; @@ -737,7 +737,7 @@ TclpCreateCommandChannel( TclFile writeFile, /* If non-null, gives the file for writing. */ TclFile errorFile, /* If non-null, gives the file where errors * can be read. */ - int numPids, /* The number of pids in the pid array. */ + size_t numPids, /* The number of pids in the pid array. */ Tcl_Pid *pidPtr) /* An array of process identifiers. Allocated * by the caller, freed when the channel is * closed or the processes are detached (in a @@ -859,7 +859,7 @@ TclGetAndDetachPids( PipeState *pipePtr; const Tcl_ChannelType *chanTypePtr; Tcl_Obj *pidsObj; - int i; + size_t i; /* * Punt if the channel is not a command channel. @@ -1258,7 +1258,7 @@ Tcl_PidObjCmd( { Tcl_Channel chan; PipeState *pipePtr; - int i; + size_t i; Tcl_Obj *resultPtr; if (objc > 2) { diff --git a/win/tclWinPipe.c b/win/tclWinPipe.c index 2477778..41692a5 100644 --- a/win/tclWinPipe.c +++ b/win/tclWinPipe.c @@ -104,7 +104,7 @@ typedef struct PipeInfo { TclFile readFile; /* Output from pipe. */ TclFile writeFile; /* Input from pipe. */ TclFile errorFile; /* Error output from pipe. */ - int numPids; /* Number of processes attached to pipe. */ + size_t numPids; /* Number of processes attached to pipe. */ Tcl_Pid *pidPtr; /* Pids of attached processes. */ Tcl_ThreadId threadId; /* Thread to which events should be reported. * This value is used by the reader/writer @@ -911,7 +911,7 @@ TclpCreateProcess( * occurred when creating the child process. * Error messages from the child process * itself are sent to errorFile. */ - size_t argc, /* Number of arguments in following array. */ + size_t argc1, /* Number of arguments in following array. */ const char **argv, /* Array of argument strings. argv[0] contains * the name of the executable converted to * native format (using the @@ -943,6 +943,7 @@ TclpCreateProcess( HANDLE hProcess, h, inputHandle, outputHandle, errorHandle; char execPath[MAX_PATH * 3]; WinFile *filePtr; + int argc = argc1; PipeInit(); @@ -1759,7 +1760,7 @@ TclpCreateCommandChannel( TclFile writeFile, /* If non-null, gives the file for writing. */ TclFile errorFile, /* If non-null, gives the file where errors * can be read. */ - int numPids, /* The number of pids in the pid array. */ + size_t numPids, /* The number of pids in the pid array. */ Tcl_Pid *pidPtr) /* An array of process identifiers. */ { char channelName[16 + TCL_INTEGER_SPACE]; @@ -1906,7 +1907,7 @@ TclGetAndDetachPids( PipeInfo *pipePtr; const Tcl_ChannelType *chanTypePtr; Tcl_Obj *pidsObj; - int i; + size_t i; /* * Punt if the channel is not a command channel. @@ -2750,7 +2751,7 @@ Tcl_PidObjCmd( Tcl_Channel chan; const Tcl_ChannelType *chanTypePtr; PipeInfo *pipePtr; - int i; + size_t i; Tcl_Obj *resultPtr; if (objc > 2) { -- cgit v0.12 From c21feb251ebe185b37d7061f8cb7c051cbdb15e8 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 23 Feb 2022 14:13:52 +0000 Subject: 2 more spare stub entries --- generic/tcl.decls | 2 +- generic/tclDecls.h | 12 +++++++++--- generic/tclStubInit.c | 4 +++- 3 files changed, 13 insertions(+), 5 deletions(-) diff --git a/generic/tcl.decls b/generic/tcl.decls index cea6b93..01318dd 100644 --- a/generic/tcl.decls +++ b/generic/tcl.decls @@ -2111,7 +2111,7 @@ declare 579 { # ----- BASELINE -- FOR -- 8.5.0 ----- # -declare 668 { +declare 670 { void TclUnusedStubEntry(void) } diff --git a/generic/tclDecls.h b/generic/tclDecls.h index 7a76c4a..10e9fc8 100644 --- a/generic/tclDecls.h +++ b/generic/tclDecls.h @@ -3500,9 +3500,11 @@ EXTERN void Tcl_AppendPrintfToObj(Tcl_Obj *objPtr, /* Slot 665 is reserved */ /* Slot 666 is reserved */ /* Slot 667 is reserved */ +/* Slot 668 is reserved */ +/* Slot 669 is reserved */ #ifndef TclUnusedStubEntry_TCL_DECLARED #define TclUnusedStubEntry_TCL_DECLARED -/* 668 */ +/* 670 */ EXTERN void TclUnusedStubEntry(void); #endif @@ -4208,7 +4210,9 @@ typedef struct TclStubs { VOID *reserved665; VOID *reserved666; VOID *reserved667; - void (*tclUnusedStubEntry) (void); /* 668 */ + VOID *reserved668; + VOID *reserved669; + void (*tclUnusedStubEntry) (void); /* 670 */ } TclStubs; extern TclStubs *tclStubsPtr; @@ -6649,9 +6653,11 @@ extern TclStubs *tclStubsPtr; /* Slot 665 is reserved */ /* Slot 666 is reserved */ /* Slot 667 is reserved */ +/* Slot 668 is reserved */ +/* Slot 669 is reserved */ #ifndef TclUnusedStubEntry #define TclUnusedStubEntry \ - (tclStubsPtr->tclUnusedStubEntry) /* 668 */ + (tclStubsPtr->tclUnusedStubEntry) /* 670 */ #endif #endif /* defined(USE_TCL_STUBS) && !defined(USE_TCL_STUB_PROCS) */ diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c index 1fcd92b..3859995 100644 --- a/generic/tclStubInit.c +++ b/generic/tclStubInit.c @@ -1466,7 +1466,9 @@ TclStubs tclStubs = { NULL, /* 665 */ NULL, /* 666 */ NULL, /* 667 */ - TclUnusedStubEntry, /* 668 */ + NULL, /* 668 */ + NULL, /* 669 */ + TclUnusedStubEntry, /* 670 */ }; /* !END!: Do not edit above this line. */ -- cgit v0.12 From 21d713fe09d0989cd5661b02ae415537c7863826 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 23 Feb 2022 14:24:15 +0000 Subject: Fix [d282fcacd1]: signed integer overflow in ScanNumber() --- generic/tclBinary.c | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/generic/tclBinary.c b/generic/tclBinary.c index 5d317fa..fdb7f59 100644 --- a/generic/tclBinary.c +++ b/generic/tclBinary.c @@ -2102,12 +2102,12 @@ ScanNumber( value = (long) (buffer[0] + (buffer[1] << 8) + (buffer[2] << 16) - + (((long)buffer[3]) << 24)); + + (((unsigned long)buffer[3]) << 24)); } else { value = (long) (buffer[3] + (buffer[2] << 8) + (buffer[1] << 16) - + (((long) buffer[0]) << 24)); + + (((unsigned long) buffer[0]) << 24)); } /* -- cgit v0.12 From 9f8ca234489c677193efb409fef485ce4774e8c6 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 23 Feb 2022 14:30:35 +0000 Subject: Fix [cb90038a63]: signed integer overflow during expr-34.22, expr-36.22 --- generic/tclExecute.c | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/generic/tclExecute.c b/generic/tclExecute.c index 97ac1f0..b96eab4 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -6286,7 +6286,8 @@ TEBCresume( (lResult * l2 != l1)) { lResult -= 1; } - lResult = l1 - l2*lResult; + lResult = (long)((unsigned long)l1 - + (unsigned long)l2*(unsigned long)lResult); goto longResultOfArithmetic; } break; @@ -8544,7 +8545,8 @@ ExecuteExtendedBinaryMathOp( && (wQuotient * w2 != w1)) { wQuotient -= (Tcl_WideInt) 1; } - wRemainder = w1 - w2*wQuotient; + wRemainder = (Tcl_WideInt)((Tcl_WideUInt)w1 - + (Tcl_WideUInt)w2*(Tcl_WideUInt)wQuotient); WIDE_RESULT(wRemainder); } -- cgit v0.12 From 20b89e16049a89c0fba39bf0762494140bd14663 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 24 Feb 2022 12:59:55 +0000 Subject: More (internal) size_t usage in TclOO --- generic/tclExecute.c | 6 +++--- generic/tclOO.c | 4 ++-- generic/tclOOBasic.c | 6 +++--- generic/tclOOCall.c | 13 +++++++------ generic/tclOOInt.h | 6 +++--- generic/tclOOMethod.c | 3 ++- 6 files changed, 20 insertions(+), 18 deletions(-) diff --git a/generic/tclExecute.c b/generic/tclExecute.c index 3876ff7..bea9798 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -4349,7 +4349,7 @@ TEBCresume( Object *oPtr; CallFrame *framePtr; CallContext *contextPtr; - int skip, newDepth; + size_t skip, newDepth; case INST_TCLOO_SELF: framePtr = iPtr->varFramePtr; @@ -4401,7 +4401,7 @@ TEBCresume( } else { Class *classPtr = oPtr->classPtr; struct MInvoke *miPtr; - int i; + size_t i; const char *methodType; if (classPtr == NULL) { @@ -4450,7 +4450,7 @@ TEBCresume( TRACE_APPEND(("ERROR: \"%.30s\" not on reachable chain\n", O2S(valuePtr))); - for (i=contextPtr->index ; i>=0 ; i--) { + for (i=contextPtr->index ; i != TCL_INDEX_NONE ; i--) { miPtr = contextPtr->callPtr->chain + i; if (miPtr->isFilter || miPtr->mPtr->declaringClassPtr != classPtr) { diff --git a/generic/tclOO.c b/generic/tclOO.c index b9c976e..f90025d 100644 --- a/generic/tclOO.c +++ b/generic/tclOO.c @@ -2799,8 +2799,8 @@ Tcl_ObjectContextInvokeNext( int skip) { CallContext *contextPtr = (CallContext *) context; - int savedIndex = contextPtr->index; - int savedSkip = contextPtr->skip; + size_t savedIndex = contextPtr->index; + size_t savedSkip = contextPtr->skip; int result; if (contextPtr->index + 1 >= contextPtr->callPtr->numChain) { diff --git a/generic/tclOOBasic.c b/generic/tclOOBasic.c index eb929c8..41ce034 100644 --- a/generic/tclOOBasic.c +++ b/generic/tclOOBasic.c @@ -909,7 +909,7 @@ TclOONextToObjCmd( CallFrame *framePtr = iPtr->varFramePtr; Class *classPtr; CallContext *contextPtr; - int i; + size_t i; Tcl_Object object; const char *methodType; @@ -985,7 +985,7 @@ TclOONextToObjCmd( methodType = "method"; } - for (i=contextPtr->index ; i>=0 ; i--) { + for (i=contextPtr->index ; i != TCL_INDEX_NONE ; i--) { struct MInvoke *miPtr = contextPtr->callPtr->chain + i; if (!miPtr->isFilter && miPtr->mPtr->declaringClassPtr == classPtr) { @@ -1218,7 +1218,7 @@ TclOOSelfObjCmd( } else { Method *mPtr; Object *declarerPtr; - int i; + size_t i; for (i=contextPtr->index ; icallPtr->numChain ; i++){ if (!contextPtr->callPtr->chain[i].isFilter) { diff --git a/generic/tclOOCall.c b/generic/tclOOCall.c index 60666f4..dbc4789 100644 --- a/generic/tclOOCall.c +++ b/generic/tclOOCall.c @@ -24,7 +24,7 @@ struct ChainBuilder { CallChain *callChainPtr; /* The call chain being built. */ - int filterLength; /* Number of entries in the call chain that + size_t filterLength; /* Number of entries in the call chain that * are due to processing filters and not the * main call chain. */ Object *oPtr; /* The object that we are building the chain @@ -326,7 +326,7 @@ TclOOInvokeContext( */ if (contextPtr->index == 0) { - int i; + size_t i; for (i = 0 ; i < contextPtr->callPtr->numChain ; i++) { AddRef(contextPtr->callPtr->chain[i].mPtr); @@ -404,7 +404,7 @@ FinalizeMethodRefs( int result) { CallContext *contextPtr = (CallContext *)data[0]; - int i; + size_t i; for (i = 0 ; i < contextPtr->callPtr->numChain ; i++) { TclOODelMethodRef(contextPtr->callPtr->chain[i].mPtr); @@ -969,7 +969,7 @@ AddMethodToCallChain( * not passed a mixin. */ { CallChain *callPtr = cbPtr->callChainPtr; - int i; + size_t i; /* * Return if this is just an entry used to record whether this is a public @@ -1408,7 +1408,7 @@ TclOOGetStereotypeCallChain( { CallChain *callPtr; struct ChainBuilder cb; - int i, count; + size_t count; Foundation *fPtr = clsPtr->thisPtr->fPtr; Tcl_HashEntry *hPtr; Tcl_HashTable doneFilters; @@ -1504,12 +1504,13 @@ TclOOGetStereotypeCallChain( } } else { if (hPtr == NULL) { + int isNew; if (clsPtr->classChainCache == NULL) { clsPtr->classChainCache = (Tcl_HashTable *)Tcl_Alloc(sizeof(Tcl_HashTable)); Tcl_InitObjHashTable(clsPtr->classChainCache); } hPtr = Tcl_CreateHashEntry(clsPtr->classChainCache, - (char *) methodNameObj, &i); + (char *) methodNameObj, &isNew); } callPtr->refCount++; Tcl_SetHashValue(hPtr, callPtr); diff --git a/generic/tclOOInt.h b/generic/tclOOInt.h index 342def6..4ad84a6 100644 --- a/generic/tclOOInt.h +++ b/generic/tclOOInt.h @@ -396,7 +396,7 @@ typedef struct CallChain { * snapshot. */ int flags; /* Assorted flags, see below. */ size_t refCount; /* Reference count. */ - int numChain; /* Size of the call chain. */ + size_t numChain; /* Size of the call chain. */ struct MInvoke *chain; /* Array of call chain entries. May point to * staticChain if the number of entries is * small. */ @@ -405,9 +405,9 @@ typedef struct CallChain { typedef struct CallContext { Object *oPtr; /* The object associated with this call. */ - int index; /* Index into the call chain of the currently + size_t index; /* Index into the call chain of the currently * executing method implementation. */ - int skip; /* Current number of arguments to skip; can + size_t skip; /* Current number of arguments to skip; can * vary depending on whether it is a direct * method call or a continuation via the * [next] command. */ diff --git a/generic/tclOOMethod.c b/generic/tclOOMethod.c index b205043..a09ae1b 100644 --- a/generic/tclOOMethod.c +++ b/generic/tclOOMethod.c @@ -1468,7 +1468,8 @@ InvokeForwardMethod( CallContext *contextPtr = (CallContext *) context; ForwardMethod *fmPtr = (ForwardMethod *)clientData; Tcl_Obj **argObjs, **prefixObjs; - int numPrefixes, len, skip = contextPtr->skip; + size_t numPrefixes, skip = contextPtr->skip; + int len; /* * Build the real list of arguments to use. Note that we know that the -- cgit v0.12 From edce3d6cb3d79f53d997bc44c3d487428d9f3aca Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 24 Feb 2022 14:00:52 +0000 Subject: Fix compiler warnings (caused by previous commit) --- generic/tclOOCall.c | 10 ++++++---- generic/tclOOMethod.c | 4 ++-- 2 files changed, 8 insertions(+), 6 deletions(-) diff --git a/generic/tclOOCall.c b/generic/tclOOCall.c index dbc4789..0c2c5e2 100644 --- a/generic/tclOOCall.c +++ b/generic/tclOOCall.c @@ -1149,7 +1149,8 @@ TclOOGetCallContext( CallContext *contextPtr; CallChain *callPtr; struct ChainBuilder cb; - int i, count, doFilters, donePrivate = 0; + size_t count; + int i, doFilters, donePrivate = 0; Tcl_HashEntry *hPtr; Tcl_HashTable doneFilters; @@ -1332,6 +1333,7 @@ TclOOGetCallContext( } } else if (doFilters && !donePrivate) { if (hPtr == NULL) { + int isNew; if (oPtr->flags & USE_CLASS_CACHE) { if (oPtr->selfCls->classChainCache == NULL) { oPtr->selfCls->classChainCache = @@ -1340,7 +1342,7 @@ TclOOGetCallContext( Tcl_InitObjHashTable(oPtr->selfCls->classChainCache); } hPtr = Tcl_CreateHashEntry(oPtr->selfCls->classChainCache, - (char *) methodNameObj, &i); + (char *) methodNameObj, &isNew); } else { if (oPtr->chainCache == NULL) { oPtr->chainCache = (Tcl_HashTable *)Tcl_Alloc(sizeof(Tcl_HashTable)); @@ -1348,7 +1350,7 @@ TclOOGetCallContext( Tcl_InitObjHashTable(oPtr->chainCache); } hPtr = Tcl_CreateHashEntry(oPtr->chainCache, - (char *) methodNameObj, &i); + (char *) methodNameObj, &isNew); } } callPtr->refCount++; @@ -1795,7 +1797,7 @@ TclOORenderCallChain( Tcl_Obj *filterLiteral, *methodLiteral, *objectLiteral, *privateLiteral; Tcl_Obj *resultObj, *descObjs[4], **objv; Foundation *fPtr = TclOOGetFoundation(interp); - int i; + size_t i; /* * Allocate the literals (potentially) used in our description. diff --git a/generic/tclOOMethod.c b/generic/tclOOMethod.c index a09ae1b..ca2b642 100644 --- a/generic/tclOOMethod.c +++ b/generic/tclOOMethod.c @@ -1468,8 +1468,8 @@ InvokeForwardMethod( CallContext *contextPtr = (CallContext *) context; ForwardMethod *fmPtr = (ForwardMethod *)clientData; Tcl_Obj **argObjs, **prefixObjs; - size_t numPrefixes, skip = contextPtr->skip; - int len; + size_t skip = contextPtr->skip; + int numPrefixes, len; /* * Build the real list of arguments to use. Note that we know that the -- cgit v0.12 From 671915641bb91ac0aed5250cf92efbfc30f9e0a4 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 24 Feb 2022 22:13:52 +0000 Subject: Consistancy in TCL_UTF_MAX check --- generic/tclEncoding.c | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/generic/tclEncoding.c b/generic/tclEncoding.c index fd83855..4630a02 100644 --- a/generic/tclEncoding.c +++ b/generic/tclEncoding.c @@ -2798,7 +2798,7 @@ UtfToUcs2Proc( { const char *srcStart, *srcEnd, *srcClose, *dstStart, *dstEnd; int result, numChars; -#if TCL_UTF_MAX <= 3 +#if TCL_UTF_MAX < 4 int len; #endif Tcl_UniChar ch = 0; @@ -2829,7 +2829,7 @@ UtfToUcs2Proc( result = TCL_CONVERT_NOSPACE; break; } -#if TCL_UTF_MAX <= 3 +#if TCL_UTF_MAX < 4 src += (len = TclUtfToUniChar(src, &ch)); if ((ch >= 0xD800) && (len < 3)) { src += TclUtfToUniChar(src, &ch); @@ -3242,7 +3242,7 @@ Iso88591FromUtfProc( */ if (ch > 0xFF -#if TCL_UTF_MAX <= 3 +#if TCL_UTF_MAX < 4 || ((ch >= 0xD800) && (len < 3)) #endif ) { @@ -3250,7 +3250,7 @@ Iso88591FromUtfProc( result = TCL_CONVERT_UNKNOWN; break; } -#if TCL_UTF_MAX <= 3 +#if TCL_UTF_MAX < 4 if ((ch >= 0xD800) && (len < 3)) { len = 4; } -- cgit v0.12 From b788457ad48d5cc34b431418f7d076d83f78b5ff Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 24 Feb 2022 22:20:17 +0000 Subject: 3 more files with TCL_UTF_MAX checks --- generic/tclDecls.h | 2 +- generic/tclStringObj.c | 4 ++-- generic/tclUtf.c | 16 ++++++++-------- 3 files changed, 11 insertions(+), 11 deletions(-) diff --git a/generic/tclDecls.h b/generic/tclDecls.h index 939bae9..fd5f81b 100644 --- a/generic/tclDecls.h +++ b/generic/tclDecls.h @@ -4283,7 +4283,7 @@ extern const TclStubs *tclStubsPtr; #undef Tcl_StringMatch #define Tcl_StringMatch(str, pattern) Tcl_StringCaseMatch((str), (pattern), 0) -#if TCL_UTF_MAX <= 3 +#if TCL_UTF_MAX < 4 # undef Tcl_UniCharToUtfDString # define Tcl_UniCharToUtfDString Tcl_Char16ToUtfDString # undef Tcl_UtfToUniCharDString diff --git a/generic/tclStringObj.c b/generic/tclStringObj.c index bee1e3e..f240bc0 100644 --- a/generic/tclStringObj.c +++ b/generic/tclStringObj.c @@ -571,7 +571,7 @@ Tcl_GetUniChar( return -1; } ch = stringPtr->unicode[index]; -#if TCL_UTF_MAX <= 3 +#if TCL_UTF_MAX < 4 /* See: bug [11ae2be95dac9417] */ if ((ch & 0xF800) == 0xD800) { if (ch & 0x400) { @@ -785,7 +785,7 @@ Tcl_GetRange( TclNewObj(newObjPtr); return newObjPtr; } -#if TCL_UTF_MAX <= 3 +#if TCL_UTF_MAX < 4 /* See: bug [11ae2be95dac9417] */ if ((first > 0) && ((stringPtr->unicode[first] & 0xFC00) == 0xDC00) && ((stringPtr->unicode[first-1] & 0xFC00) == 0xD800)) { diff --git a/generic/tclUtf.c b/generic/tclUtf.c index fae6edd..169f240 100644 --- a/generic/tclUtf.c +++ b/generic/tclUtf.c @@ -1137,7 +1137,7 @@ Tcl_UniCharAtIndex( i = TclUtfToUniChar(src, &ch); src += i; } -#if TCL_UTF_MAX <= 3 +#if TCL_UTF_MAX < 4 if ((ch >= 0xD800) && (i < 3)) { /* Index points at character following high Surrogate */ return -1; @@ -1153,7 +1153,7 @@ Tcl_UniCharAtIndex( * Tcl_UtfAtIndex -- * * Returns a pointer to the specified character (not byte) position in - * the UTF-8 string. If TCL_UTF_MAX <= 3, characters > U+FFFF count as + * the UTF-8 string. If TCL_UTF_MAX < 4, characters > U+FFFF count as * 2 positions, but then the pointer should never be placed between * the two positions. * @@ -1178,7 +1178,7 @@ Tcl_UtfAtIndex( len = TclUtfToUniChar(src, &ch); src += len; } -#if TCL_UTF_MAX <= 3 +#if TCL_UTF_MAX < 4 if ((ch >= 0xD800) && (len < 3)) { /* Index points at character following high Surrogate */ src += TclUtfToUniChar(src, &ch); @@ -1500,7 +1500,7 @@ Tcl_UtfNcmp( cs += TclUtfToUniChar(cs, &ch1); ct += TclUtfToUniChar(ct, &ch2); if (ch1 != ch2) { -#if TCL_UTF_MAX <= 3 +#if TCL_UTF_MAX < 4 /* Surrogates always report higher than non-surrogates */ if (((ch1 & 0xFC00) == 0xD800)) { if ((ch2 & 0xFC00) != 0xD800) { @@ -1551,7 +1551,7 @@ Tcl_UtfNcasecmp( cs += TclUtfToUniChar(cs, &ch1); ct += TclUtfToUniChar(ct, &ch2); if (ch1 != ch2) { -#if TCL_UTF_MAX <= 3 +#if TCL_UTF_MAX < 4 /* Surrogates always report higher than non-surrogates */ if (((ch1 & 0xFC00) == 0xD800)) { if ((ch2 & 0xFC00) != 0xD800) { @@ -1600,7 +1600,7 @@ TclUtfCmp( cs += TclUtfToUniChar(cs, &ch1); ct += TclUtfToUniChar(ct, &ch2); if (ch1 != ch2) { -#if TCL_UTF_MAX <= 3 +#if TCL_UTF_MAX < 4 /* Surrogates always report higher than non-surrogates */ if (((ch1 & 0xFC00) == 0xD800)) { if ((ch2 & 0xFC00) != 0xD800) { @@ -1646,7 +1646,7 @@ TclUtfCasecmp( cs += TclUtfToUniChar(cs, &ch1); ct += TclUtfToUniChar(ct, &ch2); if (ch1 != ch2) { -#if TCL_UTF_MAX <= 3 +#if TCL_UTF_MAX < 4 /* Surrogates always report higher than non-surrogates */ if (((ch1 & 0xFC00) == 0xD800)) { if ((ch2 & 0xFC00) != 0xD800) { @@ -2673,7 +2673,7 @@ TclUniCharMatch( *--------------------------------------------------------------------------- */ -#if TCL_UTF_MAX <= 3 +#if TCL_UTF_MAX < 4 int TclUtfToUCS4( const char *src, /* The UTF-8 string. */ -- cgit v0.12 From 6a04722bd6c3603da8a9674d7a108d73358eddab Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 25 Feb 2022 09:58:18 +0000 Subject: Use size_t in Tcl_MainEx() --- doc/Tcl_Main.3 | 2 +- generic/tcl.decls | 2 +- generic/tcl.h | 8 ++++---- generic/tclMain.c | 2 +- 4 files changed, 7 insertions(+), 7 deletions(-) diff --git a/doc/Tcl_Main.3 b/doc/Tcl_Main.3 index 986ebbe..ae32207 100644 --- a/doc/Tcl_Main.3 +++ b/doc/Tcl_Main.3 @@ -29,7 +29,7 @@ Tcl_Obj * \fBTcl_SetMainLoop\fR(\fImainLoopProc\fR) .SH ARGUMENTS .AS Tcl_MainLoopProc *mainLoopProc -.AP int argc in +.AP size_t argc in Number of elements in \fIargv\fR. .AP char *argv[] in Array of strings containing command-line arguments. On Windows, when diff --git a/generic/tcl.decls b/generic/tcl.decls index 02e0530..fe48b99 100644 --- a/generic/tcl.decls +++ b/generic/tcl.decls @@ -2572,7 +2572,7 @@ declare 3 { # Public functions that are not accessible via the stubs table. export { - void Tcl_MainEx(int argc, char **argv, Tcl_AppInitProc *appInitProc, + void Tcl_MainEx(size_t argc, char **argv, Tcl_AppInitProc *appInitProc, Tcl_Interp *interp) } export { diff --git a/generic/tcl.h b/generic/tcl.h index 6b69929..2356089 100644 --- a/generic/tcl.h +++ b/generic/tcl.h @@ -2189,7 +2189,7 @@ void * TclStubCall(void *arg); #define Tcl_Main(argc, argv, proc) Tcl_MainEx(argc, argv, proc, \ ((Tcl_SetPanicProc(Tcl_ConsolePanic), Tcl_CreateInterp()))) -EXTERN TCL_NORETURN void Tcl_MainEx(int argc, char **argv, +EXTERN TCL_NORETURN void Tcl_MainEx(size_t argc, char **argv, Tcl_AppInitProc *appInitProc, Tcl_Interp *interp); EXTERN const char * Tcl_PkgInitStubsCheck(Tcl_Interp *interp, const char *version, int exact); @@ -2217,7 +2217,7 @@ EXTERN const char *TclZipfs_AppHook(int *argc, char ***argv); # define Tcl_FindExecutable(arg) ((Tcl_FindExecutable)((const char *)(arg))) #endif # define Tcl_MainEx Tcl_MainExW - EXTERN TCL_NORETURN void Tcl_MainExW(int argc, wchar_t **argv, + EXTERN TCL_NORETURN void Tcl_MainExW(size_t argc, wchar_t **argv, Tcl_AppInitProc *appInitProc, Tcl_Interp *interp); #endif #ifdef USE_TCL_STUBS @@ -2230,11 +2230,11 @@ EXTERN const char *TclZipfs_AppHook(int *argc, char ***argv); #define TclZipfs_AppHook(argcp, argvp) \ TclInitStubTable(((const char *(*)(int *, void *))TclStubCall((void *)3))(argcp, argvp)) #define Tcl_MainExW(argc, argv, appInitProc, interp) \ - (void)((const char *(*)(int, const void *, Tcl_AppInitProc *, Tcl_Interp *)) \ + (void)((const char *(*)(size_t, const void *, Tcl_AppInitProc *, Tcl_Interp *)) \ TclStubCall((void *)4))(argc, argv, appInitProc, interp) #if !defined(_WIN32) || !defined(UNICODE) #define Tcl_MainEx(argc, argv, appInitProc, interp) \ - (void)((const char *(*)(int, const void *, Tcl_AppInitProc *, Tcl_Interp *)) \ + (void)((const char *(*)(size_t, const void *, Tcl_AppInitProc *, Tcl_Interp *)) \ TclStubCall((void *)5))(argc, argv, appInitProc, interp) #endif #define Tcl_StaticLibrary(interp, pkgName, initProc, safeInitProc) \ diff --git a/generic/tclMain.c b/generic/tclMain.c index 2778451..40f3124 100644 --- a/generic/tclMain.c +++ b/generic/tclMain.c @@ -280,7 +280,7 @@ Tcl_SourceRCFile( TCL_NORETURN void Tcl_MainEx( - int argc, /* Number of arguments. */ + size_t argc, /* Number of arguments. */ TCHAR **argv, /* Array of argument strings. */ Tcl_AppInitProc *appInitProc, /* Application-specific initialization -- cgit v0.12 From 2d07a092e5512407f7e484e7a4f058bd31264c0a Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Sun, 27 Feb 2022 18:29:55 +0000 Subject: More size_t usage, e.g. for "foreach" --- generic/tclCmdAH.c | 6 +++--- generic/tclCompCmds.c | 37 ++++++++++++++++++------------------- generic/tclCompile.h | 20 ++++++++++---------- generic/tclDisassemble.c | 17 +++++++++-------- generic/tclExecute.c | 20 ++++++++++---------- 5 files changed, 50 insertions(+), 50 deletions(-) diff --git a/generic/tclCmdAH.c b/generic/tclCmdAH.c index 9bab9bf..00bcdff 100644 --- a/generic/tclCmdAH.c +++ b/generic/tclCmdAH.c @@ -2474,9 +2474,9 @@ EachloopCmd( int objc, /* The arguments being passed in... */ Tcl_Obj *const objv[]) { - int numLists = (objc-2) / 2; + size_t i, j, numLists = (objc-2) / 2; struct ForeachState *statePtr; - int i, j, result; + int result; if (objc < 4 || (objc%2 != 0)) { Tcl_WrongNumArgs(interp, 1, objv, @@ -2558,7 +2558,7 @@ EachloopCmd( if ((statePtr->argcList[i] % statePtr->varcList[i]) != 0) { j++; } - if (j > statePtr->maxj) { + if (j > (size_t)statePtr->maxj) { statePtr->maxj = j; } } diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c index 82d09ac..39a21c8 100644 --- a/generic/tclCompCmds.c +++ b/generic/tclCompCmds.c @@ -2845,9 +2845,9 @@ CompileEachloopCmd( * body's code. Misuse loopCtTemp for storing the jump size. */ - jumpBackOffset = envPtr->exceptArrayPtr[range].continueOffset - - envPtr->exceptArrayPtr[range].codeOffset; - infoPtr->loopCtTemp = -jumpBackOffset; + jumpBackOffset = envPtr->exceptArrayPtr[range].codeOffset - + envPtr->exceptArrayPtr[range].continueOffset; + infoPtr->loopCtTemp = jumpBackOffset; /* * The command's result is an empty string if not collecting. If @@ -2895,7 +2895,7 @@ DupForeachInfo( ForeachInfo *srcPtr = (ForeachInfo *)clientData; ForeachInfo *dupPtr; ForeachVarList *srcListPtr, *dupListPtr; - int numVars, i, j, numLists = srcPtr->numLists; + size_t numVars, i, j, numLists = srcPtr->numLists; dupPtr = (ForeachInfo *)Tcl_Alloc(offsetof(ForeachInfo, varLists) + numLists * sizeof(ForeachVarList *)); @@ -2943,8 +2943,7 @@ FreeForeachInfo( { ForeachInfo *infoPtr = (ForeachInfo *)clientData; ForeachVarList *listPtr; - int numLists = infoPtr->numLists; - int i; + size_t i, numLists = infoPtr->numLists; for (i = 0; i < numLists; i++) { listPtr = infoPtr->varLists[i]; @@ -2979,7 +2978,7 @@ PrintForeachInfo( { ForeachInfo *infoPtr = (ForeachInfo *)clientData; ForeachVarList *varsPtr; - int i, j; + size_t i, j; Tcl_AppendToObj(appendObj, "data=[", -1); @@ -2987,24 +2986,24 @@ PrintForeachInfo( if (i) { Tcl_AppendToObj(appendObj, ", ", -1); } - Tcl_AppendPrintfToObj(appendObj, "%%v%u", - (unsigned) (infoPtr->firstValueTemp + i)); + Tcl_AppendPrintfToObj(appendObj, "%%v%" TCL_Z_MODIFIER "u", + (infoPtr->firstValueTemp + i)); } - Tcl_AppendPrintfToObj(appendObj, "], loop=%%v%u", - (unsigned) infoPtr->loopCtTemp); + Tcl_AppendPrintfToObj(appendObj, "], loop=%%v%" TCL_Z_MODIFIER "u", + infoPtr->loopCtTemp); for (i=0 ; inumLists ; i++) { if (i) { Tcl_AppendToObj(appendObj, ",", -1); } - Tcl_AppendPrintfToObj(appendObj, "\n\t\t it%%v%u\t[", - (unsigned) (infoPtr->firstValueTemp + i)); + Tcl_AppendPrintfToObj(appendObj, "\n\t\t it%%v%" TCL_Z_MODIFIER "u\t[", + (infoPtr->firstValueTemp + i)); varsPtr = infoPtr->varLists[i]; for (j=0 ; jnumVars ; j++) { if (j) { Tcl_AppendToObj(appendObj, ", ", -1); } - Tcl_AppendPrintfToObj(appendObj, "%%v%u", - (unsigned) varsPtr->varIndexes[j]); + Tcl_AppendPrintfToObj(appendObj, "%%v%" TCL_Z_MODIFIER "u", + (size_t)varsPtr->varIndexes[j]); } Tcl_AppendToObj(appendObj, "]", -1); } @@ -3019,9 +3018,9 @@ PrintNewForeachInfo( { ForeachInfo *infoPtr = (ForeachInfo *)clientData; ForeachVarList *varsPtr; - int i, j; + size_t i, j; - Tcl_AppendPrintfToObj(appendObj, "jumpOffset=%+d, vars=", + Tcl_AppendPrintfToObj(appendObj, "jumpOffset=%+" TCL_Z_MODIFIER "d, vars=", infoPtr->loopCtTemp); for (i=0 ; inumLists ; i++) { if (i) { @@ -3049,7 +3048,7 @@ DisassembleForeachInfo( { ForeachInfo *infoPtr = (ForeachInfo *)clientData; ForeachVarList *varsPtr; - int i, j; + size_t i, j; Tcl_Obj *objPtr, *innerPtr; /* @@ -3096,7 +3095,7 @@ DisassembleNewForeachInfo( { ForeachInfo *infoPtr = (ForeachInfo *)clientData; ForeachVarList *varsPtr; - int i, j; + size_t i, j; Tcl_Obj *objPtr, *innerPtr; /* diff --git a/generic/tclCompile.h b/generic/tclCompile.h index b7d98b6..c24150d 100644 --- a/generic/tclCompile.h +++ b/generic/tclCompile.h @@ -871,7 +871,7 @@ typedef struct InstructionDesc { * computations. The value INT_MIN signals * that the instruction's worst case effect is * (1-opnd1). */ - int numOperands; /* Number of operands. */ + size_t numOperands; /* Number of operands. */ InstOperandType opTypes[MAX_INSTRUCTION_OPERANDS]; /* The type of each operand. */ } InstructionDesc; @@ -934,14 +934,14 @@ typedef enum { typedef struct JumpFixup { TclJumpType jumpType; /* Indicates the kind of jump. */ - unsigned int codeOffset; /* Offset of the first byte of the one-byte + size_t codeOffset; /* Offset of the first byte of the one-byte * forward jump's code. */ - int cmdIndex; /* Index of the first command after the one + size_t cmdIndex; /* Index of the first command after the one * for which the jump was emitted. Used to * update the code offsets for subsequent * commands if the two-byte jump at jumpPc * must be replaced with a five-byte one. */ - int exceptIndex; /* Index of the first range entry in the + size_t exceptIndex; /* Index of the first range entry in the * ExceptionRange array after the current one. * This field is used to adjust the code * offsets in subsequent ExceptionRange @@ -953,8 +953,8 @@ typedef struct JumpFixup { typedef struct JumpFixupArray { JumpFixup *fixup; /* Points to start of jump fixup array. */ - int next; /* Index of next free array entry. */ - int end; /* Index of last usable entry in array. */ + size_t next; /* Index of next free array entry. */ + size_t end; /* Index of last usable entry in array. */ int mallocedArray; /* 1 if array was expanded and fixups points * into the heap, else 0. */ JumpFixup staticFixupSpace[JUMPFIXUP_INIT_ENTRIES]; @@ -969,7 +969,7 @@ typedef struct JumpFixupArray { */ typedef struct ForeachVarList { - int numVars; /* The number of variables in the list. */ + size_t numVars; /* The number of variables in the list. */ int varIndexes[TCLFLEXARRAY];/* An array of the indexes ("slot numbers") * for each variable in the procedure's array * of local variables. Only scalar variables @@ -986,11 +986,11 @@ typedef struct ForeachVarList { */ typedef struct ForeachInfo { - int numLists; /* The number of both the variable and value + size_t numLists; /* The number of both the variable and value * lists of the foreach command. */ - int firstValueTemp; /* Index of the first temp var in a proc frame + size_t firstValueTemp; /* Index of the first temp var in a proc frame * used to point to a value list. */ - int loopCtTemp; /* Index of temp var in a proc frame holding + size_t loopCtTemp; /* Index of temp var in a proc frame holding * the loop's iteration count. Used to * determine next value list element to assign * each loop var. */ diff --git a/generic/tclDisassemble.c b/generic/tclDisassemble.c index f946221..4839586 100644 --- a/generic/tclDisassemble.c +++ b/generic/tclDisassemble.c @@ -541,7 +541,8 @@ FormatInstruction( const InstructionDesc *instDesc = &tclInstructionTable[opCode]; unsigned char *codeStart = codePtr->codeStart; unsigned pcOffset = pc - codeStart; - int opnd = 0, i, j, numBytes = 1; + int opnd = 0, j, numBytes = 1; + size_t i; int localCt = procPtr ? procPtr->numCompiledLocals : 0; CompiledLocal *localPtr = procPtr ? procPtr->firstLocalPtr : NULL; char suffixBuffer[128]; /* Additional info to print after main opcode @@ -941,8 +942,8 @@ DisassembleByteCodeAsDicts( Tcl_Obj *description, *literals, *variables, *instructions, *inst; Tcl_Obj *aux, *exn, *commands, *file; unsigned char *pc, *opnd, *codeOffPtr, *codeLenPtr, *srcOffPtr, *srcLenPtr; - int codeOffset, codeLength, sourceOffset, sourceLength; - int i, val, line; + int val, line, codeOffset, codeLength, sourceOffset, sourceLength; + size_t i; ByteCodeGetInternalRep(objPtr, &tclByteCodeType, codePtr); @@ -951,7 +952,7 @@ DisassembleByteCodeAsDicts( */ TclNewObj(literals); - for (i=0 ; inumLitObjects ; i++) { + for (i=0 ; i<(size_t)codePtr->numLitObjects ; i++) { Tcl_ListObjAppendElement(NULL, literals, codePtr->objArrayPtr[i]); } @@ -961,7 +962,7 @@ DisassembleByteCodeAsDicts( TclNewObj(variables); if (codePtr->procPtr) { - int localCount = codePtr->procPtr->numCompiledLocals; + size_t localCount = codePtr->procPtr->numCompiledLocals; CompiledLocal *localPtr = codePtr->procPtr->firstLocalPtr; for (i=0 ; inextPtr) { @@ -1111,7 +1112,7 @@ DisassembleByteCodeAsDicts( */ TclNewObj(aux); - for (i=0 ; inumAuxDataItems ; i++) { + for (i=0 ; i<(size_t)codePtr->numAuxDataItems ; i++) { AuxData *auxData = &codePtr->auxDataArrayPtr[i]; Tcl_Obj *auxDesc = Tcl_NewStringObj(auxData->type->name, -1); @@ -1138,7 +1139,7 @@ DisassembleByteCodeAsDicts( */ TclNewObj(exn); - for (i=0 ; inumExceptRanges ; i++) { + for (i=0 ; i<(size_t)codePtr->numExceptRanges ; i++) { ExceptionRange *rangePtr = &codePtr->exceptArrayPtr[i]; switch (rangePtr->type) { @@ -1178,7 +1179,7 @@ DisassembleByteCodeAsDicts( srcOffPtr = codePtr->srcDeltaStart; srcLenPtr = codePtr->srcLengthStart; codeOffset = sourceOffset = 0; - for (i=0 ; inumCommands ; i++) { + for (i=0 ; i<(size_t)codePtr->numCommands ; i++) { Tcl_Obj *cmd; codeOffset += Decode(codeOffPtr); diff --git a/generic/tclExecute.c b/generic/tclExecute.c index bea9798..ab4aef7 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -4424,11 +4424,11 @@ TEBCresume( if (traceInstructions) { strncpy(cmdNameBuf, TclGetString(objv[0]), 20); } else { - fprintf(stdout, "%d: (%u) invoking ", + fprintf(stdout, "%d: (%" TCL_Z_MODIFIER "u) invoking ", iPtr->numLevels, - (unsigned)(pc - codePtr->codeStart)); + (size_t)(pc - codePtr->codeStart)); } - for (i = 0; i < opnd; i++) { + for (i = 0; i < (size_t)opnd; i++) { TclPrintObject(stdout, objv[i], 15); fprintf(stdout, " "); } @@ -6218,11 +6218,11 @@ TEBCresume( ForeachInfo *infoPtr; Tcl_Obj *listPtr, **elements; ForeachVarList *varListPtr; - int numLists, listLen, numVars; - int listTmpDepth; + size_t numLists, numVars; + int listTmpDepth, listLen; size_t iterNum, iterMax, iterTmp; - int varIndex, valIndex, j; - long i; + size_t varIndex, valIndex, j; + size_t i; case INST_FOREACH_START: /* @@ -6330,7 +6330,7 @@ TEBCresume( valIndex = (iterNum * numVars); for (j = 0; j < numVars; j++) { - if (valIndex >= listLen) { + if (valIndex >= (size_t)listLen) { TclNewObj(valuePtr); } else { valuePtr = elements[valIndex]; @@ -6355,7 +6355,7 @@ TEBCresume( if (TclPtrSetVarIdx(interp, varPtr, NULL, NULL, NULL, valuePtr, TCL_LEAVE_ERR_MSG, varIndex)==NULL){ CACHE_STACK_INFO(); - TRACE_APPEND(("ERROR init. index temp %d: %.30s", + TRACE_APPEND(("ERROR init. index temp %" TCL_Z_MODIFIER "d: %.30s", varIndex, O2S(Tcl_GetObjResult(interp)))); goto gotError; } @@ -6402,7 +6402,7 @@ TEBCresume( tmpPtr = OBJ_AT_DEPTH(1); infoPtr = (ForeachInfo *)tmpPtr->internalRep.twoPtrValue.ptr1; numLists = infoPtr->numLists; - TRACE_APPEND(("=> appending to list at depth %d\n", 3 + numLists)); + TRACE_APPEND(("=> appending to list at depth %" TCL_Z_MODIFIER "d\n", 3 + numLists)); objPtr = OBJ_AT_DEPTH(3 + numLists); Tcl_ListObjAppendElement(NULL, objPtr, OBJ_AT_TOS); -- cgit v0.12 From 33eea6856d85ce80c6097dd8d3673632e57b38bf Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 28 Feb 2022 11:43:20 +0000 Subject: Backout part of previous commit, making compile.test work again with --enable-symbols=all --- generic/tclCmdAH.c | 6 +++--- generic/tclCompCmds.c | 12 ++++++------ generic/tclCompile.h | 12 ++++++------ generic/tclDisassemble.c | 17 ++++++++--------- generic/tclExecute.c | 18 +++++++++--------- 5 files changed, 32 insertions(+), 33 deletions(-) diff --git a/generic/tclCmdAH.c b/generic/tclCmdAH.c index 00bcdff..9bab9bf 100644 --- a/generic/tclCmdAH.c +++ b/generic/tclCmdAH.c @@ -2474,9 +2474,9 @@ EachloopCmd( int objc, /* The arguments being passed in... */ Tcl_Obj *const objv[]) { - size_t i, j, numLists = (objc-2) / 2; + int numLists = (objc-2) / 2; struct ForeachState *statePtr; - int result; + int i, j, result; if (objc < 4 || (objc%2 != 0)) { Tcl_WrongNumArgs(interp, 1, objv, @@ -2558,7 +2558,7 @@ EachloopCmd( if ((statePtr->argcList[i] % statePtr->varcList[i]) != 0) { j++; } - if (j > (size_t)statePtr->maxj) { + if (j > statePtr->maxj) { statePtr->maxj = j; } } diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c index 39a21c8..a44e7dd 100644 --- a/generic/tclCompCmds.c +++ b/generic/tclCompCmds.c @@ -2845,9 +2845,9 @@ CompileEachloopCmd( * body's code. Misuse loopCtTemp for storing the jump size. */ - jumpBackOffset = envPtr->exceptArrayPtr[range].codeOffset - - envPtr->exceptArrayPtr[range].continueOffset; - infoPtr->loopCtTemp = jumpBackOffset; + jumpBackOffset = envPtr->exceptArrayPtr[range].continueOffset - + envPtr->exceptArrayPtr[range].codeOffset; + infoPtr->loopCtTemp = -jumpBackOffset; /* * The command's result is an empty string if not collecting. If @@ -2895,7 +2895,7 @@ DupForeachInfo( ForeachInfo *srcPtr = (ForeachInfo *)clientData; ForeachInfo *dupPtr; ForeachVarList *srcListPtr, *dupListPtr; - size_t numVars, i, j, numLists = srcPtr->numLists; + int numVars, i, j, numLists = srcPtr->numLists; dupPtr = (ForeachInfo *)Tcl_Alloc(offsetof(ForeachInfo, varLists) + numLists * sizeof(ForeachVarList *)); @@ -3002,8 +3002,8 @@ PrintForeachInfo( if (j) { Tcl_AppendToObj(appendObj, ", ", -1); } - Tcl_AppendPrintfToObj(appendObj, "%%v%" TCL_Z_MODIFIER "u", - (size_t)varsPtr->varIndexes[j]); + Tcl_AppendPrintfToObj(appendObj, "%%v%u", + (unsigned) varsPtr->varIndexes[j]); } Tcl_AppendToObj(appendObj, "]", -1); } diff --git a/generic/tclCompile.h b/generic/tclCompile.h index c24150d..0d37c6b 100644 --- a/generic/tclCompile.h +++ b/generic/tclCompile.h @@ -871,7 +871,7 @@ typedef struct InstructionDesc { * computations. The value INT_MIN signals * that the instruction's worst case effect is * (1-opnd1). */ - size_t numOperands; /* Number of operands. */ + int numOperands; /* Number of operands. */ InstOperandType opTypes[MAX_INSTRUCTION_OPERANDS]; /* The type of each operand. */ } InstructionDesc; @@ -934,14 +934,14 @@ typedef enum { typedef struct JumpFixup { TclJumpType jumpType; /* Indicates the kind of jump. */ - size_t codeOffset; /* Offset of the first byte of the one-byte + unsigned int codeOffset; /* Offset of the first byte of the one-byte * forward jump's code. */ - size_t cmdIndex; /* Index of the first command after the one + int cmdIndex; /* Index of the first command after the one * for which the jump was emitted. Used to * update the code offsets for subsequent * commands if the two-byte jump at jumpPc * must be replaced with a five-byte one. */ - size_t exceptIndex; /* Index of the first range entry in the + int exceptIndex; /* Index of the first range entry in the * ExceptionRange array after the current one. * This field is used to adjust the code * offsets in subsequent ExceptionRange @@ -953,8 +953,8 @@ typedef struct JumpFixup { typedef struct JumpFixupArray { JumpFixup *fixup; /* Points to start of jump fixup array. */ - size_t next; /* Index of next free array entry. */ - size_t end; /* Index of last usable entry in array. */ + int next; /* Index of next free array entry. */ + int end; /* Index of last usable entry in array. */ int mallocedArray; /* 1 if array was expanded and fixups points * into the heap, else 0. */ JumpFixup staticFixupSpace[JUMPFIXUP_INIT_ENTRIES]; diff --git a/generic/tclDisassemble.c b/generic/tclDisassemble.c index 4839586..f946221 100644 --- a/generic/tclDisassemble.c +++ b/generic/tclDisassemble.c @@ -541,8 +541,7 @@ FormatInstruction( const InstructionDesc *instDesc = &tclInstructionTable[opCode]; unsigned char *codeStart = codePtr->codeStart; unsigned pcOffset = pc - codeStart; - int opnd = 0, j, numBytes = 1; - size_t i; + int opnd = 0, i, j, numBytes = 1; int localCt = procPtr ? procPtr->numCompiledLocals : 0; CompiledLocal *localPtr = procPtr ? procPtr->firstLocalPtr : NULL; char suffixBuffer[128]; /* Additional info to print after main opcode @@ -942,8 +941,8 @@ DisassembleByteCodeAsDicts( Tcl_Obj *description, *literals, *variables, *instructions, *inst; Tcl_Obj *aux, *exn, *commands, *file; unsigned char *pc, *opnd, *codeOffPtr, *codeLenPtr, *srcOffPtr, *srcLenPtr; - int val, line, codeOffset, codeLength, sourceOffset, sourceLength; - size_t i; + int codeOffset, codeLength, sourceOffset, sourceLength; + int i, val, line; ByteCodeGetInternalRep(objPtr, &tclByteCodeType, codePtr); @@ -952,7 +951,7 @@ DisassembleByteCodeAsDicts( */ TclNewObj(literals); - for (i=0 ; i<(size_t)codePtr->numLitObjects ; i++) { + for (i=0 ; inumLitObjects ; i++) { Tcl_ListObjAppendElement(NULL, literals, codePtr->objArrayPtr[i]); } @@ -962,7 +961,7 @@ DisassembleByteCodeAsDicts( TclNewObj(variables); if (codePtr->procPtr) { - size_t localCount = codePtr->procPtr->numCompiledLocals; + int localCount = codePtr->procPtr->numCompiledLocals; CompiledLocal *localPtr = codePtr->procPtr->firstLocalPtr; for (i=0 ; inextPtr) { @@ -1112,7 +1111,7 @@ DisassembleByteCodeAsDicts( */ TclNewObj(aux); - for (i=0 ; i<(size_t)codePtr->numAuxDataItems ; i++) { + for (i=0 ; inumAuxDataItems ; i++) { AuxData *auxData = &codePtr->auxDataArrayPtr[i]; Tcl_Obj *auxDesc = Tcl_NewStringObj(auxData->type->name, -1); @@ -1139,7 +1138,7 @@ DisassembleByteCodeAsDicts( */ TclNewObj(exn); - for (i=0 ; i<(size_t)codePtr->numExceptRanges ; i++) { + for (i=0 ; inumExceptRanges ; i++) { ExceptionRange *rangePtr = &codePtr->exceptArrayPtr[i]; switch (rangePtr->type) { @@ -1179,7 +1178,7 @@ DisassembleByteCodeAsDicts( srcOffPtr = codePtr->srcDeltaStart; srcLenPtr = codePtr->srcLengthStart; codeOffset = sourceOffset = 0; - for (i=0 ; i<(size_t)codePtr->numCommands ; i++) { + for (i=0 ; inumCommands ; i++) { Tcl_Obj *cmd; codeOffset += Decode(codeOffPtr); diff --git a/generic/tclExecute.c b/generic/tclExecute.c index ab4aef7..0eb971f 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -4424,9 +4424,9 @@ TEBCresume( if (traceInstructions) { strncpy(cmdNameBuf, TclGetString(objv[0]), 20); } else { - fprintf(stdout, "%d: (%" TCL_Z_MODIFIER "u) invoking ", + fprintf(stdout, "%d: (%u) invoking ", iPtr->numLevels, - (size_t)(pc - codePtr->codeStart)); + (unsigned)(pc - codePtr->codeStart)); } for (i = 0; i < (size_t)opnd; i++) { TclPrintObject(stdout, objv[i], 15); @@ -6218,11 +6218,11 @@ TEBCresume( ForeachInfo *infoPtr; Tcl_Obj *listPtr, **elements; ForeachVarList *varListPtr; - size_t numLists, numVars; - int listTmpDepth, listLen; + int numLists, listLen, numVars; + int listTmpDepth; size_t iterNum, iterMax, iterTmp; - size_t varIndex, valIndex, j; - size_t i; + int varIndex, valIndex, j; + long i; case INST_FOREACH_START: /* @@ -6330,7 +6330,7 @@ TEBCresume( valIndex = (iterNum * numVars); for (j = 0; j < numVars; j++) { - if (valIndex >= (size_t)listLen) { + if (valIndex >= listLen) { TclNewObj(valuePtr); } else { valuePtr = elements[valIndex]; @@ -6355,7 +6355,7 @@ TEBCresume( if (TclPtrSetVarIdx(interp, varPtr, NULL, NULL, NULL, valuePtr, TCL_LEAVE_ERR_MSG, varIndex)==NULL){ CACHE_STACK_INFO(); - TRACE_APPEND(("ERROR init. index temp %" TCL_Z_MODIFIER "d: %.30s", + TRACE_APPEND(("ERROR init. index temp %d: %.30s", varIndex, O2S(Tcl_GetObjResult(interp)))); goto gotError; } @@ -6402,7 +6402,7 @@ TEBCresume( tmpPtr = OBJ_AT_DEPTH(1); infoPtr = (ForeachInfo *)tmpPtr->internalRep.twoPtrValue.ptr1; numLists = infoPtr->numLists; - TRACE_APPEND(("=> appending to list at depth %" TCL_Z_MODIFIER "d\n", 3 + numLists)); + TRACE_APPEND(("=> appending to list at depth %d\n", 3 + numLists)); objPtr = OBJ_AT_DEPTH(3 + numLists); Tcl_ListObjAppendElement(NULL, objPtr, OBJ_AT_TOS); -- cgit v0.12 From 9a1c1f5e11679feeaafd9c788631fc98faf6945e Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 1 Mar 2022 08:42:33 +0000 Subject: Use size_t in AuxDataPrintProc --- generic/tclBinary.c | 6 ++--- generic/tclCompCmds.c | 12 +++++----- generic/tclCompCmdsSZ.c | 8 +++---- generic/tclCompile.h | 6 ++--- generic/tclExecute.c | 62 ++++++++++++++++++++++++------------------------- unix/tclUnixPipe.c | 2 +- win/tclWinPipe.c | 4 ++-- 7 files changed, 50 insertions(+), 50 deletions(-) diff --git a/generic/tclBinary.c b/generic/tclBinary.c index c1569d5..dd8bbc0 100644 --- a/generic/tclBinary.c +++ b/generic/tclBinary.c @@ -2292,9 +2292,9 @@ ScanNumber( if (flags & BINARY_UNSIGNED) { return Tcl_NewWideIntObj((Tcl_WideInt)(unsigned long)value); } - if ((value & (((unsigned) 1) << 31)) && (value > 0)) { - value -= (((unsigned) 1) << 31); - value -= (((unsigned) 1) << 31); + if ((value & (1U << 31)) && (value > 0)) { + value -= (1U << 31); + value -= (1U << 31); } returnNumericObject: diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c index a44e7dd..e95b1fb 100644 --- a/generic/tclCompCmds.c +++ b/generic/tclCompCmds.c @@ -2292,7 +2292,7 @@ PrintDictUpdateInfo( ClientData clientData, Tcl_Obj *appendObj, TCL_UNUSED(ByteCode *), - TCL_UNUSED(unsigned int)) + TCL_UNUSED(size_t)) { DictUpdateInfo *duiPtr = (DictUpdateInfo *)clientData; size_t i; @@ -2310,7 +2310,7 @@ DisassembleDictUpdateInfo( ClientData clientData, Tcl_Obj *dictObj, TCL_UNUSED(ByteCode *), - TCL_UNUSED(unsigned int)) + TCL_UNUSED(size_t)) { DictUpdateInfo *duiPtr = (DictUpdateInfo *)clientData; size_t i; @@ -2974,7 +2974,7 @@ PrintForeachInfo( ClientData clientData, Tcl_Obj *appendObj, TCL_UNUSED(ByteCode *), - TCL_UNUSED(unsigned int)) + TCL_UNUSED(size_t)) { ForeachInfo *infoPtr = (ForeachInfo *)clientData; ForeachVarList *varsPtr; @@ -3014,7 +3014,7 @@ PrintNewForeachInfo( ClientData clientData, Tcl_Obj *appendObj, TCL_UNUSED(ByteCode *), - TCL_UNUSED(unsigned int)) + TCL_UNUSED(size_t)) { ForeachInfo *infoPtr = (ForeachInfo *)clientData; ForeachVarList *varsPtr; @@ -3044,7 +3044,7 @@ DisassembleForeachInfo( ClientData clientData, Tcl_Obj *dictObj, TCL_UNUSED(ByteCode *), - TCL_UNUSED(unsigned int)) + TCL_UNUSED(size_t)) { ForeachInfo *infoPtr = (ForeachInfo *)clientData; ForeachVarList *varsPtr; @@ -3091,7 +3091,7 @@ DisassembleNewForeachInfo( ClientData clientData, Tcl_Obj *dictObj, TCL_UNUSED(ByteCode *), - TCL_UNUSED(unsigned int)) + TCL_UNUSED(size_t)) { ForeachInfo *infoPtr = (ForeachInfo *)clientData; ForeachVarList *varsPtr; diff --git a/generic/tclCompCmdsSZ.c b/generic/tclCompCmdsSZ.c index dc07e49..0dad757 100644 --- a/generic/tclCompCmdsSZ.c +++ b/generic/tclCompCmdsSZ.c @@ -2586,13 +2586,13 @@ PrintJumptableInfo( ClientData clientData, Tcl_Obj *appendObj, TCL_UNUSED(ByteCode *), - unsigned int pcOffset) + size_t pcOffset) { JumptableInfo *jtPtr = (JumptableInfo *)clientData; Tcl_HashEntry *hPtr; Tcl_HashSearch search; const char *keyPtr; - int offset, i = 0; + size_t offset, i = 0; hPtr = Tcl_FirstHashEntry(&jtPtr->hashTable, &search); for (; hPtr ; hPtr = Tcl_NextHashEntry(&search)) { @@ -2605,7 +2605,7 @@ PrintJumptableInfo( Tcl_AppendToObj(appendObj, "\n\t\t", -1); } } - Tcl_AppendPrintfToObj(appendObj, "\"%s\"->pc %d", + Tcl_AppendPrintfToObj(appendObj, "\"%s\"->pc %" TCL_Z_MODIFIER "u", keyPtr, pcOffset + offset); } } @@ -2615,7 +2615,7 @@ DisassembleJumptableInfo( ClientData clientData, Tcl_Obj *dictObj, TCL_UNUSED(ByteCode *), - TCL_UNUSED(unsigned int)) + TCL_UNUSED(size_t)) { JumptableInfo *jtPtr = (JumptableInfo *)clientData; Tcl_Obj *mapping; diff --git a/generic/tclCompile.h b/generic/tclCompile.h index 0d37c6b..fce7111 100644 --- a/generic/tclCompile.h +++ b/generic/tclCompile.h @@ -221,7 +221,7 @@ typedef void *(AuxDataDupProc) (void *clientData); typedef void (AuxDataFreeProc) (void *clientData); typedef void (AuxDataPrintProc)(void *clientData, Tcl_Obj *appendObj, struct ByteCode *codePtr, - unsigned int pcOffset); + size_t pcOffset); /* * We define a separate AuxDataType struct to hold type-related information @@ -1805,8 +1805,8 @@ MODULE_SCOPE void TclDTraceInfo(Tcl_Obj *info, const char **args, int *argsi); FILE *tclDTraceDebugLog = NULL; \ void TclDTraceOpenDebugLog(void) { \ char n[35]; \ - sprintf(n, "/tmp/tclDTraceDebug-%" TCL_Z_MODIFIER "u.log", \ - (size_t) getpid()); \ + sprintf(n, "/tmp/tclDTraceDebug-%d.log", \ + getpid()); \ tclDTraceDebugLog = fopen(n, "a"); \ } diff --git a/generic/tclExecute.c b/generic/tclExecute.c index 0eb971f..47b48fb 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -379,9 +379,9 @@ VarHashCreateVar( #ifdef TCL_COMPILE_DEBUG # define TRACE(a) \ while (traceInstructions) { \ - fprintf(stdout, "%2d: %2d (%u) %s ", iPtr->numLevels, \ + fprintf(stdout, "%2d: %2d (%" TCL_Z_MODIFIER "u) %s ", iPtr->numLevels, \ (int) CURR_DEPTH, \ - (unsigned) (pc - codePtr->codeStart), \ + (size_t) (pc - codePtr->codeStart), \ GetOpcodeName(pc)); \ printf a; \ break; \ @@ -395,9 +395,9 @@ VarHashCreateVar( TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp)))); # define TRACE_WITH_OBJ(a, objPtr) \ while (traceInstructions) { \ - fprintf(stdout, "%2d: %2d (%u) %s ", iPtr->numLevels, \ + fprintf(stdout, "%2d: %2d (%" TCL_Z_MODIFIER "u) %s ", iPtr->numLevels, \ (int) CURR_DEPTH, \ - (unsigned) (pc - codePtr->codeStart), \ + (size_t) (pc - codePtr->codeStart), \ GetOpcodeName(pc)); \ printf a; \ TclPrintObject(stdout, objPtr, 30); \ @@ -2389,8 +2389,8 @@ TEBCresume( if (traceInstructions) { TRACE_APPEND(("YIELD...\n")); } else { - fprintf(stdout, "%d: (%u) yielding value \"%.30s\"\n", - iPtr->numLevels, (unsigned)(pc - codePtr->codeStart), + fprintf(stdout, "%d: (%" TCL_Z_MODIFIER "u) yielding value \"%.30s\"\n", + iPtr->numLevels, (size_t)(pc - codePtr->codeStart), Tcl_GetString(OBJ_AT_TOS)); } fflush(stdout); @@ -2432,8 +2432,8 @@ TEBCresume( TRACE(("[%.30s] => YIELD...\n", O2S(valuePtr))); } else { /* FIXME: What is the right thing to trace? */ - fprintf(stdout, "%d: (%u) yielding to [%.30s]\n", - iPtr->numLevels, (unsigned)(pc - codePtr->codeStart), + fprintf(stdout, "%d: (%" TCL_Z_MODIFIER "u) yielding to [%.30s]\n", + iPtr->numLevels, (size_t)(pc - codePtr->codeStart), TclGetString(valuePtr)); } fflush(stdout); @@ -2791,8 +2791,8 @@ TEBCresume( strncpy(cmdNameBuf, TclGetString(objv[0]), 20); TRACE(("%u => call ", objc)); } else { - fprintf(stdout, "%d: (%u) invoking ", iPtr->numLevels, - (unsigned)(pc - codePtr->codeStart)); + fprintf(stdout, "%d: (%" TCL_Z_MODIFIER "u) invoking ", iPtr->numLevels, + (size_t)(pc - codePtr->codeStart)); } for (i = 0; i < objc; i++) { TclPrintObject(stdout, objv[i], 15); @@ -2839,8 +2839,8 @@ TEBCresume( TRACE(("%u => call (implementation %s) ", objc, O2S(objPtr))); } else { fprintf(stdout, - "%d: (%u) invoking (using implementation %s) ", - iPtr->numLevels, (unsigned)(pc - codePtr->codeStart), + "%d: (%" TCL_Z_MODIFIER "u) invoking (using implementation %s) ", + iPtr->numLevels, (size_t)(pc - codePtr->codeStart), O2S(objPtr)); } for (i = 0; i < objc; i++) { @@ -4139,15 +4139,15 @@ TEBCresume( case INST_JUMP1: opnd = TclGetInt1AtPtr(pc+1); - TRACE(("%d => new pc %u\n", opnd, - (unsigned)(pc + opnd - codePtr->codeStart))); + TRACE(("%d => new pc %" TCL_Z_MODIFIER "u\n", opnd, + (size_t)(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))); + TRACE(("%d => new pc %" TCL_Z_MODIFIER "u\n", opnd, + (size_t)(pc + opnd - codePtr->codeStart))); NEXT_INST_F(opnd, 0, 0); { @@ -4189,8 +4189,8 @@ TEBCresume( #ifdef TCL_COMPILE_DEBUG if (b) { if ((*pc == INST_JUMP_TRUE1) || (*pc == INST_JUMP_TRUE4)) { - TRACE_APPEND(("%.20s true, new pc %u\n", O2S(valuePtr), - (unsigned)(pc + jmpOffset[1] - codePtr->codeStart))); + TRACE_APPEND(("%.20s true, new pc %" TCL_Z_MODIFIER "u\n", O2S(valuePtr), + (size_t)(pc + jmpOffset[1] - codePtr->codeStart))); } else { TRACE_APPEND(("%.20s true\n", O2S(valuePtr))); } @@ -4198,8 +4198,8 @@ TEBCresume( if ((*pc == INST_JUMP_TRUE1) || (*pc == INST_JUMP_TRUE4)) { TRACE_APPEND(("%.20s false\n", O2S(valuePtr))); } else { - TRACE_APPEND(("%.20s false, new pc %u\n", O2S(valuePtr), - (unsigned)(pc + jmpOffset[0] - codePtr->codeStart))); + TRACE_APPEND(("%.20s false, new pc %" TCL_Z_MODIFIER "u\n", O2S(valuePtr), + (size_t)(pc + jmpOffset[0] - codePtr->codeStart))); } } #endif @@ -4223,8 +4223,8 @@ TEBCresume( if (hPtr != NULL) { int jumpOffset = PTR2INT(Tcl_GetHashValue(hPtr)); - TRACE_APPEND(("found in table, new pc %u\n", - (unsigned)(pc - codePtr->codeStart + jumpOffset))); + TRACE_APPEND(("found in table, new pc %" TCL_Z_MODIFIER "u\n", + (size_t)(pc - codePtr->codeStart + jumpOffset))); NEXT_INST_F(jumpOffset, 1, 0); } else { TRACE_APPEND(("not found in table\n")); @@ -4424,9 +4424,9 @@ TEBCresume( if (traceInstructions) { strncpy(cmdNameBuf, TclGetString(objv[0]), 20); } else { - fprintf(stdout, "%d: (%u) invoking ", + fprintf(stdout, "%d: (%" TCL_Z_MODIFIER "u) invoking ", iPtr->numLevels, - (unsigned)(pc - codePtr->codeStart)); + (size_t)(pc - codePtr->codeStart)); } for (i = 0; i < (size_t)opnd; i++) { TclPrintObject(stdout, objv[i], 15); @@ -4526,8 +4526,8 @@ TEBCresume( if (traceInstructions) { strncpy(cmdNameBuf, TclGetString(objv[0]), 20); } else { - fprintf(stdout, "%d: (%u) invoking ", - iPtr->numLevels, (unsigned)(pc - codePtr->codeStart)); + fprintf(stdout, "%d: (%" TCL_Z_MODIFIER "u) invoking ", + iPtr->numLevels, (size_t)(pc - codePtr->codeStart)); } for (i = 0; i < opnd; i++) { TclPrintObject(stdout, objv[i], 15); @@ -7412,9 +7412,9 @@ TEBCresume( #ifdef TCL_COMPILE_DEBUG if (traceInstructions) { fprintf(stdout, " ... found catch at %d, catchTop=%d, " - "unwound to %ld, new pc %u\n", + "unwound to %ld, new pc %" TCL_Z_MODIFIER "u\n", rangePtr->codeOffset, (int) (catchTop - initCatchTop - 1), - (long)*catchTop, (unsigned) rangePtr->catchOffset); + (long)*catchTop, (size_t) rangePtr->catchOffset); } #endif pc = (codePtr->codeStart + rangePtr->catchOffset); @@ -7450,10 +7450,10 @@ TEBCresume( if (tosPtr < initTosPtr) { fprintf(stderr, - "\nTclNRExecuteByteCode: abnormal return at pc %u: " + "\nTclNRExecuteByteCode: abnormal return at pc %" TCL_Z_MODIFIER "u: " "stack top %d < entry stack top %d\n", - (unsigned)(pc - codePtr->codeStart), - (unsigned) CURR_DEPTH, (unsigned) 0); + (size_t)(pc - codePtr->codeStart), + (int) CURR_DEPTH, 0); Tcl_Panic("TclNRExecuteByteCode execution failure: end stack top < start stack top"); } CLANG_ASSERT(bcFramePtr); diff --git a/unix/tclUnixPipe.c b/unix/tclUnixPipe.c index bb0943a..27e8182 100644 --- a/unix/tclUnixPipe.c +++ b/unix/tclUnixPipe.c @@ -1289,7 +1289,7 @@ Tcl_PidObjCmd( TclNewObj(resultPtr); for (i = 0; i < pipePtr->numPids; i++) { Tcl_ListObjAppendElement(NULL, resultPtr, - Tcl_NewWideIntObj(PTR2INT(TclpGetPid(pipePtr->pidPtr[i])))); + Tcl_NewWideIntObj(TclpGetPid(pipePtr->pidPtr[i]))); } Tcl_SetObjResult(interp, resultPtr); } diff --git a/win/tclWinPipe.c b/win/tclWinPipe.c index 41692a5..b4f9ff0 100644 --- a/win/tclWinPipe.c +++ b/win/tclWinPipe.c @@ -2759,7 +2759,7 @@ Tcl_PidObjCmd( return TCL_ERROR; } if (objc == 1) { - Tcl_SetObjResult(interp, Tcl_NewWideIntObj((unsigned) getpid())); + Tcl_SetObjResult(interp, Tcl_NewWideIntObj(getpid())); } else { chan = Tcl_GetChannel(interp, TclGetString(objv[1]), NULL); @@ -2775,7 +2775,7 @@ Tcl_PidObjCmd( TclNewObj(resultPtr); for (i = 0; i < pipePtr->numPids; i++) { Tcl_ListObjAppendElement(/*interp*/ NULL, resultPtr, - Tcl_NewWideIntObj((unsigned) + Tcl_NewWideIntObj( TclpGetPid(pipePtr->pidPtr[i]))); } Tcl_SetObjResult(interp, resultPtr); -- cgit v0.12 From 6dc1f8021ed597b13289a02c41c2e9660525a81a Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 2 Mar 2022 16:00:19 +0000 Subject: Use TIP #613's Tcl_GetIndexFromObj() to eliminate typecasts which are no longer necessary --- generic/regc_locale.c | 48 ++++++++++++++++++++++++------------------------ generic/tclCmdMZ.c | 28 ++++++++++++---------------- generic/tclCompCmdsSZ.c | 10 +++++++--- generic/tclConfig.c | 6 +++--- generic/tclDictObj.c | 6 +++--- generic/tclDisassemble.c | 6 +++--- generic/tclEnsemble.c | 5 +++-- generic/tclEvent.c | 5 ++--- generic/tclFileName.c | 6 +++--- generic/tclIOCmd.c | 12 ++++++------ generic/tclLoad.c | 14 +++++++------- generic/tclOOBasic.c | 5 ++--- generic/tclOOInfo.c | 20 ++++++++++---------- generic/tclPkg.c | 6 +++--- generic/tclProcess.c | 6 +++--- generic/tclTest.c | 29 ++++++++++++++--------------- generic/tclThreadTest.c | 5 ++--- generic/tclTrace.c | 5 ++--- generic/tclVar.c | 12 ++++++------ generic/tclZlib.c | 24 ++++++++++++------------ 20 files changed, 127 insertions(+), 131 deletions(-) diff --git a/generic/regc_locale.c b/generic/regc_locale.c index cf751ba..56a7ae7 100644 --- a/generic/regc_locale.c +++ b/generic/regc_locale.c @@ -999,12 +999,12 @@ cclass( const chr *endp, /* just past the end of the name */ int cases) /* case-independent? */ { - size_t len; + size_t i, len; struct cvec *cv = NULL; Tcl_DString ds; const char *np; const char *const *namePtr; - int i, index; + int index; /* * The following arrays define the valid character class names. @@ -1062,14 +1062,14 @@ cclass( case CC_ALNUM: cv = getcvec(v, NUM_ALPHA_CHAR, NUM_DIGIT_RANGE + NUM_ALPHA_RANGE); if (cv) { - for (i=0 ; (size_t)i 6) { Tcl_WrongNumArgs(interp, 1, objv, @@ -1563,13 +1561,11 @@ StringIsCmd( if (objc != 3) { for (i = 2; i < objc-1; i++) { - int idx2; - if (Tcl_GetIndexFromObj(interp, objv[i], isOptions, "option", 0, &idx2) != TCL_OK) { return TCL_ERROR; } - switch ((enum isOptionsEnum) idx2) { + switch (idx2) { case OPT_STRICT: strict = 1; break; @@ -1598,7 +1594,7 @@ StringIsCmd( * When entering here, result == 1 and failat == 0. */ - switch ((enum isClassesEnum) index) { + switch (index) { case STR_IS_ALNUM: chcomp = Tcl_UniCharIsAlnum; break; @@ -3459,7 +3455,7 @@ TclNRSwitchObjCmd( int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - int i,j, index, mode, foundmode, splitObjs, numMatchesSaved; + int i,j, mode, foundmode, splitObjs, numMatchesSaved; int noCase, patternLength; const char *pattern; Tcl_Obj *stringObj, *indexVarObj, *matchVarObj; @@ -3484,7 +3480,7 @@ TclNRSwitchObjCmd( enum switchOptionsEnum { OPT_EXACT, OPT_GLOB, OPT_INDEXV, OPT_MATCHV, OPT_NOCASE, OPT_REGEXP, OPT_LAST - }; + } index; typedef int (*strCmpFn_t)(const char *, const char *); strCmpFn_t strCmpFn = TclUtfCmp; @@ -3502,7 +3498,7 @@ TclNRSwitchObjCmd( &index) != TCL_OK) { return TCL_ERROR; } - switch ((enum switchOptionsEnum) index) { + switch (index) { /* * General options. */ diff --git a/generic/tclCompCmdsSZ.c b/generic/tclCompCmdsSZ.c index aa2d13e..4c01771 100644 --- a/generic/tclCompCmdsSZ.c +++ b/generic/tclCompCmdsSZ.c @@ -518,8 +518,8 @@ TclCompileStringIsCmd( STR_IS_LIST, STR_IS_LOWER, STR_IS_PRINT, STR_IS_PUNCT, STR_IS_SPACE, STR_IS_TRUE, STR_IS_UPPER, STR_IS_UNICODE, STR_IS_WIDE, STR_IS_WORD, STR_IS_XDIGIT - }; - int t, range, allowEmpty = 0, end; + } t; + int range, allowEmpty = 0, end; InstStringClassType strClassType; Tcl_Obj *isClass; @@ -575,7 +575,7 @@ TclCompileStringIsCmd( CompileWord(envPtr, tokenPtr, interp, parsePtr->numWords-1); - switch ((enum isClassesEnum) t) { + switch (t) { case STR_IS_ALNUM: strClassType = STR_CLASS_ALNUM; goto compileStrClass; @@ -683,6 +683,8 @@ TclCompileStringIsCmd( FIXJUMP1( over); OP( LNOT); return TCL_OK; + default: + break; } break; @@ -748,6 +750,8 @@ TclCompileStringIsCmd( PUSH( "3"); OP( LE); break; + default: + break; } FIXJUMP1( end); return TCL_OK; diff --git a/generic/tclConfig.c b/generic/tclConfig.c index a145bac..cfa7596 100644 --- a/generic/tclConfig.c +++ b/generic/tclConfig.c @@ -199,13 +199,13 @@ QueryConfigObjCmd( QCCD *cdPtr = (QCCD *)clientData; Tcl_Obj *pkgName = cdPtr->pkg; Tcl_Obj *pDB, *pkgDict, *val, *listPtr; - int n, index; + int n; static const char *const subcmdStrings[] = { "get", "list", NULL }; enum subcmds { CFG_GET, CFG_LIST - }; + } index; Tcl_DString conv; Tcl_Encoding venc = NULL; const char *value; @@ -233,7 +233,7 @@ QueryConfigObjCmd( return TCL_ERROR; } - switch ((enum subcmds) index) { + switch (index) { case CFG_GET: if (objc != 3) { Tcl_WrongNumArgs(interp, 2, objv, "key"); diff --git a/generic/tclDictObj.c b/generic/tclDictObj.c index b93b141..7feb8b9 100644 --- a/generic/tclDictObj.c +++ b/generic/tclDictObj.c @@ -2996,11 +2996,11 @@ DictFilterCmd( }; enum FilterTypes { FILTER_KEYS, FILTER_SCRIPT, FILTER_VALUES - }; + } index; Tcl_Obj *scriptObj, *keyVarObj, *valueVarObj; Tcl_Obj **varv, *keyObj = NULL, *valueObj = NULL, *resultObj, *boolObj; Tcl_DictSearch search; - int index, varc, done, result, satisfied; + int varc, done, result, satisfied; const char *pattern; if (objc < 3) { @@ -3012,7 +3012,7 @@ DictFilterCmd( return TCL_ERROR; } - switch ((enum FilterTypes) index) { + switch (index) { case FILTER_KEYS: /* * Create a dictionary whose keys all match a certain pattern. diff --git a/generic/tclDisassemble.c b/generic/tclDisassemble.c index 6f45be1..3b6b7b7 100644 --- a/generic/tclDisassemble.c +++ b/generic/tclDisassemble.c @@ -1280,8 +1280,8 @@ Tcl_DisassembleObjCmd( DISAS_CLASS_CONSTRUCTOR, DISAS_CLASS_DESTRUCTOR, DISAS_LAMBDA, DISAS_CLASS_METHOD, DISAS_OBJECT_METHOD, DISAS_PROC, DISAS_SCRIPT - }; - int idx, result; + } idx; + int result; Tcl_Obj *codeObjPtr = NULL; Proc *procPtr = NULL; Tcl_HashEntry *hPtr; @@ -1297,7 +1297,7 @@ Tcl_DisassembleObjCmd( return TCL_ERROR; } - switch ((enum Types) idx) { + switch (idx) { case DISAS_LAMBDA: { Command cmd; Tcl_Obj *nsObjPtr; diff --git a/generic/tclEnsemble.c b/generic/tclEnsemble.c index 9ee4982..435fd58 100644 --- a/generic/tclEnsemble.c +++ b/generic/tclEnsemble.c @@ -163,7 +163,8 @@ TclNamespaceEnsembleCmd( Tcl_DictSearch search; Tcl_Obj *listObj; const char *simpleName; - int index, done; + enum EnsSubcmds index; + int done; if (nsPtr == NULL || nsPtr->flags & NS_DEAD) { if (!Tcl_InterpDeleted(interp)) { @@ -184,7 +185,7 @@ TclNamespaceEnsembleCmd( return TCL_ERROR; } - switch ((enum EnsSubcmds) index) { + switch (index) { case ENS_CREATE: { const char *name; int len, allocatedMapFlag = 0; diff --git a/generic/tclEvent.c b/generic/tclEvent.c index 71ca814..e3eca2c 100644 --- a/generic/tclEvent.c +++ b/generic/tclEvent.c @@ -1583,10 +1583,9 @@ Tcl_UpdateObjCmd( int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - int optionIndex; int flags = 0; /* Initialized to avoid compiler warning. */ static const char *const updateOptions[] = {"idletasks", NULL}; - enum updateOptionsEnum {OPT_IDLETASKS}; + enum updateOptionsEnum {OPT_IDLETASKS} optionIndex; if (objc == 1) { flags = TCL_ALL_EVENTS|TCL_DONT_WAIT; @@ -1595,7 +1594,7 @@ Tcl_UpdateObjCmd( "option", 0, &optionIndex) != TCL_OK) { return TCL_ERROR; } - switch ((enum updateOptionsEnum) optionIndex) { + switch (optionIndex) { case OPT_IDLETASKS: flags = TCL_IDLE_EVENTS|TCL_DONT_WAIT; break; diff --git a/generic/tclFileName.c b/generic/tclFileName.c index 1603951..5b61153 100644 --- a/generic/tclFileName.c +++ b/generic/tclFileName.c @@ -1228,7 +1228,7 @@ Tcl_GlobObjCmd( int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - int index, i, globFlags, length, join, dir, result; + int i, globFlags, length, join, dir, result; char *string; const char *separators; Tcl_Obj *typePtr, *look; @@ -1241,7 +1241,7 @@ Tcl_GlobObjCmd( enum globOptionsEnum { GLOB_DIR, GLOB_JOIN, GLOB_NOCOMPLAIN, GLOB_PATH, GLOB_TAILS, GLOB_TYPE, GLOB_LAST - }; + } index; enum pathDirOptions {PATH_NONE = -1 , PATH_GENERAL = 0, PATH_DIR = 1}; Tcl_GlobTypeData *globTypes = NULL; @@ -1271,7 +1271,7 @@ Tcl_GlobObjCmd( } } - switch ((enum globOptionsEnum) index) { + switch (index) { case GLOB_NOCOMPLAIN: /* -nocomplain */ globFlags |= TCL_GLOBMODE_NO_COMPLAIN; break; diff --git a/generic/tclIOCmd.c b/generic/tclIOCmd.c index 2ab31e4..550ee17 100644 --- a/generic/tclIOCmd.c +++ b/generic/tclIOCmd.c @@ -1473,8 +1473,8 @@ Tcl_SocketObjCmd( enum socketOptionsEnum { SKT_ASYNC, SKT_MYADDR, SKT_MYPORT, SKT_REUSEADDR, SKT_REUSEPORT, SKT_SERVER - }; - int optionIndex, a, server = 0, myport = 0, async = 0, reusep = -1, + } optionIndex; + int a, server = 0, myport = 0, async = 0, reusep = -1, reusea = -1; unsigned int flags = 0; const char *host, *port, *myaddr = NULL; @@ -1495,7 +1495,7 @@ Tcl_SocketObjCmd( TCL_EXACT, &optionIndex) != TCL_OK) { return TCL_ERROR; } - switch ((enum socketOptionsEnum) optionIndex) { + switch (optionIndex) { case SKT_ASYNC: if (server == 1) { Tcl_SetObjResult(interp, Tcl_NewStringObj( @@ -1804,9 +1804,9 @@ ChanPendingObjCmd( Tcl_Obj *const objv[]) /* Argument objects. */ { Tcl_Channel chan; - int index, mode; + int mode; static const char *const options[] = {"input", "output", NULL}; - enum pendingOptionsEnum {PENDING_INPUT, PENDING_OUTPUT}; + enum pendingOptionsEnum {PENDING_INPUT, PENDING_OUTPUT} index; if (objc != 3) { Tcl_WrongNumArgs(interp, 1, objv, "mode channelId"); @@ -1822,7 +1822,7 @@ ChanPendingObjCmd( return TCL_ERROR; } - switch ((enum pendingOptionsEnum) index) { + switch (index) { case PENDING_INPUT: if (!(mode & TCL_READABLE)) { Tcl_SetObjResult(interp, Tcl_NewWideIntObj(-1)); diff --git a/generic/tclLoad.c b/generic/tclLoad.c index 7ea1ebd..b678d20 100644 --- a/generic/tclLoad.c +++ b/generic/tclLoad.c @@ -145,14 +145,14 @@ Tcl_LoadObjCmd( Tcl_LoadHandle loadHandle; Tcl_UniChar ch = 0; unsigned len; - int index, flags = 0; + int flags = 0; Tcl_Obj *const *savedobjv = objv; static const char *const options[] = { "-global", "-lazy", "--", NULL }; enum loadOptionsEnum { LOAD_GLOBAL, LOAD_LAZY, LOAD_LAST - }; + } index; while (objc > 2) { if (TclGetString(objv[1])[0] != '-') { @@ -163,9 +163,9 @@ Tcl_LoadObjCmd( return TCL_ERROR; } ++objv; --objc; - if (LOAD_GLOBAL == (enum loadOptionsEnum) index) { + if (LOAD_GLOBAL == index) { flags |= TCL_LOAD_GLOBAL; - } else if (LOAD_LAZY == (enum loadOptionsEnum) index) { + } else if (LOAD_LAZY == index) { flags |= TCL_LOAD_LAZY; } else { break; @@ -567,7 +567,7 @@ Tcl_UnloadObjCmd( LoadedLibrary *libraryPtr; Tcl_DString pfx, tmp; InterpLibrary *ipFirstPtr, *ipPtr; - int i, index, code, complain = 1, keepLibrary = 0; + int i, code, complain = 1, keepLibrary = 0; const char *fullFileName = ""; const char *prefix; static const char *const options[] = { @@ -575,7 +575,7 @@ Tcl_UnloadObjCmd( }; enum unloadOptionsEnum { UNLOAD_NOCOMPLAIN, UNLOAD_KEEPLIB, UNLOAD_LAST - }; + } index; for (i = 1; i < objc; i++) { if (Tcl_GetIndexFromObj(interp, objv[i], options, "option", 0, @@ -598,7 +598,7 @@ Tcl_UnloadObjCmd( break; } } - switch ((enum unloadOptionsEnum)index) { + switch (index) { case UNLOAD_NOCOMPLAIN: /* -nocomplain */ complain = 0; break; diff --git a/generic/tclOOBasic.c b/generic/tclOOBasic.c index 6ea4681..ad79fde 100644 --- a/generic/tclOOBasic.c +++ b/generic/tclOOBasic.c @@ -1045,12 +1045,11 @@ TclOOSelfObjCmd( enum SelfCmds { SELF_CALL, SELF_CALLER, SELF_CLASS, SELF_FILTER, SELF_METHOD, SELF_NS, SELF_NEXT, SELF_OBJECT, SELF_TARGET - }; + } index; Interp *iPtr = (Interp *) interp; CallFrame *framePtr = iPtr->varFramePtr; CallContext *contextPtr; Tcl_Obj *result[3]; - int index; #define CurrentlyInvoked(contextPtr) \ ((contextPtr)->callPtr->chain[(contextPtr)->index]) @@ -1084,7 +1083,7 @@ TclOOSelfObjCmd( return TCL_ERROR; } - switch ((enum SelfCmds) index) { + switch (index) { case SELF_OBJECT: Tcl_SetObjResult(interp, TclOOObjectName(interp, contextPtr->oPtr)); return TCL_OK; diff --git a/generic/tclOOInfo.c b/generic/tclOOInfo.c index 4e5b55b..95682cb 100644 --- a/generic/tclOOInfo.c +++ b/generic/tclOOInfo.c @@ -408,9 +408,9 @@ InfoObjectIsACmd( }; enum IsACats { IsClass, IsMetaclass, IsMixin, IsObject, IsType - }; + } idx; Object *oPtr, *o2Ptr; - int idx, i, result = 0; + int i, result = 0; if (objc < 3) { Tcl_WrongNumArgs(interp, 1, objv, "category objName ?arg ...?"); @@ -426,7 +426,7 @@ InfoObjectIsACmd( * number of arguments. */ - switch ((enum IsACats) idx) { + switch (idx) { case IsObject: case IsClass: case IsMetaclass: @@ -454,7 +454,7 @@ InfoObjectIsACmd( goto failPrecondition; } - switch ((enum IsACats) idx) { + switch (idx) { case IsObject: result = 1; break; @@ -532,7 +532,7 @@ InfoObjectMethodsCmd( }; enum Options { OPT_ALL, OPT_LOCALPRIVATE, OPT_PRIVATE, OPT_SCOPE - }; + } idx; static const char *const scopes[] = { "private", "public", "unexported" }; @@ -550,14 +550,14 @@ InfoObjectMethodsCmd( return TCL_ERROR; } if (objc != 2) { - int i, idx; + int i; for (i=2 ; i 1) { if (TclGetString(objv[1])[0] != '-') { @@ -485,7 +485,7 @@ ProcessStatusObjCmd( return TCL_ERROR; } ++objv; --objc; - if (STATUS_WAIT == (enum switchesEnum) index) { + if (STATUS_WAIT == index) { options = 0; } else { break; diff --git a/generic/tclTest.c b/generic/tclTest.c index 009c95f..d1c211d 100644 --- a/generic/tclTest.c +++ b/generic/tclTest.c @@ -1834,7 +1834,7 @@ TestencodingObjCmd( Tcl_Obj *const objv[]) /* Argument objects. */ { Tcl_Encoding encoding; - int index, length; + int length; const char *string; TclEncoding *encodingPtr; static const char *const optionStrings[] = { @@ -1842,14 +1842,14 @@ TestencodingObjCmd( }; enum options { ENC_CREATE, ENC_DELETE - }; + } index; if (Tcl_GetIndexFromObj(interp, objv[1], optionStrings, "option", 0, &index) != TCL_OK) { return TCL_ERROR; } - switch ((enum options) index) { + switch (index) { case ENC_CREATE: { Tcl_EncodingType type; @@ -3201,7 +3201,7 @@ TestlinkarrayCmd( static const char *LinkOption[] = { "update", "remove", "create", NULL }; - enum LinkOptionEnum { LINK_UPDATE, LINK_REMOVE, LINK_CREATE }; + enum LinkOptionEnum {LINK_UPDATE, LINK_REMOVE, LINK_CREATE} optionIndex; static const char *LinkType[] = { "char", "uchar", "short", "ushort", "int", "uint", "long", "ulong", "wide", "uwide", "float", "double", "string", "char*", "binary", NULL @@ -3214,7 +3214,7 @@ TestlinkarrayCmd( TCL_LINK_FLOAT, TCL_LINK_DOUBLE, TCL_LINK_STRING, TCL_LINK_CHARS, TCL_LINK_BINARY }; - int optionIndex, typeIndex, readonly, i, size, length; + int typeIndex, readonly, i, size, length; char *name, *arg; Tcl_WideInt addr; @@ -3226,7 +3226,7 @@ TestlinkarrayCmd( &optionIndex) != TCL_OK) { return TCL_ERROR; } - switch ((enum LinkOptionEnum) optionIndex) { + switch (optionIndex) { case LINK_UPDATE: for (i=2; ifreeProc == TestsaveresultFree) ^ freeCount; diff --git a/generic/tclThreadTest.c b/generic/tclThreadTest.c index 9f08d83..0e33075 100644 --- a/generic/tclThreadTest.c +++ b/generic/tclThreadTest.c @@ -211,7 +211,6 @@ ThreadObjCmd( Tcl_Obj *const objv[]) /* Argument objects. */ { ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); - int option; static const char *const threadOptions[] = { "cancel", "create", "event", "exit", "id", "join", "names", "send", "wait", "errorproc", @@ -221,7 +220,7 @@ ThreadObjCmd( THREAD_CANCEL, THREAD_CREATE, THREAD_EVENT, THREAD_EXIT, THREAD_ID, THREAD_JOIN, THREAD_NAMES, THREAD_SEND, THREAD_WAIT, THREAD_ERRORPROC - }; + } option; if (objc < 2) { Tcl_WrongNumArgs(interp, 1, objv, "option ?arg ...?"); @@ -244,7 +243,7 @@ ThreadObjCmd( Tcl_MutexUnlock(&threadMutex); } - switch ((enum options)option) { + switch (option) { case THREAD_CANCEL: { Tcl_WideInt id; const char *result; diff --git a/generic/tclTrace.c b/generic/tclTrace.c index 535e2c2..2465aec 100644 --- a/generic/tclTrace.c +++ b/generic/tclTrace.c @@ -188,7 +188,6 @@ Tcl_TraceObjCmd( int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - int optionIndex; #ifndef TCL_REMOVE_OBSOLETE_TRACES const char *name; const char *flagOps, *p; @@ -207,7 +206,7 @@ Tcl_TraceObjCmd( #ifndef TCL_REMOVE_OBSOLETE_TRACES TRACE_OLD_VARIABLE, TRACE_OLD_VDELETE, TRACE_OLD_VINFO #endif - }; + } optionIndex; if (objc < 2) { Tcl_WrongNumArgs(interp, 1, objv, "option ?arg ...?"); @@ -218,7 +217,7 @@ Tcl_TraceObjCmd( &optionIndex) != TCL_OK) { return TCL_ERROR; } - switch ((enum traceOptionsEnum) optionIndex) { + switch (optionIndex) { case TRACE_ADD: case TRACE_REMOVE: { /* diff --git a/generic/tclVar.c b/generic/tclVar.c index 5a59fde..8abb1e8 100644 --- a/generic/tclVar.c +++ b/generic/tclVar.c @@ -3917,12 +3917,12 @@ ArrayNamesCmd( static const char *const options[] = { "-exact", "-glob", "-regexp", NULL }; - enum arrayNamesOptionsEnum { OPT_EXACT, OPT_GLOB, OPT_REGEXP }; + enum arrayNamesOptionsEnum {OPT_EXACT, OPT_GLOB, OPT_REGEXP} mode = OPT_GLOB; Var *varPtr, *varPtr2; Tcl_Obj *nameObj, *resultObj, *patternObj; Tcl_HashSearch search; const char *pattern = NULL; - int isArray, mode = OPT_GLOB; + int isArray; if ((objc < 2) || (objc > 4)) { Tcl_WrongNumArgs(interp, 1, objv, "arrayName ?mode? ?pattern?"); @@ -3985,7 +3985,7 @@ ArrayNamesCmd( const char *name = TclGetString(nameObj); int matched = 0; - switch ((enum arrayNamesOptionsEnum) mode) { + switch (mode) { case OPT_EXACT: Tcl_Panic("exact matching shouldn't get here"); case OPT_GLOB: @@ -6635,10 +6635,10 @@ ArrayDefaultCmd( static const char *const options[] = { "get", "set", "exists", "unset", NULL }; - enum arrayDefaultOptionsEnum { OPT_GET, OPT_SET, OPT_EXISTS, OPT_UNSET }; + enum arrayDefaultOptionsEnum { OPT_GET, OPT_SET, OPT_EXISTS, OPT_UNSET } option; Tcl_Obj *arrayNameObj, *defaultValueObj; Var *varPtr, *arrayPtr; - int isArray, option; + int isArray; /* * Parse arguments. @@ -6659,7 +6659,7 @@ ArrayDefaultCmd( return TCL_ERROR; } - switch ((enum arrayDefaultOptionsEnum)option) { + switch (option) { case OPT_GET: if (objc != 3) { Tcl_WrongNumArgs(interp, 2, objv, "arrayName"); diff --git a/generic/tclZlib.c b/generic/tclZlib.c index 6a9a38a..8ab0661 100644 --- a/generic/tclZlib.c +++ b/generic/tclZlib.c @@ -2390,7 +2390,7 @@ ZlibPushSubcmd( FMT_INFLATE }; Tcl_Channel chan; - int chanMode, format, mode = 0, level, i, option; + int chanMode, format, mode = 0, level, i; static const char *const pushCompressOptions[] = { "-dictionary", "-header", "-level", NULL }; @@ -2398,7 +2398,7 @@ ZlibPushSubcmd( "-dictionary", "-header", "-level", "-limit", NULL }; const char *const *pushOptions = pushDecompressOptions; - enum pushOptionsEnum {poDictionary, poHeader, poLevel, poLimit}; + enum pushOptionsEnum {poDictionary, poHeader, poLevel, poLimit} option; Tcl_Obj *headerObj = NULL, *compDictObj = NULL; int limit = DEFAULT_BUFFER_SIZE, dummy; @@ -2480,7 +2480,7 @@ ZlibPushSubcmd( Tcl_SetErrorCode(interp, "TCL", "ZIP", "NOVAL", NULL); return TCL_ERROR; } - switch ((enum pushOptionsEnum) option) { + switch (option) { case poHeader: headerObj = objv[i]; if (Tcl_DictObjSize(interp, headerObj, &dummy) != TCL_OK) { @@ -2560,7 +2560,7 @@ ZlibStreamCmd( Tcl_Obj *const objv[]) { Tcl_ZlibStream zstream = (Tcl_ZlibStream)cd; - int command, count, code; + int count, code; Tcl_Obj *obj; static const char *const cmds[] = { "add", "checksum", "close", "eof", "finalize", "flush", @@ -2570,7 +2570,7 @@ ZlibStreamCmd( enum zlibStreamCommands { zs_add, zs_checksum, zs_close, zs_eof, zs_finalize, zs_flush, zs_fullflush, zs_get, zs_header, zs_put, zs_reset - }; + } command; if (objc < 2) { Tcl_WrongNumArgs(interp, 1, objv, "option data ?...?"); @@ -2582,7 +2582,7 @@ ZlibStreamCmd( return TCL_ERROR; } - switch ((enum zlibStreamCommands) command) { + switch (command) { case zs_add: /* $strm add ?$flushopt? $data */ return ZlibStreamAddCmd(zstream, interp, objc, objv); case zs_header: /* $strm header */ @@ -2686,14 +2686,14 @@ ZlibStreamAddCmd( Tcl_Obj *const objv[]) { Tcl_ZlibStream zstream = (Tcl_ZlibStream)cd; - int index, code, buffersize = -1, flush = -1, i; + int code, buffersize = -1, flush = -1, i; Tcl_Obj *obj, *compDictObj = NULL; static const char *const add_options[] = { "-buffer", "-dictionary", "-finalize", "-flush", "-fullflush", NULL }; enum addOptions { ao_buffer, ao_dictionary, ao_finalize, ao_flush, ao_fullflush - }; + } index; for (i=2; i= 0) { flush = -2; @@ -2813,14 +2813,14 @@ ZlibStreamPutCmd( Tcl_Obj *const objv[]) { Tcl_ZlibStream zstream = (Tcl_ZlibStream)cd; - int index, flush = -1, i; + int flush = -1, i; Tcl_Obj *compDictObj = NULL; static const char *const put_options[] = { "-dictionary", "-finalize", "-flush", "-fullflush", NULL }; enum putOptions { po_dictionary, po_finalize, po_flush, po_fullflush - }; + } index; for (i=2; i= 0) { flush = -2; -- cgit v0.12 From 67bfd66650822acaa58c1afef5576e8b4760592a Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 3 Mar 2022 15:58:46 +0000 Subject: =?UTF-8?q?Fix=20warning=20when=20compiling=20with=20-DTCL=5FUTF?= =?UTF-8?q?=5FMAX=3D3:=20tclDecls.h:3921:27:=20warning:=20initialization?= =?UTF-8?q?=20of=20=E2=80=98size=5Ft=20(*)(const=20int=20*)=E2=80=99=20{ak?= =?UTF-8?q?a=20=E2=80=98long=20unsigned=20int=20(*)(const=20int=20*)?= =?UTF-8?q?=E2=80=99}=20from=20incompatible=20pointer=20type=20=E2=80=98si?= =?UTF-8?q?ze=5Ft=20(*)(const=20short=20unsigned=20int=20*)=E2=80=99=20{ak?= =?UTF-8?q?a=20=E2=80=98long=20unsigned=20int=20(*)(const=20short=20unsign?= =?UTF-8?q?ed=20int=20*)=E2=80=99}=20[-Wincompatible-pointer-types]=20=203?= =?UTF-8?q?921=20|=20#=20=20=20define=20Tcl=5FUniCharLen=20Tcl=5FChar16Len?= =?UTF-8?q?=20=20=20=20=20=20=20|=20=20=20=20=20=20=20=20=20=20=20=20=20?= =?UTF-8?q?=20=20=20=20=20=20=20=20=20=20=20=20=20=20^~~~~~~~~~~~~?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- generic/tclStubInit.c | 1 + 1 file changed, 1 insertion(+) diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c index 044da51..3121f55 100644 --- a/generic/tclStubInit.c +++ b/generic/tclStubInit.c @@ -66,6 +66,7 @@ #undef Tcl_UniCharToUtfDString #undef Tcl_UtfToUniCharDString #undef Tcl_UtfToUniChar +#undef Tcl_UniCharLen #if !defined(_WIN32) && !defined(__CYGWIN__) #undef Tcl_WinConvertError #define Tcl_WinConvertError 0 -- cgit v0.12 From a4f421b6eb3edb7aa7247e169d6628bae0641b34 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 4 Mar 2022 16:15:04 +0000 Subject: Fix [8d8bb39962]: incorrect notifier initialization in tclXtNotify.c --- unix/tclXtNotify.c | 6 +----- 1 file changed, 1 insertion(+), 5 deletions(-) diff --git a/unix/tclXtNotify.c b/unix/tclXtNotify.c index a5d92d6..dcd9abe 100644 --- a/unix/tclXtNotify.c +++ b/unix/tclXtNotify.c @@ -193,14 +193,11 @@ InitNotifier(void) return; } + memset(&np, 0, sizeof(np)); np.createFileHandlerProc = CreateFileHandler; np.deleteFileHandlerProc = DeleteFileHandler; np.setTimerProc = SetTimer; np.waitForEventProc = WaitForEvent; - np.initNotifierProc = Tcl_InitNotifier; - np.finalizeNotifierProc = Tcl_FinalizeNotifier; - np.alertNotifierProc = Tcl_AlertNotifier; - np.serviceModeHookProc = Tcl_ServiceModeHook; Tcl_SetNotifier(&np); /* @@ -209,7 +206,6 @@ InitNotifier(void) */ initialized = 1; - memset(&np, 0, sizeof(np)); Tcl_CreateExitHandler(NotifierExitHandler, NULL); } -- cgit v0.12 From 75e8b346e2193f1c524cbbb741583e6ab4dfc417 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Sat, 5 Mar 2022 10:32:38 +0000 Subject: Add "const" to Tcl_SetNotifier() argument. Should have been part of TIP #27, looooooong ago. This simplifier tclXtNotify.c a lot. --- doc/Notifier.3 | 2 +- generic/tcl.decls | 2 +- generic/tclDecls.h | 5 +++-- generic/tclNotify.c | 2 +- unix/tclXtNotify.c | 13 +++++++------ 5 files changed, 13 insertions(+), 11 deletions(-) diff --git a/doc/Notifier.3 b/doc/Notifier.3 index ec9f910..efbe216 100644 --- a/doc/Notifier.3 +++ b/doc/Notifier.3 @@ -103,7 +103,7 @@ passed to \fBTcl_DoOneEvent\fR. .AP int mode in Indicates whether events should be serviced by \fBTcl_ServiceAll\fR. Must be one of \fBTCL_SERVICE_NONE\fR or \fBTCL_SERVICE_ALL\fR. -.AP Tcl_NotifierProcs* notifierProcPtr in +.AP const Tcl_NotifierProcs* notifierProcPtr in Structure of function pointers describing notifier procedures that are to replace the ones installed in the executable. See \fBREPLACING THE NOTIFIER\fR for details. diff --git a/generic/tcl.decls b/generic/tcl.decls index a6a9d5c..8e21b1d 100644 --- a/generic/tcl.decls +++ b/generic/tcl.decls @@ -1365,7 +1365,7 @@ declare 385 { Tcl_Obj *patternObj) } declare 386 { - void Tcl_SetNotifier(Tcl_NotifierProcs *notifierProcPtr) + void Tcl_SetNotifier(const Tcl_NotifierProcs *notifierProcPtr) } declare 387 { Tcl_Mutex *Tcl_GetAllocMutex(void) diff --git a/generic/tclDecls.h b/generic/tclDecls.h index fd5f81b..87a90af 100644 --- a/generic/tclDecls.h +++ b/generic/tclDecls.h @@ -1164,7 +1164,8 @@ void Tcl_AppendUnicodeToObj(Tcl_Obj *objPtr, EXTERN int Tcl_RegExpMatchObj(Tcl_Interp *interp, Tcl_Obj *textObj, Tcl_Obj *patternObj); /* 386 */ -EXTERN void Tcl_SetNotifier(Tcl_NotifierProcs *notifierProcPtr); +EXTERN void Tcl_SetNotifier( + const Tcl_NotifierProcs *notifierProcPtr); /* 387 */ EXTERN Tcl_Mutex * Tcl_GetAllocMutex(void); /* 388 */ @@ -2377,7 +2378,7 @@ typedef struct TclStubs { Tcl_Obj * (*tcl_GetRange) (Tcl_Obj *objPtr, int first, int last); /* 383 */ TCL_DEPRECATED_API("Use Tcl_AppendStringsToObj") 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 */ - void (*tcl_SetNotifier) (Tcl_NotifierProcs *notifierProcPtr); /* 386 */ + void (*tcl_SetNotifier) (const Tcl_NotifierProcs *notifierProcPtr); /* 386 */ Tcl_Mutex * (*tcl_GetAllocMutex) (void); /* 387 */ int (*tcl_GetChannelNames) (Tcl_Interp *interp); /* 388 */ int (*tcl_GetChannelNamesEx) (Tcl_Interp *interp, const char *pattern); /* 389 */ diff --git a/generic/tclNotify.c b/generic/tclNotify.c index 12b40b1..1140168 100644 --- a/generic/tclNotify.c +++ b/generic/tclNotify.c @@ -226,7 +226,7 @@ TclFinalizeNotifier(void) void Tcl_SetNotifier( - Tcl_NotifierProcs *notifierProcPtr) + const Tcl_NotifierProcs *notifierProcPtr) { tclNotifierHooks = *notifierProcPtr; diff --git a/unix/tclXtNotify.c b/unix/tclXtNotify.c index 0210cd3..45bda3e 100644 --- a/unix/tclXtNotify.c +++ b/unix/tclXtNotify.c @@ -181,7 +181,13 @@ TclSetAppContext( void InitNotifier(void) { - Tcl_NotifierProcs np; + static const Tcl_NotifierProcs np = + SetTimer, + WaitForEvent, + CreateFileHandler, + DeleteFileHandler, + NULL, NULL, NULL, NULL + }; /* * Only reinitialize if we are not in exit handling. The notifier can get @@ -193,11 +199,6 @@ InitNotifier(void) return; } - memset(&np, 0, sizeof(np)); - np.createFileHandlerProc = CreateFileHandler; - np.deleteFileHandlerProc = DeleteFileHandler; - np.setTimerProc = SetTimer; - np.waitForEventProc = WaitForEvent; Tcl_SetNotifier(&np); /* -- cgit v0.12 From 6ec7e10a1634a0a9c10ed2cf90072ba723d701ce Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Sat, 5 Mar 2022 21:56:47 +0000 Subject: -nothrow -> -nocomplain --- doc/Encoding.3 | 2 +- generic/tcl.h | 4 ++-- generic/tclCmdAH.c | 22 ++++++++-------------- generic/tclEncoding.c | 6 +++--- tests/cmdAH.test | 4 ++-- tests/encoding.test | 52 +++++++++++++++++++++++++-------------------------- tests/safe.test | 8 ++++---- 7 files changed, 46 insertions(+), 52 deletions(-) diff --git a/doc/Encoding.3 b/doc/Encoding.3 index bffa0c3..dc37519 100644 --- a/doc/Encoding.3 +++ b/doc/Encoding.3 @@ -114,7 +114,7 @@ byte is converted and then to reset to an initial state. \fBTCL_ENCODING_STOPONERROR\fR signifies that the conversion routine should return immediately upon reading a source character that does not exist in the target encoding; otherwise a default fallback character will -automatically be substituted. The flag \fBTCL_ENCODING_NO_THROW\fR has +automatically be substituted. The flag \fBTCL_ENCODING_NOCOMPLAIN\fR has no effect, it is reserved for Tcl 9.0. The flag \fBTCL_ENCODING_MODIFIED\fR makes \fBTcl_UtfToExternalDStringEx\fR and \fBTcl_UtfToExternal\fR produce the byte sequence \exC0\ex80 in stead of \ex00, for the utf-8/cesu-8 encoders. diff --git a/generic/tcl.h b/generic/tcl.h index 783d576..ef0fa75 100644 --- a/generic/tcl.h +++ b/generic/tcl.h @@ -2081,7 +2081,7 @@ typedef struct Tcl_EncodingType { * 0x00. Only valid for "utf-8" and "cesu-8". * This flag is implicit for external -> internal conversions, * optional for internal -> external conversions. - * TCL_ENCODING_NO_THROW - If set, the converter + * TCL_ENCODING_NOCOMPLAIN - If set, the converter * substitutes the problematic character(s) with * one or more "close" characters in the * destination buffer and then continues to @@ -2097,7 +2097,7 @@ typedef struct Tcl_EncodingType { #define TCL_ENCODING_NO_TERMINATE 0x08 #define TCL_ENCODING_CHAR_LIMIT 0x10 #define TCL_ENCODING_MODIFIED 0x20 -#define TCL_ENCODING_NO_THROW 0x40 +#define TCL_ENCODING_NOCOMPLAIN 0x40 /* * The following definitions are the error codes returned by the conversion diff --git a/generic/tclCmdAH.c b/generic/tclCmdAH.c index 5b655ef..60a2c42 100644 --- a/generic/tclCmdAH.c +++ b/generic/tclCmdAH.c @@ -553,7 +553,7 @@ EncodingConvertfromObjCmd( #if TCL_MAJOR_VERSION > 8 || defined(TCL_NO_DEPRECATED) int flags = TCL_ENCODING_STOPONERROR; #else - int flags = TCL_ENCODING_NO_THROW; + int flags = TCL_ENCODING_NOCOMPLAIN; #endif size_t result; @@ -564,11 +564,8 @@ EncodingConvertfromObjCmd( data = objv[objc - 1]; bytesPtr = Tcl_GetString(objv[1]); if (bytesPtr[0] == '-' && bytesPtr[1] == 'n' - && !strncmp(bytesPtr, "-nothrow", strlen(bytesPtr))) { - flags = TCL_ENCODING_NO_THROW; - } else if (bytesPtr[0] == '-' && bytesPtr[1] == 's' - && !strncmp(bytesPtr, "-stoponerror", strlen(bytesPtr))) { - flags = TCL_ENCODING_STOPONERROR; + && !strncmp(bytesPtr, "-nocomplain", strlen(bytesPtr))) { + flags = TCL_ENCODING_NOCOMPLAIN; } else if (objc < 4) { if (Tcl_GetEncodingFromObj(interp, objv[objc - 2], &encoding) != TCL_OK) { return TCL_ERROR; @@ -584,7 +581,7 @@ EncodingConvertfromObjCmd( } } else { encConvFromError: - Tcl_WrongNumArgs(interp, 1, objv, "?-nothrow? ?encoding? data"); + Tcl_WrongNumArgs(interp, 1, objv, "?-nocomplain? ?encoding? data"); return TCL_ERROR; } @@ -660,7 +657,7 @@ EncodingConverttoObjCmd( #if TCL_MAJOR_VERSION > 8 || defined(TCL_NO_DEPRECATED) int flags = TCL_ENCODING_STOPONERROR; #else - int flags = TCL_ENCODING_NO_THROW; + int flags = TCL_ENCODING_NOCOMPLAIN; #endif if (objc == 2) { @@ -670,11 +667,8 @@ EncodingConverttoObjCmd( data = objv[objc - 1]; stringPtr = Tcl_GetString(objv[1]); if (stringPtr[0] == '-' && stringPtr[1] == 'n' - && !strncmp(stringPtr, "-nothrow", strlen(stringPtr))) { - flags = TCL_ENCODING_NO_THROW; - } else if (stringPtr[0] == '-' && stringPtr[1] == 's' - && !strncmp(stringPtr, "-stoponerror", strlen(stringPtr))) { - flags = TCL_ENCODING_STOPONERROR; + && !strncmp(stringPtr, "-nocomplain", strlen(stringPtr))) { + flags = TCL_ENCODING_NOCOMPLAIN; } else if (objc < 4) { if (Tcl_GetEncodingFromObj(interp, objv[objc - 2], &encoding) != TCL_OK) { return TCL_ERROR; @@ -690,7 +684,7 @@ EncodingConverttoObjCmd( } } else { encConvToError: - Tcl_WrongNumArgs(interp, 1, objv, "?-nothrow? ?encoding? data"); + Tcl_WrongNumArgs(interp, 1, objv, "?-nocomplain? ?encoding? data"); return TCL_ERROR; } diff --git a/generic/tclEncoding.c b/generic/tclEncoding.c index d1dbb09..b6d5dcf 100644 --- a/generic/tclEncoding.c +++ b/generic/tclEncoding.c @@ -1158,7 +1158,7 @@ Tcl_ExternalToUtfDString( * Possible flags values: * TCL_ENCODING_STOPONERROR: don't replace invalid characters/bytes but * return the first error position (Default in Tcl 9.0). - * TCL_ENCODING_NO_THROW: replace invalid characters/bytes by a default + * TCL_ENCODING_NOCOMPLAIN: replace invalid characters/bytes by a default * fallback character. Always return -1 (Default in Tcl 8.7). * TCL_ENCODING_MODIFIED: convert NULL bytes to \xC0\x80 in stead of 0x00. * Only valid for "utf-8" and "cesu-8". This flag may be used together @@ -1397,7 +1397,7 @@ Tcl_UtfToExternalDString( * Possible flags values: * TCL_ENCODING_STOPONERROR: don't replace invalid characters/bytes but * return the first error position (Default in Tcl 9.0). - * TCL_ENCODING_NO_THROW: replace invalid characters/bytes by a default + * TCL_ENCODING_NOCOMPLAIN: replace invalid characters/bytes by a default * fallback character. Always return -1 (Default in Tcl 8.7). * TCL_ENCODING_MODIFIED: convert NULL bytes to \xC0\x80 in stead of 0x00. * Only valid for "utf-8" and "cesu-8". This flag may be used together @@ -2288,7 +2288,7 @@ BinaryProc( */ #if TCL_MAJOR_VERSION > 8 || defined(TCL_NO_DEPRECATED) -# define STOPONERROR !(flags & TCL_ENCODING_NO_THROW) +# define STOPONERROR !(flags & TCL_ENCODING_NOCOMPLAIN) #else # define STOPONERROR (flags & TCL_ENCODING_STOPONERROR) #endif diff --git a/tests/cmdAH.test b/tests/cmdAH.test index 7f86275..d787c7f 100644 --- a/tests/cmdAH.test +++ b/tests/cmdAH.test @@ -178,7 +178,7 @@ test cmdAH-4.2 {Tcl_EncodingObjCmd} -returnCodes error -body { } -result {unknown or ambiguous subcommand "foo": must be convertfrom, convertto, dirs, names, or system} test cmdAH-4.3 {Tcl_EncodingObjCmd} -returnCodes error -body { encoding convertto -} -result {wrong # args: should be "encoding convertto ?-nothrow? ?encoding? data"} +} -result {wrong # args: should be "encoding convertto ?-nocomplain? ?encoding? data"} test cmdAH-4.4 {Tcl_EncodingObjCmd} -returnCodes error -body { encoding convertto foo bar } -result {unknown encoding "foo"} @@ -200,7 +200,7 @@ test cmdAH-4.6 {Tcl_EncodingObjCmd} -setup { } -result 8C test cmdAH-4.7 {Tcl_EncodingObjCmd} -returnCodes error -body { encoding convertfrom -} -result {wrong # args: should be "encoding convertfrom ?-nothrow? ?encoding? data"} +} -result {wrong # args: should be "encoding convertfrom ?-nocomplain? ?encoding? data"} test cmdAH-4.8 {Tcl_EncodingObjCmd} -returnCodes error -body { encoding convertfrom foo bar } -result {unknown encoding "foo"} diff --git a/tests/encoding.test b/tests/encoding.test index c6865d9..bf82493 100644 --- a/tests/encoding.test +++ b/tests/encoding.test @@ -299,7 +299,7 @@ test encoding-11.11 {encoding: extended Unicode UTF-32} { test encoding-12.1 {LoadTableEncoding: normal encoding} { set x [encoding convertto iso8859-3 Ġ] - append x [encoding convertto -nothrow iso8859-3 Õ] + append x [encoding convertto -nocomplain iso8859-3 Õ] append x [encoding convertfrom iso8859-3 Õ] } "Õ?Ġ" test encoding-12.2 {LoadTableEncoding: single-byte encoding} { @@ -348,67 +348,67 @@ test encoding-15.5 {UtfToUtfProc emoji character input} { } "4 😂" test encoding-15.6 {UtfToUtfProc emoji character output} { set x \uDE02\uD83D\uDE02\uD83D - set y [encoding convertto -nothrow utf-8 \uDE02\uD83D\uDE02\uD83D] + set y [encoding convertto -nocomplain utf-8 \uDE02\uD83D\uDE02\uD83D] binary scan $y H* z list [string length $y] $z } {10 edb882f09f9882eda0bd} test encoding-15.7 {UtfToUtfProc emoji character output} { set x \uDE02\uD83D\uD83D - set y [encoding convertto -nothrow utf-8 \uDE02\uD83D\uD83D] + set y [encoding convertto -nocomplain utf-8 \uDE02\uD83D\uD83D] binary scan $y H* z list [string length $x] [string length $y] $z } {3 9 edb882eda0bdeda0bd} test encoding-15.8 {UtfToUtfProc emoji character output} { set x \uDE02\uD83Dé - set y [encoding convertto -nothrow utf-8 \uDE02\uD83Dé] + set y [encoding convertto -nocomplain utf-8 \uDE02\uD83Dé] binary scan $y H* z list [string length $x] [string length $y] $z } {3 8 edb882eda0bdc3a9} test encoding-15.9 {UtfToUtfProc emoji character output} { set x \uDE02\uD83DX - set y [encoding convertto -nothrow utf-8 \uDE02\uD83DX] + set y [encoding convertto -nocomplain utf-8 \uDE02\uD83DX] binary scan $y H* z list [string length $x] [string length $y] $z } {3 7 edb882eda0bd58} test encoding-15.10 {UtfToUtfProc high surrogate character output} { set x \uDE02é - set y [encoding convertto -nothrow utf-8 \uDE02é] + set y [encoding convertto -nocomplain utf-8 \uDE02é] binary scan $y H* z list [string length $x] [string length $y] $z } {2 5 edb882c3a9} test encoding-15.11 {UtfToUtfProc low surrogate character output} { set x \uDA02é - set y [encoding convertto -nothrow utf-8 \uDA02é] + set y [encoding convertto -nocomplain utf-8 \uDA02é] binary scan $y H* z list [string length $x] [string length $y] $z } {2 5 eda882c3a9} test encoding-15.12 {UtfToUtfProc high surrogate character output} { set x \uDE02Y - set y [encoding convertto -nothrow utf-8 \uDE02Y] + set y [encoding convertto -nocomplain utf-8 \uDE02Y] binary scan $y H* z list [string length $x] [string length $y] $z } {2 4 edb88259} test encoding-15.13 {UtfToUtfProc low surrogate character output} { set x \uDA02Y - set y [encoding convertto -nothrow utf-8 \uDA02Y] + set y [encoding convertto -nocomplain utf-8 \uDA02Y] binary scan $y H* z list [string length $x] [string length $y] $z } {2 4 eda88259} test encoding-15.14 {UtfToUtfProc high surrogate character output} { set x \uDE02 - set y [encoding convertto -nothrow utf-8 \uDE02] + set y [encoding convertto -nocomplain utf-8 \uDE02] binary scan $y H* z list [string length $x] [string length $y] $z } {1 3 edb882} test encoding-15.15 {UtfToUtfProc low surrogate character output} { set x \uDA02 - set y [encoding convertto -nothrow utf-8 \uDA02] + set y [encoding convertto -nocomplain utf-8 \uDA02] binary scan $y H* z list [string length $x] [string length $y] $z } {1 3 eda882} test encoding-15.16 {UtfToUtfProc: Invalid 4-byte UTF-8, see [ed29806ba]} { set x \xF0\xA0\xA1\xC2 - set y [encoding convertfrom -nothrow utf-8 \xF0\xA0\xA1\xC2] + set y [encoding convertfrom -nocomplain utf-8 \xF0\xA0\xA1\xC2] list [string length $x] $y } "4 \xF0\xA0\xA1\xC2" test encoding-15.17 {UtfToUtfProc emoji character output} { @@ -489,10 +489,10 @@ test encoding-17.2 {UtfToUcs2Proc} -body { encoding convertfrom utf-16 [encoding convertto ucs-2 "\U460DC"] } -result "\uFFFD" test encoding-17.3 {UtfToUtf16Proc} -body { - encoding convertto -nothrow utf-16be "\uDCDC" + encoding convertto -nocomplain utf-16be "\uDCDC" } -result "\xFF\xFD" test encoding-17.4 {UtfToUtf16Proc} -body { - encoding convertto -nothrow utf-16le "\uD8D8" + encoding convertto -nocomplain utf-16le "\uD8D8" } -result "\xFD\xFF" test encoding-17.5 {UtfToUtf16Proc} -body { encoding convertto utf-32le "\U460DC" @@ -617,25 +617,25 @@ test encoding-24.4 {Parse valid or invalid utf-8} { string length [encoding convertfrom utf-8 "\xC0\x80"] } 1 test encoding-24.5 {Parse valid or invalid utf-8} { - string length [encoding convertfrom -nothrow utf-8 "\xC0\x81"] + string length [encoding convertfrom -nocomplain utf-8 "\xC0\x81"] } 2 test encoding-24.6 {Parse valid or invalid utf-8} { - string length [encoding convertfrom -nothrow utf-8 "\xC1\xBF"] + string length [encoding convertfrom -nocomplain utf-8 "\xC1\xBF"] } 2 test encoding-24.7 {Parse valid or invalid utf-8} { string length [encoding convertfrom utf-8 "\xC2\x80"] } 1 test encoding-24.8 {Parse valid or invalid utf-8} { - string length [encoding convertfrom -nothrow utf-8 "\xE0\x80\x80"] + string length [encoding convertfrom -nocomplain utf-8 "\xE0\x80\x80"] } 3 test encoding-24.9 {Parse valid or invalid utf-8} { - string length [encoding convertfrom -nothrow utf-8 "\xE0\x9F\xBF"] + string length [encoding convertfrom -nocomplain utf-8 "\xE0\x9F\xBF"] } 3 test encoding-24.10 {Parse valid or invalid utf-8} { string length [encoding convertfrom utf-8 "\xE0\xA0\x80"] } 1 test encoding-24.11 {Parse valid or invalid utf-8} { - string length [encoding convertfrom -nothrow utf-8 "\xEF\xBF\xBF"] + string length [encoding convertfrom -nocomplain utf-8 "\xEF\xBF\xBF"] } 1 test encoding-24.12 {Parse valid or invalid utf-8} -constraints deprecated -body { encoding convertfrom utf-8 "\xC0\x81" @@ -661,18 +661,18 @@ test encoding-24.18 {Parse valid or invalid utf-8} -constraints {testbytestring test encoding-24.19 {Parse valid or invalid utf-8} -constraints deprecated -body { encoding convertto utf-8 "ZX\uD800" } -returnCodes 1 -match glob -result "unexpected character at index 2: 'U+00D800'" -test encoding-24.20 {Parse with -nothrow but without providing encoding} { - string length [encoding convertfrom -nothrow "\x20"] +test encoding-24.20 {Parse with -nocomplain but without providing encoding} { + string length [encoding convertfrom -nocomplain "\x20"] } 1 -test encoding-24.21 {Parse with -nothrow but without providing encoding} { - string length [encoding convertto -nothrow "\x20"] +test encoding-24.21 {Parse with -nocomplain but without providing encoding} { + string length [encoding convertto -nocomplain "\x20"] } 1 test encoding-24.22 {Syntax error, two encodings} -body { encoding convertfrom iso8859-1 utf-8 "ZX\uD800" -} -returnCodes 1 -result {wrong # args: should be "::tcl::encoding::convertfrom ?-nothrow? ?encoding? data"} +} -returnCodes 1 -result {wrong # args: should be "::tcl::encoding::convertfrom ?-nocomplain? ?encoding? data"} test encoding-24.23 {Syntax error, two encodings} -body { encoding convertto iso8859-1 utf-8 "ZX\uD800" -} -returnCodes 1 -result {wrong # args: should be "::tcl::encoding::convertto ?-nothrow? ?encoding? data"} +} -returnCodes 1 -result {wrong # args: should be "::tcl::encoding::convertto ?-nocomplain? ?encoding? data"} file delete [file join [temporaryDirectory] iso2022.txt] @@ -828,7 +828,7 @@ test encoding-28.0 {all encodings load} -body { set string hello foreach name [encoding names] { incr count - encoding convertto -nothrow $name $string + encoding convertto -nocomplain $name $string # discard the cached internal representation of Tcl_Encoding # Unfortunately, without this, encoding 2-1 fails. diff --git a/tests/safe.test b/tests/safe.test index d5e2f00..5f3eae8 100644 --- a/tests/safe.test +++ b/tests/safe.test @@ -1269,7 +1269,7 @@ test safe-11.7 {testing safe encoding} -setup { interp eval $i encoding convertfrom } -returnCodes error -cleanup { safe::interpDelete $i -} -result {wrong # args: should be "encoding convertfrom ?-nothrow? ?encoding? data"} +} -result {wrong # args: should be "encoding convertfrom ?-nocomplain? ?encoding? data"} test safe-11.7.1 {testing safe encoding} -setup { set i [safe::interpCreate] } -body { @@ -1278,7 +1278,7 @@ test safe-11.7.1 {testing safe encoding} -setup { } -returnCodes ok -match glob -cleanup { unset -nocomplain m o safe::interpDelete $i -} -result {wrong # args: should be "encoding convertfrom ?-nothrow? ?encoding? data" +} -result {wrong # args: should be "encoding convertfrom ?-nocomplain? ?encoding? data" while executing "encoding convertfrom" invoked from within @@ -1291,7 +1291,7 @@ test safe-11.8 {testing safe encoding} -setup { interp eval $i encoding convertto } -returnCodes error -cleanup { safe::interpDelete $i -} -result {wrong # args: should be "encoding convertto ?-nothrow? ?encoding? data"} +} -result {wrong # args: should be "encoding convertto ?-nocomplain? ?encoding? data"} test safe-11.8.1 {testing safe encoding} -setup { set i [safe::interpCreate] } -body { @@ -1300,7 +1300,7 @@ test safe-11.8.1 {testing safe encoding} -setup { } -returnCodes ok -match glob -cleanup { unset -nocomplain m o safe::interpDelete $i -} -result {wrong # args: should be "encoding convertto ?-nothrow? ?encoding? data" +} -result {wrong # args: should be "encoding convertto ?-nocomplain? ?encoding? data" while executing "encoding convertto" invoked from within -- cgit v0.12 From 108b27d54956ad01e5bfe6ba29a2a244251ccb57 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Sun, 6 Mar 2022 15:28:52 +0000 Subject: More progress --- doc/ParseCmd.3 | 8 +-- generic/tcl.h | 21 +++++--- generic/tclAssembly.c | 64 +++++++++++----------- generic/tclBasic.c | 8 +-- generic/tclCompCmds.c | 140 ++++++++++++++++++++++++------------------------ generic/tclCompCmdsGR.c | 124 +++++++++++++++++++++--------------------- generic/tclCompCmdsSZ.c | 118 ++++++++++++++++++++-------------------- generic/tclCompExpr.c | 16 +++--- generic/tclCompile.c | 18 +++---- generic/tclEnsemble.c | 34 ++++++------ generic/tclExecute.c | 10 ++-- generic/tclInt.h | 15 +----- generic/tclParse.c | 40 +++++++------- generic/tclTest.c | 8 +-- 14 files changed, 309 insertions(+), 315 deletions(-) diff --git a/doc/ParseCmd.3 b/doc/ParseCmd.3 index 9da0d42..d93f00c 100644 --- a/doc/ParseCmd.3 +++ b/doc/ParseCmd.3 @@ -196,12 +196,12 @@ return parse information in two data structures, Tcl_Parse and Tcl_Token: .CS typedef struct Tcl_Parse { const char *\fIcommentStart\fR; - int \fIcommentSize\fR; + size_t \fIcommentSize\fR; const char *\fIcommandStart\fR; - int \fIcommandSize\fR; - int \fInumWords\fR; + size_t \fIcommandSize\fR; + size_t \fInumWords\fR; Tcl_Token *\fItokenPtr\fR; - int \fInumTokens\fR; + size_t \fInumTokens\fR; ... } \fBTcl_Parse\fR; diff --git a/generic/tcl.h b/generic/tcl.h index 2356089..b609feb 100644 --- a/generic/tcl.h +++ b/generic/tcl.h @@ -1766,22 +1766,28 @@ typedef struct Tcl_Parse { * field is 0. */ const char *commandStart; /* First character in first word of * command. */ - int commandSize; /* Number of bytes in command, including first + size_t commandSize; /* Number of bytes in command, including first * character of first word, up through the * terminating newline, close bracket, or * semicolon. */ - int numWords; /* Total number of words in command. May be + size_t numWords; /* Total number of words in command. May be * 0. */ Tcl_Token *tokenPtr; /* Pointer to first token representing the * words of the command. Initially points to * staticTokens, but may change to point to * malloc-ed space if command exceeds space in * staticTokens. */ - int numTokens; /* Total number of tokens in command. */ - int tokensAvailable; /* Total number of tokens available at + size_t numTokens; /* Total number of tokens in command. */ + size_t tokensAvailable; /* Total number of tokens available at * *tokenPtr. */ int errorType; /* One of the parsing error types defined * above. */ +#if TCL_MAJOR_VERSION > 8 + int incomplete; /* This field is set to 1 by Tcl_ParseCommand + * if the command appears to be incomplete. + * This information is used by + * Tcl_CommandComplete. */ +#endif /* * The fields below are intended only for the private use of the parser. @@ -1800,10 +1806,9 @@ typedef struct Tcl_Parse { * beginning of region where the error * occurred (e.g. the open brace if the close * brace is missing). */ - int incomplete; /* This field is set to 1 by Tcl_ParseCommand - * if the command appears to be incomplete. - * This information is used by - * Tcl_CommandComplete. */ +#if TCL_MAJOR_VERSION < 9 + int incomplete; +#endif Tcl_Token staticTokens[NUM_STATIC_TOKENS]; /* Initial space for tokens for command. This * space should be large enough to accommodate diff --git a/generic/tclAssembly.c b/generic/tclAssembly.c index 1ea3d37..e3e7bfc 100644 --- a/generic/tclAssembly.c +++ b/generic/tclAssembly.c @@ -970,7 +970,7 @@ TclCompileAssembleCmd( * Make sure that the command has a single arg that is a simple word. */ - if (parsePtr->numWords != 2) { + if ((int)parsePtr->numWords != 2) { return TCL_ERROR; } tokenPtr = TokenAfter(parsePtr->tokenPtr); @@ -1074,8 +1074,8 @@ TclAssembleCode( * Process the line of code. */ - if (parsePtr->numWords > 0) { - size_t instLen = parsePtr->commandSize; + if ((int)parsePtr->numWords > 0) { + size_t instLen = (int)parsePtr->commandSize; /* Length in bytes of the current command */ if (parsePtr->term == parsePtr->commandStart + instLen - 1) { @@ -1304,7 +1304,7 @@ AssembleOneLine( switch (instType) { case ASSEM_PUSH: - if (parsePtr->numWords != 2) { + if ((int)parsePtr->numWords != 2) { Tcl_WrongNumArgs(interp, 1, &instNameObj, "value"); goto cleanup; } @@ -1317,7 +1317,7 @@ AssembleOneLine( break; case ASSEM_1BYTE: - if (parsePtr->numWords != 1) { + if ((int)parsePtr->numWords != 1) { Tcl_WrongNumArgs(interp, 1, &instNameObj, ""); goto cleanup; } @@ -1332,7 +1332,7 @@ AssembleOneLine( * are being resolved. */ - if (parsePtr->numWords != 2) { + if ((int)parsePtr->numWords != 2) { Tcl_WrongNumArgs(interp, 1, &instNameObj, "label"); goto cleanup; } @@ -1347,7 +1347,7 @@ AssembleOneLine( break; case ASSEM_BOOL: - if (parsePtr->numWords != 2) { + if ((int)parsePtr->numWords != 2) { Tcl_WrongNumArgs(interp, 1, &instNameObj, "boolean"); goto cleanup; } @@ -1358,7 +1358,7 @@ AssembleOneLine( break; case ASSEM_BOOL_LVT4: - if (parsePtr->numWords != 3) { + if ((int)parsePtr->numWords != 3) { Tcl_WrongNumArgs(interp, 1, &instNameObj, "boolean varName"); goto cleanup; } @@ -1374,7 +1374,7 @@ AssembleOneLine( break; case ASSEM_CLOCK_READ: - if (parsePtr->numWords != 2) { + if ((int)parsePtr->numWords != 2) { Tcl_WrongNumArgs(interp, 1, &instNameObj, "imm8"); goto cleanup; } @@ -1391,7 +1391,7 @@ AssembleOneLine( break; case ASSEM_CONCAT1: - if (parsePtr->numWords != 2) { + if ((int)parsePtr->numWords != 2) { Tcl_WrongNumArgs(interp, 1, &instNameObj, "imm8"); goto cleanup; } @@ -1405,7 +1405,7 @@ AssembleOneLine( case ASSEM_DICT_GET: case ASSEM_DICT_GET_DEF: - if (parsePtr->numWords != 2) { + if ((int)parsePtr->numWords != 2) { Tcl_WrongNumArgs(interp, 1, &instNameObj, "count"); goto cleanup; } @@ -1417,7 +1417,7 @@ AssembleOneLine( break; case ASSEM_DICT_SET: - if (parsePtr->numWords != 3) { + if ((int)parsePtr->numWords != 3) { Tcl_WrongNumArgs(interp, 1, &instNameObj, "count varName"); goto cleanup; } @@ -1434,7 +1434,7 @@ AssembleOneLine( break; case ASSEM_DICT_UNSET: - if (parsePtr->numWords != 3) { + if ((int)parsePtr->numWords != 3) { Tcl_WrongNumArgs(interp, 1, &instNameObj, "count varName"); goto cleanup; } @@ -1451,7 +1451,7 @@ AssembleOneLine( break; case ASSEM_END_CATCH: - if (parsePtr->numWords != 1) { + if ((int)parsePtr->numWords != 1) { Tcl_WrongNumArgs(interp, 1, &instNameObj, ""); goto cleanup; } @@ -1465,7 +1465,7 @@ AssembleOneLine( * code, the message ("script" or "expression") and an evaluator * callback that calls TclCompileScript or TclCompileExpr. */ - if (parsePtr->numWords != 2) { + if ((int)parsePtr->numWords != 2) { Tcl_WrongNumArgs(interp, 1, &instNameObj, ((TalInstructionTable[tblIdx].tclInstCode == INST_EVAL_STK) ? "script" : "expression")); @@ -1491,7 +1491,7 @@ AssembleOneLine( break; case ASSEM_INVOKE: - if (parsePtr->numWords != 2) { + if ((int)parsePtr->numWords != 2) { Tcl_WrongNumArgs(interp, 1, &instNameObj, "count"); goto cleanup; } @@ -1505,7 +1505,7 @@ AssembleOneLine( case ASSEM_JUMP: case ASSEM_JUMP4: - if (parsePtr->numWords != 2) { + if ((int)parsePtr->numWords != 2) { Tcl_WrongNumArgs(interp, 1, &instNameObj, "label"); goto cleanup; } @@ -1533,7 +1533,7 @@ AssembleOneLine( break; case ASSEM_JUMPTABLE: - if (parsePtr->numWords != 2) { + if ((int)parsePtr->numWords != 2) { Tcl_WrongNumArgs(interp, 1, &instNameObj, "table"); goto cleanup; } @@ -1561,7 +1561,7 @@ AssembleOneLine( break; case ASSEM_LABEL: - if (parsePtr->numWords != 2) { + if ((int)parsePtr->numWords != 2) { Tcl_WrongNumArgs(interp, 1, &instNameObj, "name"); goto cleanup; } @@ -1579,7 +1579,7 @@ AssembleOneLine( break; case ASSEM_LINDEX_MULTI: - if (parsePtr->numWords != 2) { + if ((int)parsePtr->numWords != 2) { Tcl_WrongNumArgs(interp, 1, &instNameObj, "count"); goto cleanup; } @@ -1591,7 +1591,7 @@ AssembleOneLine( break; case ASSEM_LIST: - if (parsePtr->numWords != 2) { + if ((int)parsePtr->numWords != 2) { Tcl_WrongNumArgs(interp, 1, &instNameObj, "count"); goto cleanup; } @@ -1603,7 +1603,7 @@ AssembleOneLine( break; case ASSEM_INDEX: - if (parsePtr->numWords != 2) { + if ((int)parsePtr->numWords != 2) { Tcl_WrongNumArgs(interp, 1, &instNameObj, "count"); goto cleanup; } @@ -1614,7 +1614,7 @@ AssembleOneLine( break; case ASSEM_LSET_FLAT: - if (parsePtr->numWords != 2) { + if ((int)parsePtr->numWords != 2) { Tcl_WrongNumArgs(interp, 1, &instNameObj, "count"); goto cleanup; } @@ -1633,7 +1633,7 @@ AssembleOneLine( break; case ASSEM_LVT: - if (parsePtr->numWords != 2) { + if ((int)parsePtr->numWords != 2) { Tcl_WrongNumArgs(interp, 1, &instNameObj, "varname"); goto cleanup; } @@ -1645,7 +1645,7 @@ AssembleOneLine( break; case ASSEM_LVT1: - if (parsePtr->numWords != 2) { + if ((int)parsePtr->numWords != 2) { Tcl_WrongNumArgs(interp, 1, &instNameObj, "varname"); goto cleanup; } @@ -1657,7 +1657,7 @@ AssembleOneLine( break; case ASSEM_LVT1_SINT1: - if (parsePtr->numWords != 3) { + if ((int)parsePtr->numWords != 3) { Tcl_WrongNumArgs(interp, 1, &instNameObj, "varName imm8"); goto cleanup; } @@ -1672,7 +1672,7 @@ AssembleOneLine( break; case ASSEM_LVT4: - if (parsePtr->numWords != 2) { + if ((int)parsePtr->numWords != 2) { Tcl_WrongNumArgs(interp, 1, &instNameObj, "varname"); goto cleanup; } @@ -1684,7 +1684,7 @@ AssembleOneLine( break; case ASSEM_OVER: - if (parsePtr->numWords != 2) { + if ((int)parsePtr->numWords != 2) { Tcl_WrongNumArgs(interp, 1, &instNameObj, "count"); goto cleanup; } @@ -1696,7 +1696,7 @@ AssembleOneLine( break; case ASSEM_REGEXP: - if (parsePtr->numWords != 2) { + if ((int)parsePtr->numWords != 2) { Tcl_WrongNumArgs(interp, 1, &instNameObj, "boolean"); goto cleanup; } @@ -1709,7 +1709,7 @@ AssembleOneLine( break; case ASSEM_REVERSE: - if (parsePtr->numWords != 2) { + if ((int)parsePtr->numWords != 2) { Tcl_WrongNumArgs(interp, 1, &instNameObj, "count"); goto cleanup; } @@ -1721,7 +1721,7 @@ AssembleOneLine( break; case ASSEM_SINT1: - if (parsePtr->numWords != 2) { + if ((int)parsePtr->numWords != 2) { Tcl_WrongNumArgs(interp, 1, &instNameObj, "imm8"); goto cleanup; } @@ -1733,7 +1733,7 @@ AssembleOneLine( break; case ASSEM_SINT4_LVT4: - if (parsePtr->numWords != 3) { + if ((int)parsePtr->numWords != 3) { Tcl_WrongNumArgs(interp, 1, &instNameObj, "count varName"); goto cleanup; } diff --git a/generic/tclBasic.c b/generic/tclBasic.c index fe4f5cb..642f366 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -5146,7 +5146,7 @@ TclEvalEx( parsePtr->commandStart - outerScript); gotParse = 1; - if (parsePtr->numWords > 0) { + if ((int)parsePtr->numWords > 0) { /* * TIP #280. Track lines within the words of the current * command. We use a separate pointer into the table of @@ -5302,7 +5302,7 @@ TclEvalEx( eeFramePtr->len = parsePtr->commandSize; if (parsePtr->term == - parsePtr->commandStart + parsePtr->commandSize - 1) { + parsePtr->commandStart + (int)parsePtr->commandSize - 1) { eeFramePtr->len--; } @@ -5353,7 +5353,7 @@ TclEvalEx( * executed command. */ - next = parsePtr->commandStart + parsePtr->commandSize; + next = parsePtr->commandStart + (int)parsePtr->commandSize; bytesLeft -= next - p; p = next; TclAdvanceLines(&line, parsePtr->commandStart, p); @@ -5379,7 +5379,7 @@ TclEvalEx( } } if ((code == TCL_ERROR) && !(iPtr->flags & ERR_ALREADY_LOGGED)) { - commandLength = parsePtr->commandSize; + commandLength = (int)parsePtr->commandSize; if (parsePtr->term == parsePtr->commandStart + commandLength - 1) { /* * The terminator character (such as ; or ]) of the command where diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c index c1cd174..9791bcc 100644 --- a/generic/tclCompCmds.c +++ b/generic/tclCompCmds.c @@ -255,7 +255,7 @@ TclCompileArrayExistsCmd( Tcl_Token *tokenPtr; int isScalar, localIndex; - if (parsePtr->numWords != 2) { + if ((int)parsePtr->numWords != 2) { return TCL_ERROR; } @@ -293,7 +293,7 @@ TclCompileArraySetCmd( Tcl_Obj *literalObj; ForeachInfo *infoPtr; - if (parsePtr->numWords != 3) { + if ((int)parsePtr->numWords != 3) { return TCL_ERROR; } @@ -461,7 +461,7 @@ TclCompileArrayUnsetCmd( Tcl_Token *tokenPtr = TokenAfter(parsePtr->tokenPtr); int isScalar, localIndex; - if (parsePtr->numWords != 2) { + if ((int)parsePtr->numWords != 2) { return TclCompileBasic2ArgCmd(interp, parsePtr, cmdPtr, envPtr); } @@ -519,7 +519,7 @@ TclCompileBreakCmd( ExceptionRange *rangePtr; ExceptionAux *auxPtr; - if (parsePtr->numWords != 1) { + if ((int)parsePtr->numWords != 1) { return TCL_ERROR; } @@ -584,7 +584,7 @@ TclCompileCatchCmd( * Let runtime checks determine if syntax has changed. */ - if ((parsePtr->numWords < 2) || (parsePtr->numWords > 4)) { + if (((int)parsePtr->numWords < 2) || ((int)parsePtr->numWords > 4)) { return TCL_ERROR; } @@ -593,7 +593,7 @@ TclCompileCatchCmd( * (not in a procedure), don't compile it inline: the payoff is too small. */ - if ((parsePtr->numWords >= 3) && !EnvHasLVT(envPtr)) { + if (((int)parsePtr->numWords >= 3) && !EnvHasLVT(envPtr)) { return TCL_ERROR; } @@ -604,7 +604,7 @@ TclCompileCatchCmd( resultIndex = optsIndex = -1; cmdTokenPtr = TokenAfter(parsePtr->tokenPtr); - if (parsePtr->numWords >= 3) { + if ((int)parsePtr->numWords >= 3) { resultNameTokenPtr = TokenAfter(cmdTokenPtr); /* DGP */ resultIndex = LocalScalarFromToken(resultNameTokenPtr, envPtr); @@ -613,7 +613,7 @@ TclCompileCatchCmd( } /* DKF */ - if (parsePtr->numWords == 4) { + if ((int)parsePtr->numWords == 4) { optsNameTokenPtr = TokenAfter(resultNameTokenPtr); optsIndex = LocalScalarFromToken(optsNameTokenPtr, envPtr); if (optsIndex < 0) { @@ -759,7 +759,7 @@ TclCompileClockClicksCmd( { Tcl_Token* tokenPtr; - switch (parsePtr->numWords) { + switch ((int)parsePtr->numWords) { case 1: /* * No args @@ -821,7 +821,7 @@ TclCompileClockReadingCmd( * compiled. */ CompileEnv *envPtr) /* Holds resulting instructions. */ { - if (parsePtr->numWords != 1) { + if ((int)parsePtr->numWords != 1) { return TCL_ERROR; } @@ -862,7 +862,7 @@ TclCompileConcatCmd( int i; /* TODO: Consider compiling expansion case. */ - if (parsePtr->numWords == 1) { + if ((int)parsePtr->numWords == 1) { /* * [concat] without arguments just pushes an empty object. */ @@ -877,7 +877,7 @@ TclCompileConcatCmd( */ TclNewObj(listObj); - for (i = 1, tokenPtr = parsePtr->tokenPtr; i < parsePtr->numWords; i++) { + for (i = 1, tokenPtr = parsePtr->tokenPtr; i < (int)parsePtr->numWords; i++) { tokenPtr = TokenAfter(tokenPtr); TclNewObj(objPtr); if (!TclWordKnownAtCompileTime(tokenPtr, objPtr)) { @@ -906,7 +906,7 @@ TclCompileConcatCmd( * General case: runtime concat. */ - for (i = 1, tokenPtr = parsePtr->tokenPtr; i < parsePtr->numWords; i++) { + for (i = 1, tokenPtr = parsePtr->tokenPtr; i < (int)parsePtr->numWords; i++) { tokenPtr = TokenAfter(tokenPtr); CompileWord(envPtr, tokenPtr, interp, i); } @@ -949,7 +949,7 @@ TclCompileContinueCmd( * There should be no argument after the "continue". */ - if (parsePtr->numWords != 1) { + if ((int)parsePtr->numWords != 1) { return TCL_ERROR; } @@ -1013,7 +1013,7 @@ TclCompileDictSetCmd( * There must be at least one argument after the command. */ - if (parsePtr->numWords < 4) { + if ((int)parsePtr->numWords < 4) { return TCL_ERROR; } @@ -1034,7 +1034,7 @@ TclCompileDictSetCmd( */ tokenPtr = TokenAfter(varTokenPtr); - for (i=2 ; i< parsePtr->numWords ; i++) { + for (i=2 ; i< (int)parsePtr->numWords ; i++) { CompileWord(envPtr, tokenPtr, interp, i); tokenPtr = TokenAfter(tokenPtr); } @@ -1043,7 +1043,7 @@ TclCompileDictSetCmd( * Now emit the instruction to do the dict manipulation. */ - TclEmitInstInt4( INST_DICT_SET, parsePtr->numWords-3, envPtr); + TclEmitInstInt4( INST_DICT_SET, (int)parsePtr->numWords-3, envPtr); TclEmitInt4( dictVarIndex, envPtr); TclAdjustStackDepth(-1, envPtr); return TCL_OK; @@ -1066,7 +1066,7 @@ TclCompileDictIncrCmd( * There must be at least two arguments after the command. */ - if (parsePtr->numWords < 3 || parsePtr->numWords > 4) { + if ((int)parsePtr->numWords < 3 || (int)parsePtr->numWords > 4) { return TCL_ERROR; } varTokenPtr = TokenAfter(parsePtr->tokenPtr); @@ -1076,7 +1076,7 @@ TclCompileDictIncrCmd( * Parse the increment amount, if present. */ - if (parsePtr->numWords == 4) { + if ((int)parsePtr->numWords == 4) { const char *word; size_t numBytes; int code; @@ -1140,7 +1140,7 @@ TclCompileDictGetCmd( */ /* TODO: Consider support for compiling expanded args. */ - if (parsePtr->numWords < 3) { + if ((int)parsePtr->numWords < 3) { return TCL_ERROR; } tokenPtr = TokenAfter(parsePtr->tokenPtr); @@ -1149,11 +1149,11 @@ TclCompileDictGetCmd( * Only compile this because we need INST_DICT_GET anyway. */ - for (i=1 ; inumWords ; i++) { + for (i=1 ; i<(int)parsePtr->numWords ; i++) { CompileWord(envPtr, tokenPtr, interp, i); tokenPtr = TokenAfter(tokenPtr); } - TclEmitInstInt4(INST_DICT_GET, parsePtr->numWords-2, envPtr); + TclEmitInstInt4(INST_DICT_GET, (int)parsePtr->numWords-2, envPtr); TclAdjustStackDepth(-1, envPtr); return TCL_OK; } @@ -1175,16 +1175,16 @@ TclCompileDictGetWithDefaultCmd( */ /* TODO: Consider support for compiling expanded args. */ - if (parsePtr->numWords < 4) { + if ((int)parsePtr->numWords < 4) { return TCL_ERROR; } tokenPtr = TokenAfter(parsePtr->tokenPtr); - for (i=1 ; inumWords ; i++) { + for (i=1 ; i<(int)parsePtr->numWords ; i++) { CompileWord(envPtr, tokenPtr, interp, i); tokenPtr = TokenAfter(tokenPtr); } - TclEmitInstInt4(INST_DICT_GET_DEF, parsePtr->numWords-3, envPtr); + TclEmitInstInt4(INST_DICT_GET_DEF, (int)parsePtr->numWords-3, envPtr); TclAdjustStackDepth(-2, envPtr); return TCL_OK; } @@ -1207,7 +1207,7 @@ TclCompileDictExistsCmd( */ /* TODO: Consider support for compiling expanded args. */ - if (parsePtr->numWords < 3) { + if ((int)parsePtr->numWords < 3) { return TCL_ERROR; } tokenPtr = TokenAfter(parsePtr->tokenPtr); @@ -1216,11 +1216,11 @@ TclCompileDictExistsCmd( * Now we do the code generation. */ - for (i=1 ; inumWords ; i++) { + for (i=1 ; i<(int)parsePtr->numWords ; i++) { CompileWord(envPtr, tokenPtr, interp, i); tokenPtr = TokenAfter(tokenPtr); } - TclEmitInstInt4(INST_DICT_EXISTS, parsePtr->numWords-2, envPtr); + TclEmitInstInt4(INST_DICT_EXISTS, (int)parsePtr->numWords-2, envPtr); TclAdjustStackDepth(-1, envPtr); return TCL_OK; } @@ -1244,7 +1244,7 @@ TclCompileDictUnsetCmd( */ /* TODO: Consider support for compiling expanded args. */ - if (parsePtr->numWords < 3) { + if ((int)parsePtr->numWords < 3) { return TCL_ERROR; } @@ -1264,7 +1264,7 @@ TclCompileDictUnsetCmd( * Remaining words (the key path) can be handled normally. */ - for (i=2 ; inumWords ; i++) { + for (i=2 ; i<(int)parsePtr->numWords ; i++) { tokenPtr = TokenAfter(tokenPtr); CompileWord(envPtr, tokenPtr, interp, i); } @@ -1273,7 +1273,7 @@ TclCompileDictUnsetCmd( * Now emit the instruction to do the dict manipulation. */ - TclEmitInstInt4( INST_DICT_UNSET, parsePtr->numWords-2, envPtr); + TclEmitInstInt4( INST_DICT_UNSET, (int)parsePtr->numWords-2, envPtr); TclEmitInt4( dictVarIndex, envPtr); return TCL_OK; } @@ -1295,7 +1295,7 @@ TclCompileDictCreateCmd( int i; size_t len; - if ((parsePtr->numWords & 1) == 0) { + if (((int)parsePtr->numWords & 1) == 0) { return TCL_ERROR; } @@ -1306,7 +1306,7 @@ TclCompileDictCreateCmd( tokenPtr = TokenAfter(parsePtr->tokenPtr); TclNewObj(dictObj); Tcl_IncrRefCount(dictObj); - for (i=1 ; inumWords ; i+=2) { + for (i=1 ; i<(int)parsePtr->numWords ; i+=2) { TclNewObj(keyObj); Tcl_IncrRefCount(keyObj); if (!TclWordKnownAtCompileTime(tokenPtr, keyObj)) { @@ -1356,7 +1356,7 @@ TclCompileDictCreateCmd( Emit14Inst( INST_STORE_SCALAR, worker, envPtr); TclEmitOpcode( INST_POP, envPtr); tokenPtr = TokenAfter(parsePtr->tokenPtr); - for (i=1 ; inumWords ; i+=2) { + for (i=1 ; i<(int)parsePtr->numWords ; i+=2) { CompileWord(envPtr, tokenPtr, interp, i); tokenPtr = TokenAfter(tokenPtr); CompileWord(envPtr, tokenPtr, interp, i+1); @@ -1391,10 +1391,10 @@ TclCompileDictMergeCmd( */ /* TODO: Consider support for compiling expanded args. (less likely) */ - if (parsePtr->numWords < 2) { + if ((int)parsePtr->numWords < 2) { PushStringLiteral(envPtr, ""); return TCL_OK; - } else if (parsePtr->numWords == 2) { + } else if ((int)parsePtr->numWords == 2) { tokenPtr = TokenAfter(parsePtr->tokenPtr); CompileWord(envPtr, tokenPtr, interp, 1); TclEmitOpcode( INST_DUP, envPtr); @@ -1433,7 +1433,7 @@ TclCompileDictMergeCmd( outLoop = TclCreateExceptRange(CATCH_EXCEPTION_RANGE, envPtr); TclEmitInstInt4( INST_BEGIN_CATCH4, outLoop, envPtr); ExceptionRangeStarts(envPtr, outLoop); - for (i=2 ; inumWords ; i++) { + for (i=2 ; i<(int)parsePtr->numWords ; i++) { /* * Get the dictionary, and merge its pairs into the first dict (using * a small loop). @@ -1539,7 +1539,7 @@ CompileDictEachCmd( * There must be three arguments after the command. */ - if (parsePtr->numWords != 4) { + if ((int)parsePtr->numWords != 4) { return TclCompileBasic3ArgCmd(interp, parsePtr, cmdPtr, envPtr); } @@ -1761,7 +1761,7 @@ TclCompileDictUpdateCmd( * There must be at least one argument after the command. */ - if (parsePtr->numWords < 5) { + if ((int)parsePtr->numWords < 5) { return TCL_ERROR; } @@ -1770,10 +1770,10 @@ TclCompileDictUpdateCmd( * dict update ? ...? */ - if ((parsePtr->numWords - 1) & 1) { + if (((int)parsePtr->numWords - 1) & 1) { return TCL_ERROR; } - numVars = (parsePtr->numWords - 3) / 2; + numVars = ((int)parsePtr->numWords - 3) / 2; /* * The dictionary variable must be a local scalar that is knowable at @@ -1840,7 +1840,7 @@ TclCompileDictUpdateCmd( TclEmitInstInt4( INST_BEGIN_CATCH4, range, envPtr); ExceptionRangeStarts(envPtr, range); - BODY(bodyTokenPtr, parsePtr->numWords - 1); + BODY(bodyTokenPtr, (int)parsePtr->numWords - 1); ExceptionRangeEnds(envPtr, range); /* @@ -1913,7 +1913,7 @@ TclCompileDictAppendCmd( */ /* TODO: Consider support for compiling expanded args. */ - if (parsePtr->numWords<4 || parsePtr->numWords>100) { + if ((int)parsePtr->numWords<4 || (int)parsePtr->numWords>100) { return TCL_ERROR; } @@ -1932,12 +1932,12 @@ TclCompileDictAppendCmd( */ tokenPtr = TokenAfter(tokenPtr); - for (i=2 ; inumWords ; i++) { + for (i=2 ; i<(int)parsePtr->numWords ; i++) { CompileWord(envPtr, tokenPtr, interp, i); tokenPtr = TokenAfter(tokenPtr); } - if (parsePtr->numWords > 4) { - TclEmitInstInt1(INST_STR_CONCAT1, parsePtr->numWords-3, envPtr); + if ((int)parsePtr->numWords > 4) { + TclEmitInstInt1(INST_STR_CONCAT1, (int)parsePtr->numWords-3, envPtr); } /* @@ -1967,7 +1967,7 @@ TclCompileDictLappendCmd( /* TODO: Consider support for compiling expanded args. */ /* Probably not. Why is INST_DICT_LAPPEND limited to one value? */ - if (parsePtr->numWords != 4) { + if ((int)parsePtr->numWords != 4) { return TCL_ERROR; } @@ -2014,7 +2014,7 @@ TclCompileDictWithCmd( */ /* TODO: Consider support for compiling expanded args. */ - if (parsePtr->numWords < 3) { + if ((int)parsePtr->numWords < 3) { return TCL_ERROR; } @@ -2025,7 +2025,7 @@ TclCompileDictWithCmd( varTokenPtr = TokenAfter(parsePtr->tokenPtr); tokenPtr = TokenAfter(varTokenPtr); - for (i=3 ; inumWords ; i++) { + for (i=3 ; i<(int)parsePtr->numWords ; i++) { tokenPtr = TokenAfter(tokenPtr); } if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { @@ -2053,7 +2053,7 @@ TclCompileDictWithCmd( * Determine if we're manipulating a dict in a simple local variable. */ - gotPath = (parsePtr->numWords > 3); + gotPath = ((int)parsePtr->numWords > 3); dictVar = LocalScalarFromToken(varTokenPtr, envPtr); /* @@ -2072,11 +2072,11 @@ TclCompileDictWithCmd( */ tokenPtr = TokenAfter(varTokenPtr); - for (i=2 ; inumWords-1 ; i++) { + for (i=2 ; i<(int)parsePtr->numWords-1 ; i++) { CompileWord(envPtr, tokenPtr, interp, i); tokenPtr = TokenAfter(tokenPtr); } - TclEmitInstInt4(INST_LIST, parsePtr->numWords-3,envPtr); + TclEmitInstInt4(INST_LIST, (int)parsePtr->numWords-3,envPtr); Emit14Inst( INST_LOAD_SCALAR, dictVar, envPtr); TclEmitInstInt4(INST_OVER, 1, envPtr); TclEmitOpcode( INST_DICT_EXPAND, envPtr); @@ -2099,11 +2099,11 @@ TclCompileDictWithCmd( */ tokenPtr = varTokenPtr; - for (i=1 ; inumWords-1 ; i++) { + for (i=1 ; i<(int)parsePtr->numWords-1 ; i++) { CompileWord(envPtr, tokenPtr, interp, i); tokenPtr = TokenAfter(tokenPtr); } - TclEmitInstInt4(INST_LIST, parsePtr->numWords-3,envPtr); + TclEmitInstInt4(INST_LIST, (int)parsePtr->numWords-3,envPtr); TclEmitInstInt4(INST_OVER, 1, envPtr); TclEmitOpcode( INST_LOAD_STK, envPtr); TclEmitInstInt4(INST_OVER, 1, envPtr); @@ -2154,11 +2154,11 @@ TclCompileDictWithCmd( } tokenPtr = TokenAfter(varTokenPtr); if (gotPath) { - for (i=2 ; inumWords-1 ; i++) { + for (i=2 ; i<(int)parsePtr->numWords-1 ; i++) { CompileWord(envPtr, tokenPtr, interp, i); tokenPtr = TokenAfter(tokenPtr); } - TclEmitInstInt4( INST_LIST, parsePtr->numWords-3,envPtr); + TclEmitInstInt4( INST_LIST, (int)parsePtr->numWords-3,envPtr); Emit14Inst( INST_STORE_SCALAR, pathTmp, envPtr); TclEmitOpcode( INST_POP, envPtr); } @@ -2184,7 +2184,7 @@ TclCompileDictWithCmd( TclEmitInstInt4( INST_BEGIN_CATCH4, range, envPtr); ExceptionRangeStarts(envPtr, range); - BODY(tokenPtr, parsePtr->numWords - 1); + BODY(tokenPtr, (int)parsePtr->numWords - 1); ExceptionRangeEnds(envPtr, range); /* @@ -2220,7 +2220,7 @@ TclCompileDictWithCmd( if (dictVar == -1) { Emit14Inst( INST_LOAD_SCALAR, varNameTmp, envPtr); } - if (parsePtr->numWords > 3) { + if ((int)parsePtr->numWords > 3) { Emit14Inst( INST_LOAD_SCALAR, pathTmp, envPtr); } else { PushStringLiteral(envPtr, ""); @@ -2359,7 +2359,7 @@ TclCompileErrorCmd( * General syntax: [error message ?errorInfo? ?errorCode?] */ - if (parsePtr->numWords < 2 || parsePtr->numWords > 4) { + if ((int)parsePtr->numWords < 2 || (int)parsePtr->numWords > 4) { return TCL_ERROR; } @@ -2374,13 +2374,13 @@ TclCompileErrorCmd( * Construct the options. Note that -code and -level are not here. */ - if (parsePtr->numWords == 2) { + if ((int)parsePtr->numWords == 2) { PushStringLiteral(envPtr, ""); } else { PushStringLiteral(envPtr, "-errorinfo"); tokenPtr = TokenAfter(tokenPtr); CompileWord(envPtr, tokenPtr, interp, 2); - if (parsePtr->numWords == 3) { + if ((int)parsePtr->numWords == 3) { TclEmitInstInt4( INST_LIST, 2, envPtr); } else { PushStringLiteral(envPtr, "-errorcode"); @@ -2427,7 +2427,7 @@ TclCompileExprCmd( { Tcl_Token *firstWordPtr; - if (parsePtr->numWords == 1) { + if ((int)parsePtr->numWords == 1) { return TCL_ERROR; } @@ -2439,7 +2439,7 @@ TclCompileExprCmd( envPtr->extCmdMapPtr->nuloc-1].line[1]; firstWordPtr = TokenAfter(parsePtr->tokenPtr); - TclCompileExprWords(interp, firstWordPtr, parsePtr->numWords-1, envPtr); + TclCompileExprWords(interp, firstWordPtr, (int)parsePtr->numWords-1, envPtr); return TCL_OK; } @@ -2475,7 +2475,7 @@ TclCompileForCmd( int bodyCodeOffset, nextCodeOffset, jumpDist; int bodyRange, nextRange; - if (parsePtr->numWords != 5) { + if ((int)parsePtr->numWords != 5) { return TCL_ERROR; } @@ -2702,7 +2702,7 @@ CompileEachloopCmd( return TCL_ERROR; } - numWords = parsePtr->numWords; + numWords = (int)parsePtr->numWords; if ((numWords < 4) || (numWords%2 != 0)) { return TCL_ERROR; } @@ -3162,7 +3162,7 @@ TclCompileFormatCmd( * Don't handle any guaranteed-error cases. */ - if (parsePtr->numWords < 2) { + if ((int)parsePtr->numWords < 2) { return TCL_ERROR; } @@ -3179,8 +3179,8 @@ TclCompileFormatCmd( return TCL_ERROR; } - objv = (Tcl_Obj **)Tcl_Alloc((parsePtr->numWords-2) * sizeof(Tcl_Obj *)); - for (i=0 ; i+2 < parsePtr->numWords ; i++) { + objv = (Tcl_Obj **)Tcl_Alloc(((int)parsePtr->numWords-2) * sizeof(Tcl_Obj *)); + for (i=0 ; i+2 < (int)parsePtr->numWords ; i++) { tokenPtr = TokenAfter(tokenPtr); TclNewObj(objv[i]); Tcl_IncrRefCount(objv[i]); @@ -3195,7 +3195,7 @@ TclCompileFormatCmd( */ tmpObj = Tcl_Format(interp, TclGetString(formatObj), - parsePtr->numWords-2, objv); + (int)parsePtr->numWords-2, objv); for (; --i>=0 ;) { Tcl_DecrRefCount(objv[i]); } @@ -3256,7 +3256,7 @@ TclCompileFormatCmd( * Check if the number of things to concatenate will fit in a byte. */ - if (i+2 != parsePtr->numWords || i > 125) { + if (i+2 != (int)parsePtr->numWords || i > 125) { Tcl_DecrRefCount(formatObj); return TCL_ERROR; } diff --git a/generic/tclCompCmdsGR.c b/generic/tclCompCmdsGR.c index bb1c21b..6486b21 100644 --- a/generic/tclCompCmdsGR.c +++ b/generic/tclCompCmdsGR.c @@ -95,7 +95,7 @@ TclCompileGlobalCmd( int localIndex, numWords, i; /* TODO: Consider support for compiling expanded args. */ - numWords = parsePtr->numWords; + numWords = (int)parsePtr->numWords; if (numWords < 2) { return TCL_ERROR; } @@ -196,7 +196,7 @@ TclCompileIfCmd( tokenPtr = parsePtr->tokenPtr; wordIdx = 0; - numWords = parsePtr->numWords; + numWords = (int)parsePtr->numWords; for (wordIdx = 0; wordIdx < numWords; wordIdx++) { if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { @@ -478,7 +478,7 @@ TclCompileIncrCmd( Tcl_Token *varTokenPtr, *incrTokenPtr; int isScalar, localIndex, haveImmValue, immValue; - if ((parsePtr->numWords != 2) && (parsePtr->numWords != 3)) { + if (((int)parsePtr->numWords != 2) && ((int)parsePtr->numWords != 3)) { return TCL_ERROR; } @@ -494,7 +494,7 @@ TclCompileIncrCmd( haveImmValue = 0; immValue = 1; - if (parsePtr->numWords == 3) { + if ((int)parsePtr->numWords == 3) { incrTokenPtr = TokenAfter(varTokenPtr); if (incrTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) { const char *word = incrTokenPtr[1].start; @@ -594,9 +594,9 @@ TclCompileInfoCommandsCmd( * We require one compile-time known argument for the case we can compile. */ - if (parsePtr->numWords == 1) { + if ((int)parsePtr->numWords == 1) { return TclCompileBasic0ArgCmd(interp, parsePtr, cmdPtr, envPtr); - } else if (parsePtr->numWords != 2) { + } else if ((int)parsePtr->numWords != 2) { return TCL_ERROR; } tokenPtr = TokenAfter(parsePtr->tokenPtr); @@ -649,7 +649,7 @@ TclCompileInfoCoroutineCmd( * Only compile [info coroutine] without arguments. */ - if (parsePtr->numWords != 1) { + if ((int)parsePtr->numWords != 1) { return TCL_ERROR; } @@ -673,7 +673,7 @@ TclCompileInfoExistsCmd( Tcl_Token *tokenPtr; int isScalar, localIndex; - if (parsePtr->numWords != 2) { + if ((int)parsePtr->numWords != 2) { return TCL_ERROR; } @@ -721,13 +721,13 @@ TclCompileInfoLevelCmd( * Only compile [info level] without arguments or with a single argument. */ - if (parsePtr->numWords == 1) { + if ((int)parsePtr->numWords == 1) { /* * Not much to do; we compile to a single instruction... */ TclEmitOpcode( INST_INFO_LEVEL_NUM, envPtr); - } else if (parsePtr->numWords != 2) { + } else if ((int)parsePtr->numWords != 2) { return TCL_ERROR; } else { DefineLineInformation; /* TIP #280 */ @@ -754,7 +754,7 @@ TclCompileInfoObjectClassCmd( DefineLineInformation; /* TIP #280 */ Tcl_Token *tokenPtr = TokenAfter(parsePtr->tokenPtr); - if (parsePtr->numWords != 2) { + if ((int)parsePtr->numWords != 2) { return TCL_ERROR; } CompileWord(envPtr, tokenPtr, interp, 1); @@ -779,7 +779,7 @@ TclCompileInfoObjectIsACmd( * engine. */ - if (parsePtr->numWords != 3) { + if ((int)parsePtr->numWords != 3) { return TCL_ERROR; } if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD || tokenPtr[1].size < 1 @@ -808,7 +808,7 @@ TclCompileInfoObjectNamespaceCmd( DefineLineInformation; /* TIP #280 */ Tcl_Token *tokenPtr = TokenAfter(parsePtr->tokenPtr); - if (parsePtr->numWords != 2) { + if ((int)parsePtr->numWords != 2) { return TCL_ERROR; } CompileWord(envPtr, tokenPtr, interp, 1); @@ -847,7 +847,7 @@ TclCompileLappendCmd( int isScalar, localIndex, numWords, i; /* TODO: Consider support for compiling expanded args. */ - numWords = parsePtr->numWords; + numWords = (int)parsePtr->numWords; if (numWords < 3) { return TCL_ERROR; } @@ -961,7 +961,7 @@ TclCompileLassignCmd( Tcl_Token *tokenPtr; int isScalar, localIndex, numWords, idx; - numWords = parsePtr->numWords; + numWords = (int)parsePtr->numWords; /* * Check for command syntax error, but we'll punt that to runtime. @@ -1062,7 +1062,7 @@ TclCompileLindexCmd( { DefineLineInformation; /* TIP #280 */ Tcl_Token *idxTokenPtr, *valTokenPtr; - int i, idx, numWords = parsePtr->numWords; + int i, idx, numWords = (int)parsePtr->numWords; /* * Quit if not enough args. @@ -1155,7 +1155,7 @@ TclCompileListCmd( int i, numWords, concat, build; Tcl_Obj *listObj, *objPtr; - if (parsePtr->numWords == 1) { + if ((int)parsePtr->numWords == 1) { /* * [list] without arguments just pushes an empty object. */ @@ -1169,7 +1169,7 @@ TclCompileListCmd( * implement with a simple push. */ - numWords = parsePtr->numWords; + numWords = (int)parsePtr->numWords; valueTokenPtr = TokenAfter(parsePtr->tokenPtr); TclNewObj(listObj); for (i = 1; i < numWords && listObj != NULL; i++) { @@ -1192,7 +1192,7 @@ TclCompileListCmd( * Push the all values onto the stack. */ - numWords = parsePtr->numWords; + numWords = (int)parsePtr->numWords; valueTokenPtr = TokenAfter(parsePtr->tokenPtr); concat = build = 0; for (i = 1; i < numWords; i++) { @@ -1266,7 +1266,7 @@ TclCompileLlengthCmd( DefineLineInformation; /* TIP #280 */ Tcl_Token *varTokenPtr; - if (parsePtr->numWords != 2) { + if ((int)parsePtr->numWords != 2) { return TCL_ERROR; } varTokenPtr = TokenAfter(parsePtr->tokenPtr); @@ -1299,7 +1299,7 @@ TclCompileLrangeCmd( Tcl_Token *tokenPtr, *listTokenPtr; int idx1, idx2; - if (parsePtr->numWords != 4) { + if ((int)parsePtr->numWords != 4) { return TCL_ERROR; } listTokenPtr = TokenAfter(parsePtr->tokenPtr); @@ -1359,7 +1359,7 @@ TclCompileLinsertCmd( Tcl_Token *tokenPtr, *listTokenPtr; int idx, i; - if (parsePtr->numWords < 3) { + if ((int)parsePtr->numWords < 3) { return TCL_ERROR; } listTokenPtr = TokenAfter(parsePtr->tokenPtr); @@ -1392,13 +1392,13 @@ TclCompileLinsertCmd( */ CompileWord(envPtr, listTokenPtr, interp, 1); - if (parsePtr->numWords == 3) { + if ((int)parsePtr->numWords == 3) { TclEmitInstInt4( INST_LIST_RANGE_IMM, 0, envPtr); TclEmitInt4( (int)TCL_INDEX_END, envPtr); return TCL_OK; } - for (i=3 ; inumWords ; i++) { + for (i=3 ; i<(int)parsePtr->numWords ; i++) { tokenPtr = TokenAfter(tokenPtr); CompileWord(envPtr, tokenPtr, interp, i); } @@ -1462,7 +1462,7 @@ TclCompileLreplaceCmd( int idx1, idx2, i; int emptyPrefix=1, suffixStart = 0; - if (parsePtr->numWords < 4) { + if ((int)parsePtr->numWords < 4) { return TCL_ERROR; } listTokenPtr = TokenAfter(parsePtr->tokenPtr); @@ -1510,10 +1510,10 @@ TclCompileLreplaceCmd( * Push all the replacement values next so any errors raised in * creating them get raised first. */ - if (parsePtr->numWords > 4) { + if ((int)parsePtr->numWords > 4) { /* Push the replacement arguments */ tokenPtr = TokenAfter(tokenPtr); - for (i=4 ; inumWords ; i++) { + for (i=4 ; i<(int)parsePtr->numWords ; i++) { CompileWord(envPtr, tokenPtr, interp, i); tokenPtr = TokenAfter(tokenPtr); } @@ -1524,7 +1524,7 @@ TclCompileLreplaceCmd( emptyPrefix = 0; } - if ((idx1 == suffixStart) && (parsePtr->numWords == 4)) { + if ((idx1 == suffixStart) && ((int)parsePtr->numWords == 4)) { /* * This is a "no-op". Example: [lreplace {a b c} 2 0] * We still do a list operation to get list-verification @@ -1634,7 +1634,7 @@ TclCompileLsetCmd( */ /* TODO: Consider support for compiling expanded args. */ - if (parsePtr->numWords < 3) { + if ((int)parsePtr->numWords < 3) { /* * Fail at run time, not in compilation. */ @@ -1658,7 +1658,7 @@ TclCompileLsetCmd( * Push the "index" args and the new element value. */ - for (i=2 ; inumWords ; ++i) { + for (i=2 ; i<(int)parsePtr->numWords ; ++i) { varTokenPtr = TokenAfter(varTokenPtr); CompileWord(envPtr, varTokenPtr, interp, i); } @@ -1669,9 +1669,9 @@ TclCompileLsetCmd( if (localIndex < 0) { if (isScalar) { - tempDepth = parsePtr->numWords - 2; + tempDepth = (int)parsePtr->numWords - 2; } else { - tempDepth = parsePtr->numWords - 1; + tempDepth = (int)parsePtr->numWords - 1; } TclEmitInstInt4( INST_OVER, tempDepth, envPtr); } @@ -1682,9 +1682,9 @@ TclCompileLsetCmd( if (!isScalar) { if (localIndex < 0) { - tempDepth = parsePtr->numWords - 1; + tempDepth = (int)parsePtr->numWords - 1; } else { - tempDepth = parsePtr->numWords - 2; + tempDepth = (int)parsePtr->numWords - 2; } TclEmitInstInt4( INST_OVER, tempDepth, envPtr); } @@ -1711,10 +1711,10 @@ TclCompileLsetCmd( * Emit the correct variety of 'lset' instruction. */ - if (parsePtr->numWords == 4) { + if ((int)parsePtr->numWords == 4) { TclEmitOpcode( INST_LSET_LIST, envPtr); } else { - TclEmitInstInt4( INST_LSET_FLAT, parsePtr->numWords-1, envPtr); + TclEmitInstInt4( INST_LSET_FLAT, (int)parsePtr->numWords-1, envPtr); } /* @@ -1770,7 +1770,7 @@ TclCompileNamespaceCurrentCmd( * Only compile [namespace current] without arguments. */ - if (parsePtr->numWords != 1) { + if ((int)parsePtr->numWords != 1) { return TCL_ERROR; } @@ -1793,7 +1793,7 @@ TclCompileNamespaceCodeCmd( DefineLineInformation; /* TIP #280 */ Tcl_Token *tokenPtr; - if (parsePtr->numWords != 2) { + if ((int)parsePtr->numWords != 2) { return TCL_ERROR; } tokenPtr = TokenAfter(parsePtr->tokenPtr); @@ -1842,7 +1842,7 @@ TclCompileNamespaceOriginCmd( DefineLineInformation; /* TIP #280 */ Tcl_Token *tokenPtr; - if (parsePtr->numWords != 2) { + if ((int)parsePtr->numWords != 2) { return TCL_ERROR; } tokenPtr = TokenAfter(parsePtr->tokenPtr); @@ -1864,7 +1864,7 @@ TclCompileNamespaceQualifiersCmd( Tcl_Token *tokenPtr = TokenAfter(parsePtr->tokenPtr); int off; - if (parsePtr->numWords != 2) { + if ((int)parsePtr->numWords != 2) { return TCL_ERROR; } @@ -1899,7 +1899,7 @@ TclCompileNamespaceTailCmd( Tcl_Token *tokenPtr = TokenAfter(parsePtr->tokenPtr); JumpFixup jumpFixup; - if (parsePtr->numWords != 2) { + if ((int)parsePtr->numWords != 2) { return TCL_ERROR; } @@ -1943,7 +1943,7 @@ TclCompileNamespaceUpvarCmd( * Only compile [namespace upvar ...]: needs an even number of args, >=4 */ - numWords = parsePtr->numWords; + numWords = (int)parsePtr->numWords; if ((numWords % 2) || (numWords < 4)) { return TCL_ERROR; } @@ -1995,7 +1995,7 @@ TclCompileNamespaceWhichCmd( Tcl_Token *tokenPtr, *opt; int idx; - if (parsePtr->numWords < 2 || parsePtr->numWords > 3) { + if ((int)parsePtr->numWords < 2 || (int)parsePtr->numWords > 3) { return TCL_ERROR; } tokenPtr = TokenAfter(parsePtr->tokenPtr); @@ -2006,7 +2006,7 @@ TclCompileNamespaceWhichCmd( * "-variable" (currently) and anything else is an error. */ - if (parsePtr->numWords == 3) { + if ((int)parsePtr->numWords == 3) { if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { return TCL_ERROR; } @@ -2068,7 +2068,7 @@ TclCompileRegexpCmd( * regexp ?-nocase? ?--? {^staticString$} $var */ - if (parsePtr->numWords < 3) { + if ((int)parsePtr->numWords < 3) { return TCL_ERROR; } @@ -2083,7 +2083,7 @@ TclCompileRegexpCmd( * handling, but satisfies our stricter needs. */ - for (i = 1; i < parsePtr->numWords - 2; i++) { + for (i = 1; i < (int)parsePtr->numWords - 2; i++) { varTokenPtr = TokenAfter(varTokenPtr); if (varTokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { /* @@ -2109,7 +2109,7 @@ TclCompileRegexpCmd( } } - if ((parsePtr->numWords - i) != 2) { + if (((int)parsePtr->numWords - i) != 2) { /* * We don't support capturing to variables. */ @@ -2162,7 +2162,7 @@ TclCompileRegexpCmd( } if (!simple) { - CompileWord(envPtr, varTokenPtr, interp, parsePtr->numWords - 2); + CompileWord(envPtr, varTokenPtr, interp, (int)parsePtr->numWords - 2); } /* @@ -2170,7 +2170,7 @@ TclCompileRegexpCmd( */ varTokenPtr = TokenAfter(varTokenPtr); - CompileWord(envPtr, varTokenPtr, interp, parsePtr->numWords - 1); + CompileWord(envPtr, varTokenPtr, interp, (int)parsePtr->numWords - 1); if (simple) { if (exact && !nocase) { @@ -2247,7 +2247,7 @@ TclCompileRegsubCmd( int exact, quantified, result = TCL_ERROR; size_t len; - if (parsePtr->numWords < 5 || parsePtr->numWords > 6) { + if ((int)parsePtr->numWords < 5 || (int)parsePtr->numWords > 6) { return TCL_ERROR; } @@ -2274,7 +2274,7 @@ TclCompileRegsubCmd( } if (TclGetString(patternObj)[0] == '-') { if (strcmp(TclGetString(patternObj), "--") != 0 - || parsePtr->numWords == 5) { + || (int)parsePtr->numWords == 5) { goto done; } tokenPtr = TokenAfter(tokenPtr); @@ -2283,7 +2283,7 @@ TclCompileRegsubCmd( if (!TclWordKnownAtCompileTime(tokenPtr, patternObj)) { goto done; } - } else if (parsePtr->numWords == 6) { + } else if ((int)parsePtr->numWords == 6) { goto done; } @@ -2354,7 +2354,7 @@ TclCompileRegsubCmd( PushLiteral(envPtr, bytes, len); bytes = Tcl_GetStringFromObj(replacementObj, &len); PushLiteral(envPtr, bytes, len); - CompileWord(envPtr, stringTokenPtr, interp, parsePtr->numWords - 2); + CompileWord(envPtr, stringTokenPtr, interp, (int)parsePtr->numWords - 2); TclEmitOpcode( INST_STR_MAP, envPtr); done: @@ -2401,7 +2401,7 @@ TclCompileReturnCmd( */ int level, code, objc, status = TCL_OK; size_t size; - int numWords = parsePtr->numWords; + int numWords = (int)parsePtr->numWords; int explicitResult = (0 == (numWords % 2)); int numOptionWords = numWords - 1 - explicitResult; Tcl_Obj *returnOpts, **objv; @@ -2655,7 +2655,7 @@ TclCompileUpvarCmd( return TCL_ERROR; } - numWords = parsePtr->numWords; + numWords = (int)parsePtr->numWords; if (numWords < 3) { return TCL_ERROR; } @@ -2756,7 +2756,7 @@ TclCompileVariableCmd( Tcl_Token *varTokenPtr, *valueTokenPtr; int localIndex, numWords, i; - numWords = parsePtr->numWords; + numWords = (int)parsePtr->numWords; if (numWords < 2) { return TCL_ERROR; } @@ -2930,11 +2930,11 @@ TclCompileObjectNextCmd( Tcl_Token *tokenPtr = parsePtr->tokenPtr; int i; - if (parsePtr->numWords > 255) { + if ((int)parsePtr->numWords > 255) { return TCL_ERROR; } - for (i=0 ; inumWords ; i++) { + for (i=0 ; i<(int)parsePtr->numWords ; i++) { CompileWord(envPtr, tokenPtr, interp, i); tokenPtr = TokenAfter(tokenPtr); } @@ -2954,11 +2954,11 @@ TclCompileObjectNextToCmd( Tcl_Token *tokenPtr = parsePtr->tokenPtr; int i; - if (parsePtr->numWords < 2 || parsePtr->numWords > 255) { + if ((int)parsePtr->numWords < 2 || (int)parsePtr->numWords > 255) { return TCL_ERROR; } - for (i=0 ; inumWords ; i++) { + for (i=0 ; i<(int)parsePtr->numWords ; i++) { CompileWord(envPtr, tokenPtr, interp, i); tokenPtr = TokenAfter(tokenPtr); } @@ -2980,9 +2980,9 @@ TclCompileObjectSelfCmd( * bytecoding is at all reasonable. */ - if (parsePtr->numWords == 1) { + if ((int)parsePtr->numWords == 1) { goto compileSelfObject; - } else if (parsePtr->numWords == 2) { + } else if ((int)parsePtr->numWords == 2) { Tcl_Token *tokenPtr = TokenAfter(parsePtr->tokenPtr), *subcmd; if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD || tokenPtr[1].size==0) { diff --git a/generic/tclCompCmdsSZ.c b/generic/tclCompCmdsSZ.c index d1b33c8..70c1a1d 100644 --- a/generic/tclCompCmdsSZ.c +++ b/generic/tclCompCmdsSZ.c @@ -133,7 +133,7 @@ TclCompileSetCmd( Tcl_Token *varTokenPtr, *valueTokenPtr; int isAssignment, isScalar, localIndex, numWords; - numWords = parsePtr->numWords; + numWords = (int)parsePtr->numWords; if ((numWords != 2) && (numWords != 3)) { return TCL_ERROR; } @@ -223,7 +223,7 @@ TclCompileStringCatCmd( CompileEnv *envPtr) /* Holds resulting instructions. */ { DefineLineInformation; /* TIP #280 */ - int i, numWords = parsePtr->numWords, numArgs; + int i, numWords = (int)parsePtr->numWords, numArgs; Tcl_Token *wordTokenPtr; Tcl_Obj *obj, *folded; @@ -300,7 +300,7 @@ TclCompileStringCmpCmd( * We don't support any flags; the bytecode isn't that sophisticated. */ - if (parsePtr->numWords != 3) { + if ((int)parsePtr->numWords != 3) { return TCL_ERROR; } @@ -331,7 +331,7 @@ TclCompileStringEqualCmd( * We don't support any flags; the bytecode isn't that sophisticated. */ - if (parsePtr->numWords != 3) { + if ((int)parsePtr->numWords != 3) { return TCL_ERROR; } @@ -362,7 +362,7 @@ TclCompileStringFirstCmd( * We don't support any flags; the bytecode isn't that sophisticated. */ - if (parsePtr->numWords != 3) { + if ((int)parsePtr->numWords != 3) { return TCL_ERROR; } @@ -393,7 +393,7 @@ TclCompileStringLastCmd( * We don't support any flags; the bytecode isn't that sophisticated. */ - if (parsePtr->numWords != 3) { + if ((int)parsePtr->numWords != 3) { return TCL_ERROR; } @@ -420,7 +420,7 @@ TclCompileStringIndexCmd( DefineLineInformation; /* TIP #280 */ Tcl_Token *tokenPtr; - if (parsePtr->numWords != 3) { + if ((int)parsePtr->numWords != 3) { return TCL_ERROR; } @@ -448,7 +448,7 @@ TclCompileStringInsertCmd( Tcl_Token *tokenPtr; int idx; - if (parsePtr->numWords != 4) { + if ((int)parsePtr->numWords != 4) { return TCL_ERROR; } @@ -523,7 +523,7 @@ TclCompileStringIsCmd( InstStringClassType strClassType; Tcl_Obj *isClass; - if (parsePtr->numWords < 3 || parsePtr->numWords > 6) { + if ((int)parsePtr->numWords < 3 || (int)parsePtr->numWords > 6) { return TCL_ERROR; } TclNewObj(isClass); @@ -549,12 +549,12 @@ TclCompileStringIsCmd( * way to have more than 4 arguments. */ - if (parsePtr->numWords != 3 && parsePtr->numWords != 4) { + if ((int)parsePtr->numWords != 3 && (int)parsePtr->numWords != 4) { return TCL_ERROR; } tokenPtr = TokenAfter(tokenPtr); - if (parsePtr->numWords == 3) { + if ((int)parsePtr->numWords == 3) { allowEmpty = 1; } else { if (!GotLiteral(tokenPtr, "-strict")) { @@ -573,7 +573,7 @@ TclCompileStringIsCmd( * 5. Lists */ - CompileWord(envPtr, tokenPtr, interp, parsePtr->numWords-1); + CompileWord(envPtr, tokenPtr, interp, (int)parsePtr->numWords-1); switch ((enum isClassesEnum) t) { case STR_IS_ALNUM: @@ -798,7 +798,7 @@ TclCompileStringMatchCmd( int i, exactMatch = 0, nocase = 0; const char *str; - if (parsePtr->numWords < 3 || parsePtr->numWords > 4) { + if ((int)parsePtr->numWords < 3 || (int)parsePtr->numWords > 4) { return TCL_ERROR; } tokenPtr = TokenAfter(parsePtr->tokenPtr); @@ -807,7 +807,7 @@ TclCompileStringMatchCmd( * Check if we have a -nocase flag. */ - if (parsePtr->numWords == 4) { + if ((int)parsePtr->numWords == 4) { if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { return TclCompileBasic3ArgCmd(interp, parsePtr, cmdPtr, envPtr); } @@ -877,7 +877,7 @@ TclCompileStringLenCmd( Tcl_Token *tokenPtr; Tcl_Obj *objPtr; - if (parsePtr->numWords != 2) { + if ((int)parsePtr->numWords != 2) { return TCL_ERROR; } @@ -929,7 +929,7 @@ TclCompileStringMapCmd( * thing to map). */ - if (parsePtr->numWords != 3) { + if ((int)parsePtr->numWords != 3) { return TCL_ERROR; } mapTokenPtr = TokenAfter(parsePtr->tokenPtr); @@ -979,7 +979,7 @@ TclCompileStringRangeCmd( Tcl_Token *stringTokenPtr, *fromTokenPtr, *toTokenPtr; int idx1, idx2; - if (parsePtr->numWords != 4) { + if ((int)parsePtr->numWords != 4) { return TCL_ERROR; } stringTokenPtr = TokenAfter(parsePtr->tokenPtr); @@ -1054,7 +1054,7 @@ TclCompileStringReplaceCmd( Tcl_Token *tokenPtr, *valueTokenPtr; int first, last; - if (parsePtr->numWords < 4 || parsePtr->numWords > 5) { + if ((int)parsePtr->numWords < 4 || (int)parsePtr->numWords > 5) { return TCL_ERROR; } @@ -1119,7 +1119,7 @@ TclCompileStringReplaceCmd( */ || ((first >= (int)TCL_INDEX_START) && (last >= (int)TCL_INDEX_START) && (last < first))) { /* Know (last < first) */ - if (parsePtr->numWords == 5) { + if ((int)parsePtr->numWords == 5) { tokenPtr = TokenAfter(tokenPtr); CompileWord(envPtr, tokenPtr, interp, 4); OP( POP); /* Pop newString */ @@ -1128,7 +1128,7 @@ TclCompileStringReplaceCmd( return TCL_OK; } - if (parsePtr->numWords == 5) { + if ((int)parsePtr->numWords == 5) { /* * When we have a string replacement, we have to take care about * not replacing empty substrings that [string replace] promises @@ -1230,7 +1230,7 @@ TclCompileStringReplaceCmd( CompileWord(envPtr, tokenPtr, interp, 2); tokenPtr = TokenAfter(tokenPtr); CompileWord(envPtr, tokenPtr, interp, 3); - if (parsePtr->numWords == 5) { + if ((int)parsePtr->numWords == 5) { tokenPtr = TokenAfter(tokenPtr); CompileWord(envPtr, tokenPtr, interp, 4); } else { @@ -1251,13 +1251,13 @@ TclCompileStringTrimLCmd( DefineLineInformation; /* TIP #280 */ Tcl_Token *tokenPtr; - if (parsePtr->numWords != 2 && parsePtr->numWords != 3) { + if ((int)parsePtr->numWords != 2 && (int)parsePtr->numWords != 3) { return TCL_ERROR; } tokenPtr = TokenAfter(parsePtr->tokenPtr); CompileWord(envPtr, tokenPtr, interp, 1); - if (parsePtr->numWords == 3) { + if ((int)parsePtr->numWords == 3) { tokenPtr = TokenAfter(tokenPtr); CompileWord(envPtr, tokenPtr, interp, 2); } else { @@ -1278,13 +1278,13 @@ TclCompileStringTrimRCmd( DefineLineInformation; /* TIP #280 */ Tcl_Token *tokenPtr; - if (parsePtr->numWords != 2 && parsePtr->numWords != 3) { + if ((int)parsePtr->numWords != 2 && (int)parsePtr->numWords != 3) { return TCL_ERROR; } tokenPtr = TokenAfter(parsePtr->tokenPtr); CompileWord(envPtr, tokenPtr, interp, 1); - if (parsePtr->numWords == 3) { + if ((int)parsePtr->numWords == 3) { tokenPtr = TokenAfter(tokenPtr); CompileWord(envPtr, tokenPtr, interp, 2); } else { @@ -1305,13 +1305,13 @@ TclCompileStringTrimCmd( DefineLineInformation; /* TIP #280 */ Tcl_Token *tokenPtr; - if (parsePtr->numWords != 2 && parsePtr->numWords != 3) { + if ((int)parsePtr->numWords != 2 && (int)parsePtr->numWords != 3) { return TCL_ERROR; } tokenPtr = TokenAfter(parsePtr->tokenPtr); CompileWord(envPtr, tokenPtr, interp, 1); - if (parsePtr->numWords == 3) { + if ((int)parsePtr->numWords == 3) { tokenPtr = TokenAfter(tokenPtr); CompileWord(envPtr, tokenPtr, interp, 2); } else { @@ -1333,7 +1333,7 @@ TclCompileStringToUpperCmd( DefineLineInformation; /* TIP #280 */ Tcl_Token *tokenPtr; - if (parsePtr->numWords != 2) { + if ((int)parsePtr->numWords != 2) { return TclCompileBasic1To3ArgCmd(interp, parsePtr, cmdPtr, envPtr); } @@ -1355,7 +1355,7 @@ TclCompileStringToLowerCmd( DefineLineInformation; /* TIP #280 */ Tcl_Token *tokenPtr; - if (parsePtr->numWords != 2) { + if ((int)parsePtr->numWords != 2) { return TclCompileBasic1To3ArgCmd(interp, parsePtr, cmdPtr, envPtr); } @@ -1377,7 +1377,7 @@ TclCompileStringToTitleCmd( DefineLineInformation; /* TIP #280 */ Tcl_Token *tokenPtr; - if (parsePtr->numWords != 2) { + if ((int)parsePtr->numWords != 2) { return TclCompileBasic1To3ArgCmd(interp, parsePtr, cmdPtr, envPtr); } @@ -1452,7 +1452,7 @@ TclCompileSubstCmd( CompileEnv *envPtr) /* Holds resulting instructions. */ { DefineLineInformation; /* TIP #280 */ - int numArgs = parsePtr->numWords - 1; + int numArgs = (int)parsePtr->numWords - 1; int numOpts = numArgs - 1; int objc, flags = TCL_SUBST_ALL; Tcl_Obj **objv/*, *toSubst = NULL*/; @@ -1822,7 +1822,7 @@ TclCompileSwitchCmd( tokenPtr = TokenAfter(parsePtr->tokenPtr); valueIndex = 1; - numWords = parsePtr->numWords-1; + numWords = (int)parsePtr->numWords-1; /* * Check for options. @@ -2664,7 +2664,7 @@ TclCompileTailcallCmd( Tcl_Token *tokenPtr = parsePtr->tokenPtr; int i; - if (parsePtr->numWords < 2 || parsePtr->numWords > 256 + if ((int)parsePtr->numWords < 2 || (int)parsePtr->numWords > 256 || envPtr->procPtr == NULL) { return TCL_ERROR; } @@ -2672,11 +2672,11 @@ TclCompileTailcallCmd( /* make room for the nsObjPtr */ /* TODO: Doesn't this have to be a known value? */ CompileWord(envPtr, tokenPtr, interp, 0); - for (i=1 ; inumWords ; i++) { + for (i=1 ; i<(int)parsePtr->numWords ; i++) { tokenPtr = TokenAfter(tokenPtr); CompileWord(envPtr, tokenPtr, interp, i); } - TclEmitInstInt1( INST_TAILCALL, parsePtr->numWords, envPtr); + TclEmitInstInt1( INST_TAILCALL, (int)parsePtr->numWords, envPtr); return TCL_OK; } @@ -2707,7 +2707,7 @@ TclCompileThrowCmd( CompileEnv *envPtr) /* Holds resulting instructions. */ { DefineLineInformation; /* TIP #280 */ - int numWords = parsePtr->numWords; + int numWords = (int)parsePtr->numWords; Tcl_Token *codeToken, *msgToken; Tcl_Obj *objPtr; int codeKnown, codeIsList, codeIsValid; @@ -2810,7 +2810,7 @@ TclCompileTryCmd( TCL_UNUSED(Command *), CompileEnv *envPtr) /* Holds resulting instructions. */ { - int numWords = parsePtr->numWords, numHandlers, result = TCL_ERROR; + int numWords = (int)parsePtr->numWords, numHandlers, result = TCL_ERROR; Tcl_Token *bodyToken, *finallyToken, *tokenPtr; Tcl_Token **handlerTokens = NULL; Tcl_Obj **matchClauses = NULL; @@ -3633,7 +3633,7 @@ TclCompileUnsetCmd( * push/rotate. [Bug 3970f54c4e] */ - for (i=1,varTokenPtr=parsePtr->tokenPtr ; inumWords ; i++) { + for (i=1,varTokenPtr=parsePtr->tokenPtr ; i<(int)parsePtr->numWords ; i++) { Tcl_Obj *leadingWord; TclNewObj(leadingWord); @@ -3697,7 +3697,7 @@ TclCompileUnsetCmd( for (i=0; inumWords ; i++) { + for (i=1+haveFlags ; i<(int)parsePtr->numWords ; i++) { /* * Decide if we can use a frame slot for the var/array name or if we * need to emit code to compute and push the name at runtime. We use a @@ -3767,7 +3767,7 @@ TclCompileWhileCmd( * infinite loop. */ Tcl_Obj *boolObj; - if (parsePtr->numWords != 3) { + if ((int)parsePtr->numWords != 3) { return TCL_ERROR; } @@ -3936,11 +3936,11 @@ TclCompileYieldCmd( TCL_UNUSED(Command *), CompileEnv *envPtr) /* Holds resulting instructions. */ { - if (parsePtr->numWords < 1 || parsePtr->numWords > 2) { + if ((int)parsePtr->numWords < 1 || (int)parsePtr->numWords > 2) { return TCL_ERROR; } - if (parsePtr->numWords == 1) { + if ((int)parsePtr->numWords == 1) { PUSH(""); } else { DefineLineInformation; /* TIP #280 */ @@ -3982,12 +3982,12 @@ TclCompileYieldToCmd( Tcl_Token *tokenPtr = TokenAfter(parsePtr->tokenPtr); int i; - if (parsePtr->numWords < 2) { + if ((int)parsePtr->numWords < 2) { return TCL_ERROR; } OP( NS_CURRENT); - for (i = 1 ; i < parsePtr->numWords ; i++) { + for (i = 1 ; i < (int)parsePtr->numWords ; i++) { CompileWord(envPtr, tokenPtr, interp, i); tokenPtr = TokenAfter(tokenPtr); } @@ -4024,7 +4024,7 @@ CompileUnaryOpCmd( DefineLineInformation; /* TIP #280 */ Tcl_Token *tokenPtr; - if (parsePtr->numWords != 2) { + if ((int)parsePtr->numWords != 2) { return TCL_ERROR; } tokenPtr = TokenAfter(parsePtr->tokenPtr); @@ -4068,11 +4068,11 @@ CompileAssociativeBinaryOpCmd( int words; /* TODO: Consider support for compiling expanded args. */ - for (words=1 ; wordsnumWords ; words++) { + for (words=1 ; words<(int)parsePtr->numWords ; words++) { tokenPtr = TokenAfter(tokenPtr); CompileWord(envPtr, tokenPtr, interp, words); } - if (parsePtr->numWords <= 2) { + if ((int)parsePtr->numWords <= 2) { PushLiteral(envPtr, identity, -1); words++; } @@ -4116,7 +4116,7 @@ CompileStrictlyBinaryOpCmd( int instruction, CompileEnv *envPtr) { - if (parsePtr->numWords != 3) { + if ((int)parsePtr->numWords != 3) { return TCL_ERROR; } return CompileAssociativeBinaryOpCmd(interp, parsePtr, @@ -4152,9 +4152,9 @@ CompileComparisonOpCmd( Tcl_Token *tokenPtr; /* TODO: Consider support for compiling expanded args. */ - if (parsePtr->numWords < 3) { + if ((int)parsePtr->numWords < 3) { PUSH("1"); - } else if (parsePtr->numWords == 3) { + } else if ((int)parsePtr->numWords == 3) { tokenPtr = TokenAfter(parsePtr->tokenPtr); CompileWord(envPtr, tokenPtr, interp, 1); tokenPtr = TokenAfter(tokenPtr); @@ -4176,11 +4176,11 @@ CompileComparisonOpCmd( CompileWord(envPtr, tokenPtr, interp, 2); STORE(tmpIndex); TclEmitOpcode(instruction, envPtr); - for (words=3 ; wordsnumWords ;) { + for (words=3 ; words<(int)parsePtr->numWords ;) { LOAD(tmpIndex); tokenPtr = TokenAfter(tokenPtr); CompileWord(envPtr, tokenPtr, interp, words); - if (++words < parsePtr->numWords) { + if (++words < (int)parsePtr->numWords) { STORE(tmpIndex); } TclEmitOpcode(instruction, envPtr); @@ -4311,11 +4311,11 @@ TclCompilePowOpCmd( * one with right associativity. */ - for (words=1 ; wordsnumWords ; words++) { + for (words=1 ; words<(int)parsePtr->numWords ; words++) { tokenPtr = TokenAfter(tokenPtr); CompileWord(envPtr, tokenPtr, interp, words); } - if (parsePtr->numWords <= 2) { + if ((int)parsePtr->numWords <= 2) { PUSH("1"); words++; } @@ -4508,14 +4508,14 @@ TclCompileMinusOpCmd( int words; /* TODO: Consider support for compiling expanded args. */ - if (parsePtr->numWords == 1) { + if ((int)parsePtr->numWords == 1) { /* * Fallback to direct eval to report syntax error. */ return TCL_ERROR; } - for (words=1 ; wordsnumWords ; words++) { + for (words=1 ; words<(int)parsePtr->numWords ; words++) { tokenPtr = TokenAfter(tokenPtr); CompileWord(envPtr, tokenPtr, interp, words); } @@ -4553,17 +4553,17 @@ TclCompileDivOpCmd( int words; /* TODO: Consider support for compiling expanded args. */ - if (parsePtr->numWords == 1) { + if ((int)parsePtr->numWords == 1) { /* * Fallback to direct eval to report syntax error. */ return TCL_ERROR; } - if (parsePtr->numWords == 2) { + if ((int)parsePtr->numWords == 2) { PUSH("1.0"); } - for (words=1 ; wordsnumWords ; words++) { + for (words=1 ; words<(int)parsePtr->numWords ; words++) { tokenPtr = TokenAfter(tokenPtr); CompileWord(envPtr, tokenPtr, interp, words); } diff --git a/generic/tclCompExpr.c b/generic/tclCompExpr.c index 937e71e..12a88b7 100644 --- a/generic/tclCompExpr.c +++ b/generic/tclCompExpr.c @@ -915,7 +915,7 @@ ParseExpr( */ TclGrowParseTokenArray(parsePtr, 2); - wordIndex = parsePtr->numTokens; + wordIndex = (int)parsePtr->numTokens; tokenPtr = parsePtr->tokenPtr + wordIndex; tokenPtr->type = TCL_TOKEN_WORD; tokenPtr->start = start; @@ -955,7 +955,7 @@ ParseExpr( Tcl_Parse *nestedPtr = (Tcl_Parse *) TclStackAlloc(interp, sizeof(Tcl_Parse)); - tokenPtr = parsePtr->tokenPtr + parsePtr->numTokens; + tokenPtr = parsePtr->tokenPtr + (int)parsePtr->numTokens; tokenPtr->type = TCL_TOKEN_COMMAND; tokenPtr->start = start; tokenPtr->numComponents = 0; @@ -1023,7 +1023,7 @@ ParseExpr( tokenPtr = parsePtr->tokenPtr + wordIndex; tokenPtr->size = scanned; - tokenPtr->numComponents = parsePtr->numTokens - wordIndex - 1; + tokenPtr->numComponents = (int)parsePtr->numTokens - wordIndex - 1; if (!parseOnly && ((lexeme == QUOTED) || (lexeme == BRACED))) { /* * When this expression is destined to be compiled, and a @@ -1560,7 +1560,7 @@ ConvertTreeToTokens( scanned = ParseLexeme(start, numBytes, &lexeme, NULL); TclGrowParseTokenArray(parsePtr, 2); - subExprTokenPtr = parsePtr->tokenPtr + parsePtr->numTokens; + subExprTokenPtr = parsePtr->tokenPtr + (int)parsePtr->numTokens; subExprTokenPtr->type = TCL_TOKEN_SUB_EXPR; subExprTokenPtr->start = start; subExprTokenPtr->size = scanned; @@ -1599,7 +1599,7 @@ ConvertTreeToTokens( */ TclGrowParseTokenArray(parsePtr, toCopy); - subExprTokenPtr = parsePtr->tokenPtr + parsePtr->numTokens; + subExprTokenPtr = parsePtr->tokenPtr + (int)parsePtr->numTokens; memcpy(subExprTokenPtr, tokenPtr, toCopy * sizeof(Tcl_Token)); subExprTokenPtr->type = TCL_TOKEN_SUB_EXPR; @@ -1612,7 +1612,7 @@ ConvertTreeToTokens( */ TclGrowParseTokenArray(parsePtr, toCopy+1); - subExprTokenPtr = parsePtr->tokenPtr + parsePtr->numTokens; + subExprTokenPtr = parsePtr->tokenPtr + (int)parsePtr->numTokens; *subExprTokenPtr = *tokenPtr; subExprTokenPtr->type = TCL_TOKEN_SUB_EXPR; subExprTokenPtr->numComponents++; @@ -1678,7 +1678,7 @@ ConvertTreeToTokens( */ TclGrowParseTokenArray(parsePtr, 2); - subExprTokenIdx = parsePtr->numTokens; + subExprTokenIdx = (int)parsePtr->numTokens; subExprTokenPtr = parsePtr->tokenPtr + subExprTokenIdx; parsePtr->numTokens += 2; subExprTokenPtr->type = TCL_TOKEN_SUB_EXPR; @@ -1806,7 +1806,7 @@ ConvertTreeToTokens( */ subExprTokenPtr->numComponents = - (parsePtr->numTokens - subExprTokenIdx) - 1; + ((int)parsePtr->numTokens - subExprTokenIdx) - 1; /* * Finally, as we return up the tree to our parent, pop the diff --git a/generic/tclCompile.c b/generic/tclCompile.c index cfdbda0..430c2c1 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -2026,7 +2026,7 @@ CompileCommandTokens( int startCodeOffset = envPtr->codeNext - envPtr->codeStart; int depth = TclGetStackDepth(envPtr); - assert (parsePtr->numWords > 0); + assert ((int)parsePtr->numWords > 0); /* Pre-Compile */ @@ -2044,7 +2044,7 @@ CompileCommandTokens( EnterCmdWordData(eclPtr, parsePtr->commandStart - envPtr->source, parsePtr->tokenPtr, parsePtr->commandStart, - parsePtr->numWords, cmdLine, + (int)parsePtr->numWords, cmdLine, clNext, &wlines, envPtr); wlineat = eclPtr->nuloc - 1; @@ -2071,7 +2071,7 @@ CompileCommandTokens( } } if (cmdPtr && !(cmdPtr->flags & CMD_COMPILES_EXPANDED)) { - expand = ExpandRequested(parsePtr->tokenPtr, parsePtr->numWords); + expand = ExpandRequested(parsePtr->tokenPtr, (int)parsePtr->numWords); if (expand) { /* We need to expand, but compileProc cannot. */ cmdPtr = NULL; @@ -2086,15 +2086,15 @@ CompileCommandTokens( if (code == TCL_ERROR) { if (expand < 0) { - expand = ExpandRequested(parsePtr->tokenPtr, parsePtr->numWords); + expand = ExpandRequested(parsePtr->tokenPtr, (int)parsePtr->numWords); } if (expand) { CompileExpanded(interp, parsePtr->tokenPtr, - cmdKnown ? cmdObj : NULL, parsePtr->numWords, envPtr); + cmdKnown ? cmdObj : NULL, (int)parsePtr->numWords, envPtr); } else { TclCompileInvocation(interp, parsePtr->tokenPtr, - cmdKnown ? cmdObj : NULL, parsePtr->numWords, envPtr); + cmdKnown ? cmdObj : NULL, (int)parsePtr->numWords, envPtr); } } @@ -2215,7 +2215,7 @@ TclCompileScript( numBytes -= next - p; p = next; - if (parsePtr->numWords == 0) { + if ((int)parsePtr->numWords == 0) { /* * The "command" parsed has no words. In this case we can skip * the rest of the loop body. With no words, clearly @@ -2229,7 +2229,7 @@ TclCompileScript( * Tcl_FreeParse() to do. * * The advantage of this shortcut is that CompileCommandTokens() - * can be written with an assumption that parsePtr->numWords > 0, with + * can be written with an assumption that (int)parsePtr->numWords > 0, with * the implication the CCT() always generates bytecode. */ continue; @@ -2720,7 +2720,7 @@ TclCompileNoOp( int i; tokenPtr = parsePtr->tokenPtr; - for (i = 1; i < parsePtr->numWords; i++) { + for (i = 1; i < (int)parsePtr->numWords; i++) { tokenPtr = tokenPtr + tokenPtr->numComponents + 1; if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { diff --git a/generic/tclEnsemble.c b/generic/tclEnsemble.c index 69b20a2..c24a1e6 100644 --- a/generic/tclEnsemble.c +++ b/generic/tclEnsemble.c @@ -2920,7 +2920,7 @@ TclCompileEnsemble( TclNewObj(replaced); Tcl_IncrRefCount(replaced); - if (parsePtr->numWords < depth + 1) { + if ((int)parsePtr->numWords < depth + 1) { goto failed; } if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { @@ -3147,7 +3147,7 @@ TclCompileEnsemble( if (cmdPtr->compileProc == TclCompileEnsemble) { tokenPtr = TokenAfter(tokenPtr); - if (parsePtr->numWords < depth + 1 + if ((int)parsePtr->numWords < depth + 1 || tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { /* * Too hard because the user has done something unpleasant like @@ -3393,7 +3393,7 @@ CompileToInvokedCommand( */ TclListObjGetElements(NULL, replacements, &numWords, &words); - for (i = 0, tokPtr = parsePtr->tokenPtr; i < parsePtr->numWords; + for (i = 0, tokPtr = parsePtr->tokenPtr; i < (int)parsePtr->numWords; i++, tokPtr = TokenAfter(tokPtr)) { if (i > 0 && (size_t)i <= numWords) { bytes = Tcl_GetStringFromObj(words[i-1], &length); @@ -3438,7 +3438,7 @@ CompileToInvokedCommand( * Do the replacing dispatch. */ - TclEmitInvoke(envPtr, INST_INVOKE_REPLACE, parsePtr->numWords,numWords+1); + TclEmitInvoke(envPtr, INST_INVOKE_REPLACE, (int)parsePtr->numWords,numWords+1); } /* @@ -3468,7 +3468,7 @@ CompileBasicNArgCommand( Tcl_IncrRefCount(objPtr); Tcl_GetCommandFullName(interp, (Tcl_Command) cmdPtr, objPtr); TclCompileInvocation(interp, parsePtr->tokenPtr, objPtr, - parsePtr->numWords, envPtr); + (int)parsePtr->numWords, envPtr); Tcl_DecrRefCount(objPtr); return TCL_OK; } @@ -3488,7 +3488,7 @@ TclCompileBasic0ArgCmd( * which is the only code that sees the shenanigans of ensemble dispatch. */ - if (parsePtr->numWords != 1) { + if ((int)parsePtr->numWords != 1) { return TCL_ERROR; } @@ -3510,7 +3510,7 @@ TclCompileBasic1ArgCmd( * which is the only code that sees the shenanigans of ensemble dispatch. */ - if (parsePtr->numWords != 2) { + if ((int)parsePtr->numWords != 2) { return TCL_ERROR; } @@ -3532,7 +3532,7 @@ TclCompileBasic2ArgCmd( * which is the only code that sees the shenanigans of ensemble dispatch. */ - if (parsePtr->numWords != 3) { + if ((int)parsePtr->numWords != 3) { return TCL_ERROR; } @@ -3554,7 +3554,7 @@ TclCompileBasic3ArgCmd( * which is the only code that sees the shenanigans of ensemble dispatch. */ - if (parsePtr->numWords != 4) { + if ((int)parsePtr->numWords != 4) { return TCL_ERROR; } @@ -3576,7 +3576,7 @@ TclCompileBasic0Or1ArgCmd( * which is the only code that sees the shenanigans of ensemble dispatch. */ - if (parsePtr->numWords != 1 && parsePtr->numWords != 2) { + if ((int)parsePtr->numWords != 1 && (int)parsePtr->numWords != 2) { return TCL_ERROR; } @@ -3598,7 +3598,7 @@ TclCompileBasic1Or2ArgCmd( * which is the only code that sees the shenanigans of ensemble dispatch. */ - if (parsePtr->numWords != 2 && parsePtr->numWords != 3) { + if ((int)parsePtr->numWords != 2 && (int)parsePtr->numWords != 3) { return TCL_ERROR; } @@ -3620,7 +3620,7 @@ TclCompileBasic2Or3ArgCmd( * which is the only code that sees the shenanigans of ensemble dispatch. */ - if (parsePtr->numWords != 3 && parsePtr->numWords != 4) { + if ((int)parsePtr->numWords != 3 && (int)parsePtr->numWords != 4) { return TCL_ERROR; } @@ -3642,7 +3642,7 @@ TclCompileBasic0To2ArgCmd( * which is the only code that sees the shenanigans of ensemble dispatch. */ - if (parsePtr->numWords < 1 || parsePtr->numWords > 3) { + if ((int)parsePtr->numWords < 1 || (int)parsePtr->numWords > 3) { return TCL_ERROR; } @@ -3664,7 +3664,7 @@ TclCompileBasic1To3ArgCmd( * which is the only code that sees the shenanigans of ensemble dispatch. */ - if (parsePtr->numWords < 2 || parsePtr->numWords > 4) { + if ((int)parsePtr->numWords < 2 || (int)parsePtr->numWords > 4) { return TCL_ERROR; } @@ -3686,7 +3686,7 @@ TclCompileBasicMin0ArgCmd( * which is the only code that sees the shenanigans of ensemble dispatch. */ - if (parsePtr->numWords < 1) { + if ((int)parsePtr->numWords < 1) { return TCL_ERROR; } @@ -3708,7 +3708,7 @@ TclCompileBasicMin1ArgCmd( * which is the only code that sees the shenanigans of ensemble dispatch. */ - if (parsePtr->numWords < 2) { + if ((int)parsePtr->numWords < 2) { return TCL_ERROR; } @@ -3730,7 +3730,7 @@ TclCompileBasicMin2ArgCmd( * which is the only code that sees the shenanigans of ensemble dispatch. */ - if (parsePtr->numWords < 3) { + if ((int)parsePtr->numWords < 3) { return TCL_ERROR; } diff --git a/generic/tclExecute.c b/generic/tclExecute.c index 5229f65..91796b3 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -2125,7 +2125,7 @@ TEBCresume( * instruction. */ - TRACE_WITH_OBJ(("%u => ... after \"%.20s\": TCL_OK, result=", + TRACE_WITH_OBJ(("%" TCL_Z_MODIFIER "u => ... after \"%.20s\": TCL_OK, result=", objc, cmdNameBuf), Tcl_GetObjResult(interp)); /* @@ -2845,7 +2845,7 @@ TEBCresume( O2S(objPtr)); } for (i = 0; i < objc; i++) { - if (i < opnd) { + if (i < (size_t)opnd) { fprintf(stdout, "<"); TclPrintObject(stdout, objv[i], 15); fprintf(stdout, ">"); @@ -4643,7 +4643,7 @@ TEBCresume( goto gotError; } TclNewIntObj(objResultPtr, length); - TRACE_APPEND(("%d\n", length)); + TRACE_APPEND(("%" TCL_Z_MODIFIER "u\n", length)); NEXT_INST_F(1, 1, 1); case INST_LIST_INDEX: /* lindex with objc == 3 */ @@ -6355,7 +6355,7 @@ TEBCresume( if (TclPtrSetVarIdx(interp, varPtr, NULL, NULL, NULL, valuePtr, TCL_LEAVE_ERR_MSG, varIndex)==NULL){ CACHE_STACK_INFO(); - TRACE_APPEND(("ERROR init. index temp %d: %.30s", + TRACE_APPEND(("ERROR init. index temp %" TCL_Z_MODIFIER "u: %.30s", varIndex, O2S(Tcl_GetObjResult(interp)))); goto gotError; } @@ -6402,7 +6402,7 @@ TEBCresume( tmpPtr = OBJ_AT_DEPTH(1); infoPtr = (ForeachInfo *)tmpPtr->internalRep.twoPtrValue.ptr1; numLists = infoPtr->numLists; - TRACE_APPEND(("=> appending to list at depth %d\n", 3 + numLists)); + TRACE_APPEND(("=> appending to list at depth %" TCL_Z_MODIFIER "u\n", 3 + numLists)); objPtr = OBJ_AT_DEPTH(3 + numLists); Tcl_ListObjAppendElement(NULL, objPtr, OBJ_AT_TOS); diff --git a/generic/tclInt.h b/generic/tclInt.h index af2a6ba..c6b7180 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -4590,31 +4590,20 @@ MODULE_SCOPE const TclFileAttrProcs tclpFileAttrProcs[]; #define TCL_MIN_TOKEN_GROWTH TCL_MIN_GROWTH/sizeof(Tcl_Token) #endif -#define TCL_MAX_TOKENS (int)(UINT_MAX / sizeof(Tcl_Token)) #define TclGrowTokenArray(tokenPtr, used, available, append, staticPtr) \ do { \ - int _needed = (used) + (append); \ - if (_needed > TCL_MAX_TOKENS) { \ - Tcl_Panic("max # of tokens for a Tcl parse (%d) exceeded", \ - TCL_MAX_TOKENS); \ - } \ + size_t _needed = (used) + (append); \ if (_needed > (available)) { \ - int allocated = 2 * _needed; \ + size_t allocated = 2 * _needed; \ Tcl_Token *oldPtr = (tokenPtr); \ Tcl_Token *newPtr; \ if (oldPtr == (staticPtr)) { \ oldPtr = NULL; \ } \ - if (allocated > TCL_MAX_TOKENS) { \ - allocated = TCL_MAX_TOKENS; \ - } \ newPtr = (Tcl_Token *)Tcl_AttemptRealloc((char *) oldPtr, \ allocated * sizeof(Tcl_Token)); \ if (newPtr == NULL) { \ allocated = _needed + (append) + TCL_MIN_TOKEN_GROWTH; \ - if (allocated > TCL_MAX_TOKENS) { \ - allocated = TCL_MAX_TOKENS; \ - } \ newPtr = (Tcl_Token *)Tcl_Realloc((char *) oldPtr, \ allocated * sizeof(Tcl_Token)); \ } \ diff --git a/generic/tclParse.c b/generic/tclParse.c index 614401f..52c11d4 100644 --- a/generic/tclParse.c +++ b/generic/tclParse.c @@ -303,7 +303,7 @@ Tcl_ParseCommand( */ TclGrowParseTokenArray(parsePtr, 1); - wordIndex = parsePtr->numTokens; + wordIndex = (int)parsePtr->numTokens; tokenPtr = &parsePtr->tokenPtr[wordIndex]; tokenPtr->type = TCL_TOKEN_WORD; @@ -344,7 +344,7 @@ Tcl_ParseCommand( expPtr = &parsePtr->tokenPtr[expIdx]; if ((0 == expandWord) /* Haven't seen prefix already */ - && (1 == parsePtr->numTokens - expIdx) + && (1 == (int)parsePtr->numTokens - expIdx) /* Only one token */ && (((1 == expPtr->size) /* Same length as prefix */ @@ -379,7 +379,7 @@ Tcl_ParseCommand( tokenPtr = &parsePtr->tokenPtr[wordIndex]; tokenPtr->size = src - tokenPtr->start; - tokenPtr->numComponents = parsePtr->numTokens - (wordIndex + 1); + tokenPtr->numComponents = (int)parsePtr->numTokens - (wordIndex + 1); if (expandWord) { size_t i; int isLiteral = 1; @@ -471,7 +471,7 @@ Tcl_ParseCommand( const char *listStart; int growthNeeded = wordIndex + 2*elemCount - - parsePtr->numTokens; + - (int)parsePtr->numTokens; parsePtr->numWords += elemCount - 1; if (growthNeeded > 0) { @@ -1082,10 +1082,10 @@ ParseTokens( * for the parsed variable name. */ - originalTokens = parsePtr->numTokens; + originalTokens = (int)parsePtr->numTokens; while (numBytes && !((type = CHAR_TYPE(*src)) & mask)) { TclGrowParseTokenArray(parsePtr, 1); - tokenPtr = &parsePtr->tokenPtr[parsePtr->numTokens]; + tokenPtr = &parsePtr->tokenPtr[(int)parsePtr->numTokens]; tokenPtr->start = src; tokenPtr->numComponents = 0; @@ -1119,7 +1119,7 @@ ParseTokens( * the dirty work of parsing the name. */ - varToken = parsePtr->numTokens; + varToken = (int)parsePtr->numTokens; if (Tcl_ParseVarName(parsePtr->interp, src, numBytes, parsePtr, 1) != TCL_OK) { return TCL_ERROR; @@ -1230,7 +1230,7 @@ ParseTokens( */ if (mask & TYPE_SPACE) { - if (parsePtr->numTokens == originalTokens) { + if ((int)parsePtr->numTokens == originalTokens) { goto finishToken; } break; @@ -1251,14 +1251,14 @@ ParseTokens( Tcl_Panic("ParseTokens encountered unknown character"); } } - if (parsePtr->numTokens == originalTokens) { + if ((int)parsePtr->numTokens == originalTokens) { /* * There was nothing in this range of text. Add an empty token for the * empty range, so that there is always at least one token added. */ TclGrowParseTokenArray(parsePtr, 1); - tokenPtr = &parsePtr->tokenPtr[parsePtr->numTokens]; + tokenPtr = &parsePtr->tokenPtr[(int)parsePtr->numTokens]; tokenPtr->start = src; tokenPtr->numComponents = 0; @@ -1365,10 +1365,10 @@ Tcl_ParseVarName( src = start; TclGrowParseTokenArray(parsePtr, 2); - tokenPtr = &parsePtr->tokenPtr[parsePtr->numTokens]; + tokenPtr = &parsePtr->tokenPtr[(int)parsePtr->numTokens]; tokenPtr->type = TCL_TOKEN_VARIABLE; tokenPtr->start = src; - varIndex = parsePtr->numTokens; + varIndex = (int)parsePtr->numTokens; parsePtr->numTokens++; tokenPtr++; src++; @@ -1480,7 +1480,7 @@ Tcl_ParseVarName( } tokenPtr = &parsePtr->tokenPtr[varIndex]; tokenPtr->size = src - tokenPtr->start; - tokenPtr->numComponents = parsePtr->numTokens - (varIndex + 1); + tokenPtr->numComponents = (int)parsePtr->numTokens - (varIndex + 1); return TCL_OK; /* @@ -1543,7 +1543,7 @@ Tcl_ParseVar( if (termPtr != NULL) { *termPtr = start + parsePtr->tokenPtr->size; } - if (parsePtr->numTokens == 1) { + if ((int)parsePtr->numTokens == 1) { /* * There isn't a variable name after all: the $ is just a $. */ @@ -1552,7 +1552,7 @@ Tcl_ParseVar( return "$"; } - code = TclSubstTokens(interp, parsePtr->tokenPtr, parsePtr->numTokens, + code = TclSubstTokens(interp, parsePtr->tokenPtr, (int)parsePtr->numTokens, NULL, 1, NULL, NULL); Tcl_FreeParse(parsePtr); TclStackFree(interp, parsePtr); @@ -1641,7 +1641,7 @@ Tcl_ParseBraces( } src = start; - startIndex = parsePtr->numTokens; + startIndex = (int)parsePtr->numTokens; TclGrowParseTokenArray(parsePtr, 1); tokenPtr = &parsePtr->tokenPtr[startIndex]; @@ -1679,7 +1679,7 @@ Tcl_ParseBraces( */ if ((src != tokenPtr->start) - || (parsePtr->numTokens == startIndex)) { + || ((int)parsePtr->numTokens == startIndex)) { tokenPtr->size = (src - tokenPtr->start); parsePtr->numTokens++; } @@ -1707,7 +1707,7 @@ Tcl_ParseBraces( parsePtr->numTokens++; } TclGrowParseTokenArray(parsePtr, 2); - tokenPtr = &parsePtr->tokenPtr[parsePtr->numTokens]; + tokenPtr = &parsePtr->tokenPtr[(int)parsePtr->numTokens]; tokenPtr->type = TCL_TOKEN_BS; tokenPtr->start = src; tokenPtr->size = length; @@ -1978,7 +1978,7 @@ TclSubstParse( */ Tcl_Token *varTokenPtr = - parsePtr->tokenPtr + parsePtr->numTokens - 2; + parsePtr->tokenPtr + (int)parsePtr->numTokens - 2; if (varTokenPtr->type != TCL_TOKEN_VARIABLE) { Tcl_Panic("TclSubstParse: programming error"); @@ -2048,7 +2048,7 @@ TclSubstParse( */ TclGrowParseTokenArray(parsePtr, 1); - tokenPtr = &(parsePtr->tokenPtr[parsePtr->numTokens]); + tokenPtr = &(parsePtr->tokenPtr[(int)parsePtr->numTokens]); tokenPtr->start = parsePtr->term; tokenPtr->numComponents = 0; tokenPtr->type = TCL_TOKEN_COMMAND; diff --git a/generic/tclTest.c b/generic/tclTest.c index a88062e..7dd6d44 100644 --- a/generic/tclTest.c +++ b/generic/tclTest.c @@ -3519,10 +3519,10 @@ PrintParse( Tcl_Obj *objPtr; const char *typeString; Tcl_Token *tokenPtr; - int i; + size_t i; objPtr = Tcl_GetObjResult(interp); - if (parsePtr->commentSize > 0) { + if (parsePtr->commentSize + 1 > 1) { Tcl_ListObjAppendElement(NULL, objPtr, Tcl_NewStringObj(parsePtr->commentStart, parsePtr->commentSize)); @@ -3532,8 +3532,8 @@ PrintParse( Tcl_ListObjAppendElement(NULL, objPtr, Tcl_NewStringObj(parsePtr->commandStart, parsePtr->commandSize)); Tcl_ListObjAppendElement(NULL, objPtr, - Tcl_NewIntObj(parsePtr->numWords)); - for (i = 0; i < parsePtr->numTokens; i++) { + Tcl_NewWideIntObj(parsePtr->numWords)); + for (i = 0; i < (size_t)parsePtr->numTokens; i++) { tokenPtr = &parsePtr->tokenPtr[i]; switch (tokenPtr->type) { case TCL_TOKEN_EXPAND_WORD: -- cgit v0.12 From 4fae186836bab8e7fef53fb7d4344fa2d344b815 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Sun, 6 Mar 2022 15:40:05 +0000 Subject: Prepare for Tcl_Parse's commentSize/numTokens to become size_t --- generic/tclTest.c | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/generic/tclTest.c b/generic/tclTest.c index f3f2879..7dd6d44 100644 --- a/generic/tclTest.c +++ b/generic/tclTest.c @@ -3519,10 +3519,10 @@ PrintParse( Tcl_Obj *objPtr; const char *typeString; Tcl_Token *tokenPtr; - int i; + size_t i; objPtr = Tcl_GetObjResult(interp); - if (parsePtr->commentSize > 0) { + if (parsePtr->commentSize + 1 > 1) { Tcl_ListObjAppendElement(NULL, objPtr, Tcl_NewStringObj(parsePtr->commentStart, parsePtr->commentSize)); @@ -3532,8 +3532,8 @@ PrintParse( Tcl_ListObjAppendElement(NULL, objPtr, Tcl_NewStringObj(parsePtr->commandStart, parsePtr->commandSize)); Tcl_ListObjAppendElement(NULL, objPtr, - Tcl_NewIntObj(parsePtr->numWords)); - for (i = 0; i < parsePtr->numTokens; i++) { + Tcl_NewWideIntObj(parsePtr->numWords)); + for (i = 0; i < (size_t)parsePtr->numTokens; i++) { tokenPtr = &parsePtr->tokenPtr[i]; switch (tokenPtr->type) { case TCL_TOKEN_EXPAND_WORD: @@ -7909,7 +7909,7 @@ MyCompiledVarFetch( } hPtr = Tcl_CreateHashEntry((Tcl_HashTable *) &iPtr->globalNsPtr->varTable, - (char *) resVarInfo->nameObj, &isNewVar); + resVarInfo->nameObj, &isNewVar); if (hPtr) { var = (Tcl_Var) TclVarHashGetValue(hPtr); } else { -- cgit v0.12 From 4f3ba4b9d477365cac08bf7361c31778a497d9ad Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Sun, 6 Mar 2022 15:49:31 +0000 Subject: Fix [112e7aa36d]: signed integer overflow in Tcl_SetObjLength(), Tcl_AttemptSetObjLength() --- generic/tclStringObj.c | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/generic/tclStringObj.c b/generic/tclStringObj.c index 8f4bfb2..d1e709c 100644 --- a/generic/tclStringObj.c +++ b/generic/tclStringObj.c @@ -956,9 +956,9 @@ Tcl_SetObjLength( * Need to enlarge the buffer. */ if (objPtr->bytes == tclEmptyStringRep) { - objPtr->bytes = (char *)ckalloc(length + 1); + objPtr->bytes = (char *)ckalloc((unsigned int)length + 1U); } else { - objPtr->bytes = (char *)ckrealloc(objPtr->bytes, length + 1); + objPtr->bytes = (char *)ckrealloc(objPtr->bytes, (unsigned int)length + 1U); } stringPtr->allocated = length; } @@ -1062,9 +1062,9 @@ Tcl_AttemptSetObjLength( char *newBytes; if (objPtr->bytes == tclEmptyStringRep) { - newBytes = (char *)attemptckalloc(length + 1); + newBytes = (char *)attemptckalloc((unsigned int)length + 1U); } else { - newBytes = (char *)attemptckrealloc(objPtr->bytes, length + 1); + newBytes = (char *)attemptckrealloc(objPtr->bytes, (unsigned int)length + 1U); } if (newBytes == NULL) { return 0; -- cgit v0.12 From 9a091756bbc40e8d359ac59e4b892c0835f57bae Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Sun, 6 Mar 2022 16:10:06 +0000 Subject: Fix [4789e18fcb]: signed integer overflow during obj-31.6 --- generic/tclUtil.c | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/generic/tclUtil.c b/generic/tclUtil.c index 858163e..8d2347b 100644 --- a/generic/tclUtil.c +++ b/generic/tclUtil.c @@ -3730,7 +3730,8 @@ UpdateStringOfEndOffset( memcpy(buffer, "end", 4); if (objPtr->internalRep.longValue != 0) { buffer[len++] = '-'; - len += TclFormatInt(buffer+len, -(objPtr->internalRep.longValue)); + len += TclFormatInt(buffer+len, + (long)(-(unsigned long)(objPtr->internalRep.longValue))); } objPtr->bytes = (char *)ckalloc(len+1); memcpy(objPtr->bytes, buffer, len+1); @@ -3842,8 +3843,7 @@ SetEndOffsetFromAny( } if (bytes[3] == '-') { - /* TODO: Review overflow concerns here! */ - offset = -offset; + offset = (int)(-(unsigned int)offset); } } else { /* -- cgit v0.12 From 5e2de17d9be405ccfdc6ef6311e9b7a8bff4645b Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 7 Mar 2022 11:25:22 +0000 Subject: Another round of int -> size_t for internal functions --- generic/tclCompCmds.c | 4 ++-- generic/tclCompile.c | 16 ++++++++++------ generic/tclCompile.h | 24 ++++++++++++------------ generic/tclEnsemble.c | 5 +++-- generic/tclProc.c | 3 ++- 5 files changed, 29 insertions(+), 23 deletions(-) diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c index 9791bcc..c9a5724 100644 --- a/generic/tclCompCmds.c +++ b/generic/tclCompCmds.c @@ -3354,7 +3354,7 @@ TclCompileFormatCmd( *---------------------------------------------------------------------- */ -int +size_t TclLocalScalarFromToken( Tcl_Token *tokenPtr, CompileEnv *envPtr) @@ -3368,7 +3368,7 @@ TclLocalScalarFromToken( return index; } -int +size_t TclLocalScalar( const char *bytes, size_t numBytes, diff --git a/generic/tclCompile.c b/generic/tclCompile.c index 430c2c1..9166ec4 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -2382,7 +2382,7 @@ TclCompileTokens( Tcl_Interp *interp, /* Used for error and status reporting. */ Tcl_Token *tokenPtr, /* Pointer to first in an array of tokens to * compile. */ - int count, /* Number of tokens to consider at tokenPtr. + size_t count1, /* Number of tokens to consider at tokenPtr. * Must be at least 1. */ CompileEnv *envPtr) /* Holds the resulting instructions. */ { @@ -2396,6 +2396,7 @@ TclCompileTokens( int isLiteral, maxNumCL, numCL; int *clPosition = NULL; int depth = TclGetStackDepth(envPtr); + int count = count1; /* * if this is actually a literal, handle continuation lines by @@ -2599,10 +2600,12 @@ TclCompileCmdWord( Tcl_Interp *interp, /* Used for error and status reporting. */ Tcl_Token *tokenPtr, /* Pointer to first in an array of tokens for * a command word to compile inline. */ - int count, /* Number of tokens to consider at tokenPtr. + size_t count1, /* Number of tokens to consider at tokenPtr. * Must be at least 1. */ CompileEnv *envPtr) /* Holds the resulting instructions. */ { + int count = count1; + if ((count == 1) && (tokenPtr->type == TCL_TOKEN_TEXT)) { /* * The common case that there is a single text token. Compile it @@ -2648,13 +2651,14 @@ TclCompileExprWords( Tcl_Token *tokenPtr, /* Points to first in an array of word tokens * tokens for the expression to compile * inline. */ - int numWords, /* Number of word tokens starting at tokenPtr. + size_t numWords1, /* Number of word tokens starting at tokenPtr. * Must be at least 1. Each word token * contains one or more subtokens. */ CompileEnv *envPtr) /* Holds the resulting instructions. */ { Tcl_Token *wordPtr; int i, concatItems; + int numWords = numWords1; /* * If the expression is a single word that doesn't require substitutions, @@ -2975,7 +2979,7 @@ TclInitByteCodeObj( *---------------------------------------------------------------------- */ -int +size_t TclFindCompiledLocal( const char *name, /* Points to first character of the name of a * scalar or array variable. If NULL, a @@ -3009,7 +3013,7 @@ TclFindCompiledLocal( size_t len; if (!cachePtr || !name) { - return -1; + return TCL_INDEX_NONE; } varNamePtr = &cachePtr->varName0; @@ -3021,7 +3025,7 @@ TclFindCompiledLocal( } } } - return -1; + return TCL_INDEX_NONE; } if (name != NULL) { diff --git a/generic/tclCompile.h b/generic/tclCompile.h index fce7111..b550c57 100644 --- a/generic/tclCompile.h +++ b/generic/tclCompile.h @@ -1071,17 +1071,17 @@ MODULE_SCOPE ByteCode * TclCompileObj(Tcl_Interp *interp, Tcl_Obj *objPtr, */ MODULE_SCOPE int TclAttemptCompileProc(Tcl_Interp *interp, - Tcl_Parse *parsePtr, int depth, Command *cmdPtr, + Tcl_Parse *parsePtr, size_t depth, Command *cmdPtr, CompileEnv *envPtr); MODULE_SCOPE void TclCleanupStackForBreakContinue(CompileEnv *envPtr, ExceptionAux *auxPtr); MODULE_SCOPE void TclCompileCmdWord(Tcl_Interp *interp, - Tcl_Token *tokenPtr, int count, + Tcl_Token *tokenPtr, size_t count, CompileEnv *envPtr); MODULE_SCOPE void TclCompileExpr(Tcl_Interp *interp, const char *script, size_t numBytes, CompileEnv *envPtr, int optimize); MODULE_SCOPE void TclCompileExprWords(Tcl_Interp *interp, - Tcl_Token *tokenPtr, int numWords, + Tcl_Token *tokenPtr, size_t numWords, CompileEnv *envPtr); MODULE_SCOPE void TclCompileInvocation(Tcl_Interp *interp, Tcl_Token *tokenPtr, Tcl_Obj *cmdObj, size_t numWords, @@ -1092,7 +1092,7 @@ MODULE_SCOPE void TclCompileScript(Tcl_Interp *interp, MODULE_SCOPE void TclCompileSyntaxError(Tcl_Interp *interp, CompileEnv *envPtr); MODULE_SCOPE void TclCompileTokens(Tcl_Interp *interp, - Tcl_Token *tokenPtr, int count, + Tcl_Token *tokenPtr, size_t count, CompileEnv *envPtr); MODULE_SCOPE void TclCompileVarSubst(Tcl_Interp *interp, Tcl_Token *tokenPtr, CompileEnv *envPtr); @@ -1117,7 +1117,7 @@ MODULE_SCOPE void TclExpandJumpFixupArray(JumpFixupArray *fixupArrayPtr); MODULE_SCOPE int TclNRExecuteByteCode(Tcl_Interp *interp, ByteCode *codePtr); MODULE_SCOPE Tcl_Obj * TclFetchLiteral(CompileEnv *envPtr, size_t index); -MODULE_SCOPE int TclFindCompiledLocal(const char *name, size_t nameChars, +MODULE_SCOPE size_t TclFindCompiledLocal(const char *name, size_t nameChars, int create, CompileEnv *envPtr); MODULE_SCOPE int TclFixupForwardJump(CompileEnv *envPtr, JumpFixup *jumpFixupPtr, int jumpDist, @@ -1146,9 +1146,9 @@ MODULE_SCOPE void TclFinalizeLoopExceptionRange(CompileEnv *envPtr, MODULE_SCOPE char * TclLiteralStats(LiteralTable *tablePtr); MODULE_SCOPE int TclLog2(int value); #endif -MODULE_SCOPE int TclLocalScalar(const char *bytes, size_t numBytes, +MODULE_SCOPE size_t TclLocalScalar(const char *bytes, size_t numBytes, CompileEnv *envPtr); -MODULE_SCOPE int TclLocalScalarFromToken(Tcl_Token *tokenPtr, +MODULE_SCOPE size_t TclLocalScalarFromToken(Tcl_Token *tokenPtr, CompileEnv *envPtr); MODULE_SCOPE void TclOptimizeBytecode(void *envPtr); #ifdef TCL_COMPILE_DEBUG @@ -1196,7 +1196,7 @@ MODULE_SCOPE Tcl_Obj *TclGetInnerContext(Tcl_Interp *interp, const unsigned char *pc, Tcl_Obj **tosPtr); MODULE_SCOPE Tcl_Obj *TclNewInstNameObj(unsigned char inst); MODULE_SCOPE int TclPushProcCallFrame(void *clientData, - Tcl_Interp *interp, int objc, + Tcl_Interp *interp, size_t objc, Tcl_Obj *const objv[], int isLambda); @@ -1246,10 +1246,10 @@ MODULE_SCOPE int TclPushProcCallFrame(void *clientData, #define TclCheckStackDepth(depth, envPtr) \ do { \ - int _dd = (depth); \ - if (_dd != (envPtr)->currStackDepth) { \ - Tcl_Panic("bad stack depth computations: is %i, should be %i", \ - (envPtr)->currStackDepth, _dd); \ + size_t _dd = (depth); \ + if (_dd != (size_t)(envPtr)->currStackDepth) { \ + Tcl_Panic("bad stack depth computations: is %" TCL_Z_MODIFIER "u, should be %" TCL_Z_MODIFIER "u", \ + (size_t)(envPtr)->currStackDepth, _dd); \ } \ } while (0) diff --git a/generic/tclEnsemble.c b/generic/tclEnsemble.c index c24a1e6..c0846f8 100644 --- a/generic/tclEnsemble.c +++ b/generic/tclEnsemble.c @@ -2920,7 +2920,7 @@ TclCompileEnsemble( TclNewObj(replaced); Tcl_IncrRefCount(replaced); - if ((int)parsePtr->numWords < depth + 1) { + if ((int)parsePtr->numWords <= depth) { goto failed; } if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { @@ -3242,7 +3242,7 @@ int TclAttemptCompileProc( Tcl_Interp *interp, Tcl_Parse *parsePtr, - int depth, + size_t depth1, Command *cmdPtr, CompileEnv *envPtr) /* Holds resulting instructions. */ { @@ -3256,6 +3256,7 @@ TclAttemptCompileProc( #ifdef TCL_COMPILE_DEBUG int savedExceptDepth = envPtr->exceptDepth; #endif + int depth = depth1; if (cmdPtr->compileProc == NULL) { return TCL_ERROR; diff --git a/generic/tclProc.c b/generic/tclProc.c index d3e2ceb..c4c6de1 100644 --- a/generic/tclProc.c +++ b/generic/tclProc.c @@ -1504,7 +1504,7 @@ TclPushProcCallFrame( * interpreted. */ Tcl_Interp *interp,/* Interpreter in which procedure was * invoked. */ - int objc, /* Count of number of arguments to this + size_t objc1, /* Count of number of arguments to this * procedure. */ Tcl_Obj *const objv[], /* Argument value objects. */ int isLambda) /* 1 if this is a call by ApplyObjCmd: it @@ -1515,6 +1515,7 @@ TclPushProcCallFrame( CallFrame *framePtr, **framePtrPtr; int result; ByteCode *codePtr; + int objc = objc1; /* * If necessary (i.e. if we haven't got a suitable compilation already -- cgit v0.12 From 0716c6bd83df14591bdafd41dcd46ef1e78a3a17 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 7 Mar 2022 11:52:05 +0000 Subject: More int -> size_t --- generic/tclCmdMZ.c | 3 ++- generic/tclInt.h | 6 +++--- generic/tclParse.c | 3 ++- generic/tclUtil.c | 7 ++++--- 4 files changed, 11 insertions(+), 8 deletions(-) diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c index 736aadb..c195328 100644 --- a/generic/tclCmdMZ.c +++ b/generic/tclCmdMZ.c @@ -3326,7 +3326,7 @@ TclInitStringCmd( int TclSubstOptions( Tcl_Interp *interp, - int numOpts, + size_t numOpts1, Tcl_Obj *const opts[], int *flagPtr) { @@ -3337,6 +3337,7 @@ TclSubstOptions( SUBST_NOBACKSLASHES, SUBST_NOCOMMANDS, SUBST_NOVARS }; int i, flags = TCL_SUBST_ALL; + int numOpts = numOpts1; for (i = 0; i < numOpts; i++) { int optionIndex; diff --git a/generic/tclInt.h b/generic/tclInt.h index c6b7180..66d9245 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -2896,7 +2896,7 @@ MODULE_SCOPE Tcl_Command TclCreateEnsembleInNs(Tcl_Interp *interp, MODULE_SCOPE void TclDeleteNamespaceVars(Namespace *nsPtr); MODULE_SCOPE void TclDeleteNamespaceChildren(Namespace *nsPtr); MODULE_SCOPE int TclFindDictElement(Tcl_Interp *interp, - const char *dict, int dictLength, + const char *dict, size_t dictLength, const char **elementPtr, const char **nextPtr, size_t *sizePtr, int *literalPtr); /* TIP #280 - Modified token based evaluation, with line information. */ @@ -3178,13 +3178,13 @@ MODULE_SCOPE int TclStringMatchObj(Tcl_Obj *stringObj, MODULE_SCOPE void TclSubstCompile(Tcl_Interp *interp, const char *bytes, size_t numBytes, int flags, int line, struct CompileEnv *envPtr); -MODULE_SCOPE int TclSubstOptions(Tcl_Interp *interp, int numOpts, +MODULE_SCOPE int TclSubstOptions(Tcl_Interp *interp, size_t numOpts, Tcl_Obj *const opts[], int *flagPtr); MODULE_SCOPE void TclSubstParse(Tcl_Interp *interp, const char *bytes, size_t numBytes, int flags, Tcl_Parse *parsePtr, Tcl_InterpState *statePtr); MODULE_SCOPE int TclSubstTokens(Tcl_Interp *interp, Tcl_Token *tokenPtr, - int count, int *tokensLeftPtr, int line, + size_t count, int *tokensLeftPtr, int line, int *clNextOuter, const char *outerScript); MODULE_SCOPE size_t TclTrim(const char *bytes, size_t numBytes, const char *trim, size_t numTrim, size_t *trimRight); diff --git a/generic/tclParse.c b/generic/tclParse.c index 52c11d4..1462fd7 100644 --- a/generic/tclParse.c +++ b/generic/tclParse.c @@ -2092,7 +2092,7 @@ TclSubstTokens( * errors. */ Tcl_Token *tokenPtr, /* Pointer to first in an array of tokens to * evaluate and concatenate. */ - int count, /* Number of tokens to consider at tokenPtr. + size_t count1, /* Number of tokens to consider at tokenPtr. * Must be at least 1. */ int *tokensLeftPtr, /* If not NULL, points to memory where an * integer representing the number of tokens @@ -2123,6 +2123,7 @@ TclSubstTokens( int *clPosition = NULL; Interp *iPtr = (Interp *) interp; int inFile = iPtr->evalFlags & TCL_EVAL_FILE; + int count = count1; /* * Each pass through this loop will substitute one token, and its diff --git a/generic/tclUtil.c b/generic/tclUtil.c index 3ca178d..4e2165b 100644 --- a/generic/tclUtil.c +++ b/generic/tclUtil.c @@ -107,7 +107,7 @@ static Tcl_HashTable * GetThreadHash(Tcl_ThreadDataKey *keyPtr); static int GetWideForIndex(Tcl_Interp *interp, Tcl_Obj *objPtr, size_t endValue, Tcl_WideInt *widePtr); static int FindElement(Tcl_Interp *interp, const char *string, - int stringLength, const char *typeStr, + size_t stringLength, const char *typeStr, const char *typeCode, const char **elementPtr, const char **nextPtr, size_t *sizePtr, int *literalPtr); @@ -521,7 +521,7 @@ TclFindDictElement( * containing a Tcl dictionary with zero or * more keys and values (possibly in * braces). */ - int dictLength, /* Number of bytes in the dict's string. */ + size_t dictLength, /* Number of bytes in the dict's string. */ const char **elementPtr, /* Where to put address of first significant * character in the first element (i.e., key * or value) of dict. */ @@ -550,7 +550,7 @@ FindElement( * containing a Tcl list or dictionary with * zero or more elements (possibly in * braces). */ - int stringLength, /* Number of bytes in the string. */ + size_t stringLength1, /* Number of bytes in the string. */ const char *typeStr, /* The name of the type of thing we are * parsing, for error messages. */ const char *typeCode, /* The type code for thing we are parsing, for @@ -578,6 +578,7 @@ FindElement( size_t numChars; int literal = 1; const char *p2; + int stringLength = stringLength1; /* * Skim off leading white space and check for an opening brace or quote. -- cgit v0.12 From 2071722ddec667bebfb47e91d684cc37be2d81e5 Mon Sep 17 00:00:00 2001 From: fvogel Date: Mon, 7 Mar 2022 21:45:10 +0000 Subject: Improve a bit the ttk::treeview man page by instructing the html generator not link some words in that page when it should not. --- tools/tcltk-man2html.tcl | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/tools/tcltk-man2html.tcl b/tools/tcltk-man2html.tcl index 020aad9..75ed97e 100755 --- a/tools/tcltk-man2html.tcl +++ b/tools/tcltk-man2html.tcl @@ -682,7 +682,7 @@ array set exclude_refs_map { ttk_scale.n {variable} ttk_scrollbar.n {set} ttk_spinbox.n {format} - ttk_treeview.n {text open} + ttk_treeview.n {text open focus selection} ttk_widget.n {image text variable} TclZlib.3 {binary flush filename text} } -- cgit v0.12 From faf33c3ece8ecb7a33845cb5c3b4edfd725b9ef3 Mon Sep 17 00:00:00 2001 From: dgp Date: Mon, 7 Mar 2022 23:59:52 +0000 Subject: Starting in Tcl 8.7, Tcl_GetUniChar() returns int, not Tcl_UniChar (TIP 389). Make typecasts of returned values match the new signature. --- generic/tclStringObj.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/generic/tclStringObj.c b/generic/tclStringObj.c index 0a6503c..c2249ae 100644 --- a/generic/tclStringObj.c +++ b/generic/tclStringObj.c @@ -561,7 +561,7 @@ Tcl_GetUniChar( TclNumUtfChars(stringPtr->numChars, objPtr->bytes, objPtr->length); } if (stringPtr->numChars == objPtr->length) { - return (Tcl_UniChar) objPtr->bytes[index]; + return (int) objPtr->bytes[index]; } FillUnicodeRep(objPtr); stringPtr = GET_STRING(objPtr); -- cgit v0.12 From 0c1dd51a1481431e5ea33b1a451b99c939775ea8 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 8 Mar 2022 08:23:07 +0000 Subject: This typecast is wrong (and was already wrong). Correct it, and add testcase to prove it --- generic/tclStringObj.c | 2 +- tests/string.test | 3 +++ 2 files changed, 4 insertions(+), 1 deletion(-) diff --git a/generic/tclStringObj.c b/generic/tclStringObj.c index c2249ae..7d4aef3 100644 --- a/generic/tclStringObj.c +++ b/generic/tclStringObj.c @@ -561,7 +561,7 @@ Tcl_GetUniChar( TclNumUtfChars(stringPtr->numChars, objPtr->bytes, objPtr->length); } if (stringPtr->numChars == objPtr->length) { - return (int) objPtr->bytes[index]; + return (unsigned char) objPtr->bytes[index]; } FillUnicodeRep(objPtr); stringPtr = GET_STRING(objPtr); diff --git a/tests/string.test b/tests/string.test index 7da50e9..203d0c6 100644 --- a/tests/string.test +++ b/tests/string.test @@ -510,6 +510,9 @@ test string-5.20.$noComp {string index, bytearray object out of bounds} -body { test string-5.21.$noComp {string index, surrogates, bug [11ae2be95dac9417]} -constraints utf16 -body { run {list [string index a\U100000b 1] [string index a\U100000b 2] [string index a\U100000b 3]} } -result [list \U100000 {} b] +test string-5.22.$noComp {string index} -constraints testbytestring -body { + run {list [scan [string index [testbytestring \xFF] 0] %c var] $var} +} -result {1 255} test string-6.1.$noComp {string is, not enough args} { -- cgit v0.12 From 559954ccb37cf5d1bde6ed4bb37cde477b76a154 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 8 Mar 2022 10:38:36 +0000 Subject: Provide somewhat more space in Tcl_CallFrame --- generic/tcl.h | 9 +++++++-- generic/tclEnsemble.c | 4 ++-- generic/tclInt.h | 21 +++++++++++++-------- generic/tclNamesp.c | 2 +- generic/tclProc.c | 2 +- generic/tclVar.c | 8 ++++---- 6 files changed, 28 insertions(+), 18 deletions(-) diff --git a/generic/tcl.h b/generic/tcl.h index b609feb..9025c50 100644 --- a/generic/tcl.h +++ b/generic/tcl.h @@ -718,14 +718,19 @@ typedef struct Tcl_Namespace { typedef struct Tcl_CallFrame { Tcl_Namespace *nsPtr; int dummy1; - int dummy2; +#if TCL_MAJOR_VERSION > 8 + int dummy6; +#endif + size_t dummy2; void *dummy3; void *dummy4; void *dummy5; +#if TCL_MAJOR_VERSION < 9 int dummy6; +#endif void *dummy7; void *dummy8; - int dummy9; + size_t dummy9; void *dummy10; void *dummy11; void *dummy12; diff --git a/generic/tclEnsemble.c b/generic/tclEnsemble.c index c0846f8..56dc3c1 100644 --- a/generic/tclEnsemble.c +++ b/generic/tclEnsemble.c @@ -2231,8 +2231,8 @@ Tcl_Obj *const * TclFetchEnsembleRoot( Tcl_Interp *interp, Tcl_Obj *const *objv, - int objc, - int *objcPtr) + size_t objc, + size_t *objcPtr) { Tcl_Obj *const *sourceObjs; Interp *iPtr = (Interp *) interp; diff --git a/generic/tclInt.h b/generic/tclInt.h index 66d9245..c9a82b8 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -1110,7 +1110,13 @@ typedef struct CallFrame { * If FRAME_IS_PROC is set, the frame was * pushed to execute a Tcl procedure and may * have local vars. */ - int objc; /* This and objv below describe the arguments +#if TCL_MAJOR_VERSION > 8 + int level; /* Level of this procedure, for "uplevel" + * purposes (i.e. corresponds to nesting of + * callerVarPtr's, not callerPtr's). 1 for + * outermost procedure, 0 for top-level. */ +#endif + size_t objc; /* This and objv below describe the arguments * for this procedure call. */ Tcl_Obj *const *objv; /* Array of argument objects. */ struct CallFrame *callerPtr; @@ -1124,10 +1130,9 @@ typedef struct CallFrame { * callerPtr unless an "uplevel" command or * something equivalent was active in the * caller). */ - int level; /* Level of this procedure, for "uplevel" - * purposes (i.e. corresponds to nesting of - * callerVarPtr's, not callerPtr's). 1 for - * outermost procedure, 0 for top-level. */ +#if TCL_MAJOR_VERSION < 9 + int level; +#endif Proc *procPtr; /* Points to the structure defining the called * procedure. Used to get information such as * the number of compiled local variables @@ -1138,8 +1143,8 @@ typedef struct CallFrame { * recognized by the compiler, or created at * execution time through, e.g., upvar. * Initially NULL and created if needed. */ - int numCompiledLocals; /* Count of local variables recognized by the - * compiler including arguments. */ + size_t numCompiledLocals; /* Count of local variables recognized + * by the compiler including arguments. */ Var *compiledLocals; /* Points to the array of local variables * recognized by the compiler. The compiler * emits code that refers to these variables @@ -2922,7 +2927,7 @@ MODULE_SCOPE char * TclDStringAppendDString(Tcl_DString *dsPtr, Tcl_DString *toAppendPtr); MODULE_SCOPE Tcl_Obj * TclDStringToObj(Tcl_DString *dsPtr); MODULE_SCOPE Tcl_Obj *const *TclFetchEnsembleRoot(Tcl_Interp *interp, - Tcl_Obj *const *objv, int objc, int *objcPtr); + Tcl_Obj *const *objv, size_t objc, size_t *objcPtr); MODULE_SCOPE Tcl_Obj *const *TclEnsembleGetRewriteValues(Tcl_Interp *interp); MODULE_SCOPE Tcl_Namespace *TclEnsureNamespace(Tcl_Interp *interp, Tcl_Namespace *namespacePtr); diff --git a/generic/tclNamesp.c b/generic/tclNamesp.c index 4ce88ff..e1e298f 100644 --- a/generic/tclNamesp.c +++ b/generic/tclNamesp.c @@ -394,7 +394,7 @@ Tcl_PopCallFrame( Tcl_Free(framePtr->varTablePtr); framePtr->varTablePtr = NULL; } - if (framePtr->numCompiledLocals > 0) { + if (framePtr->numCompiledLocals + 1 > 1) { TclDeleteCompiledLocalVars(iPtr, framePtr); if (framePtr->localCachePtr->refCount-- <= 1) { TclFreeLocalCache(interp, framePtr->localCachePtr); diff --git a/generic/tclProc.c b/generic/tclProc.c index c4c6de1..55c109e 100644 --- a/generic/tclProc.c +++ b/generic/tclProc.c @@ -1675,7 +1675,7 @@ TclNRInterpProcCore( #if defined(TCL_COMPILE_DEBUG) if (tclTraceExec >= 1) { CallFrame *framePtr = iPtr->varFramePtr; - int i; + size_t i; if (framePtr->isProcCallFrame & FRAME_IS_LAMBDA) { fprintf(stdout, "Calling lambda "); diff --git a/generic/tclVar.c b/generic/tclVar.c index 8820fcd..2a9f8b7 100644 --- a/generic/tclVar.c +++ b/generic/tclVar.c @@ -619,7 +619,7 @@ TclObjLookupVarEx( if (localIndex >= 0) { if (HasLocalVars(varFramePtr) && !(flags & (TCL_GLOBAL_ONLY | TCL_NAMESPACE_ONLY)) - && (localIndex < varFramePtr->numCompiledLocals)) { + && (localIndex < (int)varFramePtr->numCompiledLocals)) { /* * Use the cached index if the names coincide. */ @@ -4763,9 +4763,9 @@ Tcl_GetVariableFullName( Tcl_AppendObjToObj(objPtr, namePtr); } } else if (iPtr->varFramePtr->procPtr) { - int index = varPtr - iPtr->varFramePtr->compiledLocals; + size_t index = varPtr - iPtr->varFramePtr->compiledLocals; - if (index >= 0 && index < iPtr->varFramePtr->numCompiledLocals) { + if (index < iPtr->varFramePtr->numCompiledLocals) { namePtr = localName(iPtr->varFramePtr, index); Tcl_AppendObjToObj(objPtr, namePtr); } @@ -5389,7 +5389,7 @@ TclDeleteCompiledLocalVars( * assigned local variables to delete. */ { Var *varPtr; - int numLocals, i; + size_t numLocals, i; Tcl_Obj **namePtrPtr; numLocals = framePtr->numCompiledLocals; -- cgit v0.12 From 9c52d351f19a451f9d7fff451624b195959a558d Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 8 Mar 2022 11:38:58 +0000 Subject: More size_t --- generic/regcomp.c | 4 ++-- generic/tclAssembly.c | 4 ++-- generic/tclCmdIL.c | 4 ++-- generic/tclCompCmds.c | 2 +- generic/tclCompCmdsSZ.c | 2 +- generic/tclCompile.c | 6 +++--- generic/tclCompile.h | 22 ++++++++++++++++------ generic/tclExecute.c | 2 +- generic/tclIORChan.c | 4 ++-- generic/tclListObj.c | 4 ++-- generic/tclOptimize.c | 5 +++-- generic/tclProc.c | 4 ++-- 12 files changed, 37 insertions(+), 26 deletions(-) diff --git a/generic/regcomp.c b/generic/regcomp.c index 103c0bf..4a107a8 100644 --- a/generic/regcomp.c +++ b/generic/regcomp.c @@ -410,7 +410,7 @@ compile( assert(v->nlacons == 0 || v->lacons != NULL); for (i = 1; i < v->nlacons; i++) { if (debug != NULL) { - fprintf(debug, "\n\n\n========= LA%" TCL_Z_MODIFIER "d ==========\n", i); + fprintf(debug, "\n\n\n========= LA%" TCL_Z_MODIFIER "u ==========\n", i); } nfanode(v, &v->lacons[i], debug); } @@ -2064,7 +2064,7 @@ dump( } fprintf(f, "\n\n\n========= DUMP ==========\n"); - fprintf(f, "nsub %" TCL_Z_MODIFIER "d, info 0%lo, ntree %d\n", + fprintf(f, "nsub %" TCL_Z_MODIFIER "u, info 0%lo, ntree %d\n", re->re_nsub, re->re_info, g->ntree); dumpcolors(&g->cmap, f); diff --git a/generic/tclAssembly.c b/generic/tclAssembly.c index e3e7bfc..b8a4606 100644 --- a/generic/tclAssembly.c +++ b/generic/tclAssembly.c @@ -963,14 +963,14 @@ TclCompileAssembleCmd( { Tcl_Token *tokenPtr; /* Token in the input script */ - int numCommands = envPtr->numCommands; + size_t numCommands = envPtr->numCommands; int offset = envPtr->codeNext - envPtr->codeStart; int depth = envPtr->currStackDepth; /* * Make sure that the command has a single arg that is a simple word. */ - if ((int)parsePtr->numWords != 2) { + if (parsePtr->numWords != 2) { return TCL_ERROR; } tokenPtr = TokenAfter(parsePtr->tokenPtr); diff --git a/generic/tclCmdIL.c b/generic/tclCmdIL.c index 261cc65..07e42ef 100644 --- a/generic/tclCmdIL.c +++ b/generic/tclCmdIL.c @@ -3383,7 +3383,7 @@ Tcl_LsearchObjCmd( } if (result == TCL_ERROR) { Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( - "\n (-index option item number %" TCL_Z_MODIFIER "d)", j)); + "\n (-index option item number %" TCL_Z_MODIFIER "u)", j)); goto done; } sortInfo.indexv[j] = encoded; @@ -4110,7 +4110,7 @@ Tcl_LsortObjCmd( } if (result == TCL_ERROR) { Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( - "\n (-index option item number %" TCL_Z_MODIFIER "d)", j)); + "\n (-index option item number %" TCL_Z_MODIFIER "u)", j)); sortInfo.resultCode = TCL_ERROR; goto done; } diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c index c9a5724..a3d663b 100644 --- a/generic/tclCompCmds.c +++ b/generic/tclCompCmds.c @@ -3022,7 +3022,7 @@ PrintNewForeachInfo( ForeachVarList *varsPtr; size_t i, j; - Tcl_AppendPrintfToObj(appendObj, "jumpOffset=%+" TCL_Z_MODIFIER "d, vars=", + Tcl_AppendPrintfToObj(appendObj, "jumpOffset=%+" TCL_Z_MODIFIER "u, vars=", infoPtr->loopCtTemp); for (i=0 ; inumLists ; i++) { if (i) { diff --git a/generic/tclCompCmdsSZ.c b/generic/tclCompCmdsSZ.c index 70c1a1d..0e782ac 100644 --- a/generic/tclCompCmdsSZ.c +++ b/generic/tclCompCmdsSZ.c @@ -893,7 +893,7 @@ TclCompileStringLenCmd( char buf[TCL_INTEGER_SPACE]; size_t len = Tcl_GetCharLength(objPtr); - len = sprintf(buf, "%" TCL_Z_MODIFIER "d", len); + len = sprintf(buf, "%" TCL_Z_MODIFIER "u", len); PushLiteral(envPtr, buf, len); } else { SetLineInformation(1); diff --git a/generic/tclCompile.c b/generic/tclCompile.c index 9166ec4..e86a363 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -3164,7 +3164,7 @@ EnterCmdStartData( { CmdLocation *cmdLocPtr; - if ((cmdIndex < 0) || (cmdIndex >= envPtr->numCommands)) { + if ((size_t)cmdIndex >= envPtr->numCommands) { Tcl_Panic("EnterCmdStartData: bad command index %d", cmdIndex); } @@ -3243,7 +3243,7 @@ EnterCmdExtentData( { CmdLocation *cmdLocPtr; - if ((cmdIndex < 0) || (cmdIndex >= envPtr->numCommands)) { + if ((size_t)cmdIndex >= envPtr->numCommands) { Tcl_Panic("EnterCmdExtentData: bad command index %d", cmdIndex); } @@ -4028,7 +4028,7 @@ TclFixupForwardJump( */ firstCmd = jumpFixupPtr->cmdIndex; - lastCmd = envPtr->numCommands - 1; + lastCmd = (int)envPtr->numCommands - 1; if (firstCmd < lastCmd) { for (k = firstCmd; k <= lastCmd; k++) { envPtr->cmdMapPtr[k].codeOffset += 3; diff --git a/generic/tclCompile.h b/generic/tclCompile.h index b550c57..9f47a03 100644 --- a/generic/tclCompile.h +++ b/generic/tclCompile.h @@ -290,13 +290,13 @@ typedef struct CompileEnv { * SetByteCodeFromAny. This pointer is not * owned by the CompileEnv and must not be * freed or changed by it. */ - int numSrcBytes; /* Number of bytes in source. */ + size_t numSrcBytes; /* Number of bytes in source. */ Proc *procPtr; /* If a procedure is being compiled, a pointer * to its Proc structure; otherwise NULL. Used * to compile local variables. Set from * information provided by ObjInterpProc in * tclProc.c. */ - int numCommands; /* Number of commands compiled. */ + size_t numCommands; /* Number of commands compiled. */ int exceptDepth; /* Current exception range nesting level; -1 * if not in any range currently. */ int maxExceptDepth; /* Max nesting level of exception ranges; -1 @@ -316,6 +316,10 @@ typedef struct CompileEnv { * array byte. */ int mallocedCodeArray; /* Set 1 if code array was expanded and * codeStart points into the heap.*/ +#if TCL_MAJOR_VERSION > 8 + int mallocedExceptArray; /* 1 if ExceptionRange array was expanded and + * exceptArrayPtr points in heap, else 0. */ +#endif LiteralEntry *literalArrayPtr; /* Points to start of LiteralEntry array. */ int literalArrayNext; /* Index of next free object array entry. */ @@ -331,8 +335,9 @@ typedef struct CompileEnv { * current range's array entry. */ int exceptArrayEnd; /* Index after the last ExceptionRange array * entry. */ - int mallocedExceptArray; /* 1 if ExceptionRange array was expanded and - * exceptArrayPtr points in heap, else 0. */ +#if TCL_MAJOR_VERSION < 9 + int mallocedExceptArray; +#endif ExceptionAux *exceptAuxArrayPtr; /* Array of information used to restore the * state when processing BREAK/CONTINUE @@ -345,14 +350,19 @@ typedef struct CompileEnv { int cmdMapEnd; /* Index after last CmdLocation entry. */ int mallocedCmdMap; /* 1 if command map array was expanded and * cmdMapPtr points in the heap, else 0. */ +#if TCL_MAJOR_VERSION > 8 + int mallocedAuxDataArray; /* 1 if aux data array was expanded and + * auxDataArrayPtr points in heap else 0. */ +#endif AuxData *auxDataArrayPtr; /* Points to auxiliary data array start. */ int auxDataArrayNext; /* Next free compile aux data array index. * auxDataArrayNext is the number of aux data * items and (auxDataArrayNext-1) is index of * current aux data array entry. */ int auxDataArrayEnd; /* Index after last aux data array entry. */ - int mallocedAuxDataArray; /* 1 if aux data array was expanded and - * auxDataArrayPtr points in heap else 0. */ +#if TCL_MAJOR_VERSION < 9 + int mallocedAuxDataArray; +#endif unsigned char staticCodeSpace[COMPILEENV_INIT_CODE_BYTES]; /* Initial storage for code. */ LiteralEntry staticLiteralSpace[COMPILEENV_INIT_NUM_OBJECTS]; diff --git a/generic/tclExecute.c b/generic/tclExecute.c index 91796b3..fb51350 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -2658,7 +2658,7 @@ TEBCresume( /* Ugly abuse! */ starting = 1; #endif - TRACE(("=> drop %" TCL_Z_MODIFIER "d items\n", objc)); + TRACE(("=> drop %" TCL_Z_MODIFIER "u items\n", objc)); NEXT_INST_V(1, objc, 0); case INST_EXPAND_STKTOP: { diff --git a/generic/tclIORChan.c b/generic/tclIORChan.c index 7588ffa..f8646ff 100644 --- a/generic/tclIORChan.c +++ b/generic/tclIORChan.c @@ -2006,7 +2006,7 @@ ReflectGetOption( Tcl_ResetResult(interp); Tcl_SetObjResult(interp, Tcl_ObjPrintf( "Expected list with even number of " - "elements, got %" TCL_Z_MODIFIER "d element%s instead", listc, + "elements, got %" TCL_Z_MODIFIER "u element%s instead", listc, (listc == 1 ? "" : "s"))); goto error; } else { @@ -3320,7 +3320,7 @@ ForwardProc( char *buf = (char *)Tcl_Alloc(200); sprintf(buf, - "{Expected list with even number of elements, got %" TCL_Z_MODIFIER "d %s instead}", + "{Expected list with even number of elements, got %" TCL_Z_MODIFIER "u %s instead}", listc, (listc == 1 ? "element" : "elements")); ForwardSetDynamicError(paramPtr, buf); diff --git a/generic/tclListObj.c b/generic/tclListObj.c index f7c32ef..17dd466 100644 --- a/generic/tclListObj.c +++ b/generic/tclListObj.c @@ -1763,7 +1763,7 @@ TclListObjSetElement( if (length == 0) { if (interp != NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "index \"%" TCL_Z_MODIFIER "d\" out of range", index)); + "index \"%" TCL_Z_MODIFIER "u\" out of range", index)); Tcl_SetErrorCode(interp, "TCL", "VALUE", "INDEX", "OUTOFRANGE", NULL); } @@ -1785,7 +1785,7 @@ TclListObjSetElement( if (index>=elemCount) { if (interp != NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "index \"%" TCL_Z_MODIFIER "d\" out of range", index)); + "index \"%" TCL_Z_MODIFIER "u\" out of range", index)); Tcl_SetErrorCode(interp, "TCL", "VALUE", "INDEX", "OUTOFRANGE", NULL); } diff --git a/generic/tclOptimize.c b/generic/tclOptimize.c index 1ef5ae7..094638e 100644 --- a/generic/tclOptimize.c +++ b/generic/tclOptimize.c @@ -54,7 +54,8 @@ LocateTargetAddresses( Tcl_HashTable *tablePtr) { unsigned char *currentInstPtr, *targetInstPtr; - int isNew, i; + int isNew; + size_t i; Tcl_HashEntry *hPtr; Tcl_HashSearch hSearch; @@ -124,7 +125,7 @@ LocateTargetAddresses( * Enter in the targets of exception ranges. */ - for (i=0 ; iexceptArrayNext ; i++) { + for (i=0 ; i<(size_t)envPtr->exceptArrayNext ; i++) { ExceptionRange *rangePtr = &envPtr->exceptArrayPtr[i]; if (rangePtr->type == CATCH_EXCEPTION_RANGE) { diff --git a/generic/tclProc.c b/generic/tclProc.c index 55c109e..feba33b 100644 --- a/generic/tclProc.c +++ b/generic/tclProc.c @@ -492,7 +492,7 @@ TclCreateProc( if (precompiled) { if (numArgs > (size_t)procPtr->numArgs) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "procedure \"%s\": arg list contains %" TCL_Z_MODIFIER "d entries, " + "procedure \"%s\": arg list contains %" TCL_Z_MODIFIER "u entries, " "precompiled header expects %d", procName, numArgs, procPtr->numArgs)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC", @@ -587,7 +587,7 @@ TclCreateProc( || (localPtr->defValuePtr == NULL && fieldCount == 2) || (localPtr->defValuePtr != NULL && fieldCount != 2)) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "procedure \"%s\": formal parameter %" TCL_Z_MODIFIER "d is " + "procedure \"%s\": formal parameter %" TCL_Z_MODIFIER "u is " "inconsistent with precompiled body", procName, i)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC", "BYTECODELIES", NULL); -- cgit v0.12 From 9c28f4fc5f89366f31d58cf585b33aff028ea5d6 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 8 Mar 2022 15:10:57 +0000 Subject: Fix [b6afa33737]: signed integer overflow in TclInitStringRep() macro --- generic/tclInt.h | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/generic/tclInt.h b/generic/tclInt.h index 1954a13..89ce8f0 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -4316,7 +4316,7 @@ MODULE_SCOPE void TclDbInitNewObj(Tcl_Obj *objPtr, const char *file, (objPtr)->bytes = tclEmptyStringRep; \ (objPtr)->length = 0; \ } else { \ - (objPtr)->bytes = (char *) ckalloc((len) + 1); \ + (objPtr)->bytes = (char *) ckalloc((unsigned int)(len) + 1U); \ memcpy((objPtr)->bytes, (bytePtr), (len)); \ (objPtr)->bytes[len] = '\0'; \ (objPtr)->length = (len); \ -- cgit v0.12 From aaead6c7ae251886735590603d20616cc63a497f Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 8 Mar 2022 15:21:25 +0000 Subject: Fix [1c7f179710]: undefined behavior for INST_LSHIFT in ExecuteExtendedBinaryMathOp() --- generic/tclExecute.c | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/generic/tclExecute.c b/generic/tclExecute.c index b96eab4..a26aae1 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -8661,9 +8661,9 @@ ExecuteExtendedBinaryMathOp( && ((size_t)shift < CHAR_BIT*sizeof(Tcl_WideInt))) { TclGetWideIntFromObj(NULL, valuePtr, &w1); if (!((w1>0 ? w1 : ~w1) - & -(((Tcl_WideInt)1) + & -(((Tcl_WideUInt)1) << (CHAR_BIT*sizeof(Tcl_WideInt) - 1 - shift)))) { - WIDE_RESULT(w1 << shift); + WIDE_RESULT((Tcl_WideUInt)w1 << shift); } } } else { -- cgit v0.12 From 94033c98698f9311df88190fad45f190b4b829a8 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 8 Mar 2022 15:23:16 +0000 Subject: Fix [9c7557160]: signed integer overflow in UpdateStringOfByteArray() --- generic/tclBinary.c | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/generic/tclBinary.c b/generic/tclBinary.c index fdb7f59..1c97728 100644 --- a/generic/tclBinary.c +++ b/generic/tclBinary.c @@ -565,14 +565,14 @@ UpdateStringOfByteArray( size = length; for (i = 0; i < length && size >= 0; i++) { if ((src[i] == 0) || (src[i] > 127)) { - size++; + size = (int)((unsigned int)size + 1U); } } if (size < 0) { Tcl_Panic("max size for a Tcl value (%d bytes) exceeded", INT_MAX); } - dst = (char *)ckalloc(size + 1); + dst = (char *)ckalloc((unsigned int)size + 1U); objPtr->bytes = dst; objPtr->length = size; -- cgit v0.12 From 77d395c7f814d2a2d784c06b197ea84fc03ab213 Mon Sep 17 00:00:00 2001 From: dgp Date: Tue, 8 Mar 2022 17:12:28 +0000 Subject: Backport fix and test for typecasting bug in Tcl_GetUniChar(). --- generic/tclStringObj.c | 4 ++-- tests/string.test | 7 +++++++ 2 files changed, 9 insertions(+), 2 deletions(-) diff --git a/generic/tclStringObj.c b/generic/tclStringObj.c index d1e709c..4afd12a 100644 --- a/generic/tclStringObj.c +++ b/generic/tclStringObj.c @@ -576,7 +576,7 @@ Tcl_GetUniChar( TclNumUtfChars(stringPtr->numChars, objPtr->bytes, objPtr->length); } if (stringPtr->numChars == objPtr->length) { - return (Tcl_UniChar) objPtr->bytes[index]; + return (unsigned char) objPtr->bytes[index]; } FillUnicodeRep(objPtr); stringPtr = GET_STRING(objPtr); @@ -632,7 +632,7 @@ TclGetUCS4( TclNumUtfChars(stringPtr->numChars, objPtr->bytes, objPtr->length); } if (stringPtr->numChars == objPtr->length) { - return (Tcl_UniChar) objPtr->bytes[index]; + return (unsigned char) objPtr->bytes[index]; } FillUnicodeRep(objPtr); stringPtr = GET_STRING(objPtr); diff --git a/tests/string.test b/tests/string.test index 66eb6ad..977e875 100644 --- a/tests/string.test +++ b/tests/string.test @@ -323,6 +323,13 @@ test string-5.20 {string index, bytearray object out of bounds} { string index [binary format I* {0x50515253 0x52}] 20 } {} +test string-5.22 {string index} -constraints testbytestring -setup { + set string string +} -body { + list [scan [$string index [testbytestring \xFF] 0] %c var] $var +} -cleanup { + unset string +} -result {1 255} proc largest_int {} { # This will give us what the largest valid int on this machine is, -- cgit v0.12 From 0018893f3518509598c9945436bbd7b51ecacc70 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 9 Mar 2022 15:16:01 +0000 Subject: Tweak test code such that it can be used to test indexes > 2^31 too, so no longer limit values to INT_MIN .. INT_MAX --- generic/tclTest.c | 68 ++++++++-------- generic/tclTestObj.c | 216 +++++++++++++++++++++++---------------------------- 2 files changed, 130 insertions(+), 154 deletions(-) diff --git a/generic/tclTest.c b/generic/tclTest.c index 009c95f..1564bd5 100644 --- a/generic/tclTest.c +++ b/generic/tclTest.c @@ -760,7 +760,7 @@ TestasyncCmd( asyncPtr->nextPtr = firstHandler; firstHandler = asyncPtr; Tcl_MutexUnlock(&asyncTestMutex); - Tcl_SetObjResult(interp, Tcl_NewIntObj(asyncPtr->id)); + Tcl_SetObjResult(interp, Tcl_NewWideIntObj(asyncPtr->id)); } else if (strcmp(argv[1], "delete") == 0) { if (argc == 2) { Tcl_MutexLock(&asyncTestMutex); @@ -1023,9 +1023,9 @@ TestcmdinfoCmd( info.deleteProc = CmdDelProc2; info.deleteData = (void *) "new_delete_data"; if (Tcl_SetCommandInfo(interp, argv[2], &info) == 0) { - Tcl_SetObjResult(interp, Tcl_NewIntObj(0)); + Tcl_SetObjResult(interp, Tcl_NewWideIntObj(0)); } else { - Tcl_SetObjResult(interp, Tcl_NewIntObj(1)); + Tcl_SetObjResult(interp, Tcl_NewWideIntObj(1)); } } else { Tcl_AppendResult(interp, "bad option \"", argv[1], @@ -1676,7 +1676,7 @@ TestdoubledigitsObjCmd( strObj = Tcl_NewStringObj(str, endPtr-str); ckfree(str); retval = Tcl_NewListObj(1, &strObj); - Tcl_ListObjAppendElement(NULL, retval, Tcl_NewIntObj(decpt)); + Tcl_ListObjAppendElement(NULL, retval, Tcl_NewWideIntObj(decpt)); strObj = Tcl_NewStringObj(signum ? "-" : "+", 1); Tcl_ListObjAppendElement(NULL, retval, strObj); Tcl_SetObjResult(interp, retval); @@ -1770,7 +1770,7 @@ TestdstringCmd( if (argc != 2) { goto wrongNumArgs; } - Tcl_SetObjResult(interp, Tcl_NewIntObj(Tcl_DStringLength(&dstring))); + Tcl_SetObjResult(interp, Tcl_NewWideIntObj(Tcl_DStringLength(&dstring))); } else if (strcmp(argv[1], "result") == 0) { if (argc != 2) { goto wrongNumArgs; @@ -3534,7 +3534,7 @@ PrintParse( Tcl_ListObjAppendElement(NULL, objPtr, Tcl_NewStringObj(parsePtr->commandStart, parsePtr->commandSize)); Tcl_ListObjAppendElement(NULL, objPtr, - Tcl_NewIntObj(parsePtr->numWords)); + Tcl_NewWideIntObj(parsePtr->numWords)); for (i = 0; i < parsePtr->numTokens; i++) { tokenPtr = &parsePtr->tokenPtr[i]; switch (tokenPtr->type) { @@ -3574,7 +3574,7 @@ PrintParse( Tcl_ListObjAppendElement(NULL, objPtr, Tcl_NewStringObj(tokenPtr->start, tokenPtr->size)); Tcl_ListObjAppendElement(NULL, objPtr, - Tcl_NewIntObj(tokenPtr->numComponents)); + Tcl_NewWideIntObj(tokenPtr->numComponents)); } Tcl_ListObjAppendElement(NULL, objPtr, parsePtr->commandStart ? @@ -3890,7 +3890,7 @@ TestregexpObjCmd( * value 0. */ - Tcl_SetIntObj(Tcl_GetObjResult(interp), 0); + Tcl_SetWideIntObj(Tcl_GetObjResult(interp), 0); if (objc > 2 && (cflags®_EXPECT) && indices) { const char *varName; const char *value; @@ -3986,7 +3986,7 @@ TestregexpObjCmd( * Set the interpreter's object result to an integer object w/ value 1. */ - Tcl_SetIntObj(Tcl_GetObjResult(interp), 1); + Tcl_SetWideIntObj(Tcl_GetObjResult(interp), 1); return TCL_OK; } @@ -6203,7 +6203,7 @@ TestServiceModeCmd( Tcl_SetServiceMode(TCL_SERVICE_ALL); } } - Tcl_SetObjResult(interp, Tcl_NewIntObj(oldmode)); + Tcl_SetObjResult(interp, Tcl_NewWideIntObj(oldmode)); return TCL_OK; } @@ -6881,7 +6881,7 @@ TestUtfNextCmd( int objc, Tcl_Obj *const objv[]) { - int numBytes; + size_t numBytes; char *bytes; const char *result, *first; char buffer[32]; @@ -6894,10 +6894,10 @@ TestUtfNextCmd( } bytes = Tcl_GetStringFromObj(objv[1], &numBytes); - if (numBytes > (int)sizeof(buffer) - 4) { + if (numBytes + 4 > sizeof(buffer)) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "\"testutfnext\" can only handle %d bytes", - (int)sizeof(buffer) - 4)); + "\"testutfnext\" can only handle %" TCL_Z_MODIFIER "u bytes", + sizeof(buffer) - 4)); return TCL_ERROR; } @@ -6925,7 +6925,7 @@ TestUtfNextCmd( } } - Tcl_SetObjResult(interp, Tcl_NewIntObj(first - buffer - 1)); + Tcl_SetObjResult(interp, Tcl_NewWideIntObj(first - buffer - 1)); return TCL_OK; } @@ -6967,7 +6967,7 @@ TestUtfPrevCmd( offset = numBytes; } result = Tcl_UtfPrev(bytes + offset, bytes); - Tcl_SetObjResult(interp, Tcl_NewIntObj(result - bytes)); + Tcl_SetObjResult(interp, Tcl_NewWideIntObj(result - bytes)); return TCL_OK; } @@ -6995,7 +6995,7 @@ TestNumUtfCharsCmd( } } len = Tcl_NumUtfChars(bytes, limit); - Tcl_SetObjResult(interp, Tcl_NewIntObj(len)); + Tcl_SetObjResult(interp, Tcl_NewWideIntObj(len)); } return TCL_OK; } @@ -7120,7 +7120,7 @@ TestcpuidCmd( return status; } for (i=0 ; i<4 ; ++i) { - regsObjs[i] = Tcl_NewIntObj(regs[i]); + regsObjs[i] = Tcl_NewWideIntObj(regs[i]); } Tcl_SetObjResult(interp, Tcl_NewListObj(4, regsObjs)); return TCL_OK; @@ -7161,7 +7161,7 @@ TestHashSystemHashCmd( for (i=0 ; inumLevels); - levels[2] = Tcl_NewIntObj(iPtr->cmdFramePtr->level); - levels[3] = Tcl_NewIntObj(iPtr->varFramePtr->level); - levels[4] = Tcl_NewIntObj(iPtr->execEnvPtr->execStackPtr->tosPtr + levels[0] = Tcl_NewWideIntObj(depth); + levels[1] = Tcl_NewWideIntObj(iPtr->numLevels); + levels[2] = Tcl_NewWideIntObj(iPtr->cmdFramePtr->level); + levels[3] = Tcl_NewWideIntObj(iPtr->varFramePtr->level); + levels[4] = Tcl_NewWideIntObj(iPtr->execEnvPtr->execStackPtr->tosPtr - iPtr->execEnvPtr->execStackPtr->stackWords); while (cbPtr) { i++; cbPtr = cbPtr->nextPtr; } - levels[5] = Tcl_NewIntObj(i); + levels[5] = Tcl_NewWideIntObj(i); Tcl_SetObjResult(interp, Tcl_NewListObj(6, levels)); return TCL_OK; @@ -7726,8 +7726,8 @@ TestparseargsCmd( if (Tcl_ParseArgsObjv(interp, argTable, &count, objv, &remObjv)!=TCL_OK) { return TCL_ERROR; } - result[0] = Tcl_NewIntObj(foo); - result[1] = Tcl_NewIntObj(count); + result[0] = Tcl_NewWideIntObj(foo); + result[1] = Tcl_NewWideIntObj(count); result[2] = Tcl_NewListObj(count, remObjv); Tcl_SetObjResult(interp, Tcl_NewListObj(3, result)); ckfree(remObjv); diff --git a/generic/tclTestObj.c b/generic/tclTestObj.c index f766030..9081bcf 100644 --- a/generic/tclTestObj.c +++ b/generic/tclTestObj.c @@ -38,10 +38,10 @@ * Forward declarations for functions defined later in this file: */ -static int CheckIfVarUnset(Tcl_Interp *interp, Tcl_Obj **varPtr, int varIndex); +static int CheckIfVarUnset(Tcl_Interp *interp, Tcl_Obj **varPtr, size_t varIndex); static int GetVariableIndex(Tcl_Interp *interp, - const char *string, int *indexPtr); -static void SetVarToObj(Tcl_Obj **varPtr, int varIndex, Tcl_Obj *objPtr); + Tcl_Obj *obj, size_t *indexPtr); +static void SetVarToObj(Tcl_Obj **varPtr, size_t varIndex, Tcl_Obj *objPtr); static Tcl_ObjCmdProc TestbignumobjCmd; static Tcl_ObjCmdProc TestbooleanobjCmd; static Tcl_ObjCmdProc TestdoubleobjCmd; @@ -160,7 +160,8 @@ TestbignumobjCmd( BIGNUM_SET, BIGNUM_GET, BIGNUM_MULT10, BIGNUM_DIV10, BIGNUM_ISEVEN, BIGNUM_RADIXSIZE }; - int index, varIndex; + int index; + size_t varIndex; const char *string; mp_int bignumValue; Tcl_Obj **varPtr; @@ -173,13 +174,12 @@ TestbignumobjCmd( &index) != TCL_OK) { return TCL_ERROR; } - string = Tcl_GetString(objv[2]); - if (GetVariableIndex(interp, string, &varIndex) != TCL_OK) { + if (GetVariableIndex(interp, objv[2], &varIndex) != TCL_OK) { return TCL_ERROR; } varPtr = GetVarPtr(interp); - switch (index) { + switch ((enum options)index) { case BIGNUM_SET: if (objc != 4) { Tcl_WrongNumArgs(interp, 2, objv, "var value"); @@ -292,9 +292,9 @@ TestbignumobjCmd( return TCL_ERROR; } if (!Tcl_IsShared(varPtr[varIndex])) { - Tcl_SetIntObj(varPtr[varIndex], mp_iszero(&bignumValue)); + Tcl_SetWideIntObj(varPtr[varIndex], mp_iszero(&bignumValue)); } else { - SetVarToObj(varPtr, varIndex, Tcl_NewIntObj(mp_iszero(&bignumValue))); + SetVarToObj(varPtr, varIndex, Tcl_NewWideIntObj(mp_iszero(&bignumValue))); } mp_clear(&bignumValue); break; @@ -315,9 +315,9 @@ TestbignumobjCmd( return TCL_ERROR; } if (!Tcl_IsShared(varPtr[varIndex])) { - Tcl_SetIntObj(varPtr[varIndex], index); + Tcl_SetWideIntObj(varPtr[varIndex], index); } else { - SetVarToObj(varPtr, varIndex, Tcl_NewIntObj(index)); + SetVarToObj(varPtr, varIndex, Tcl_NewWideIntObj(index)); } mp_clear(&bignumValue); break; @@ -352,8 +352,9 @@ TestbooleanobjCmd( int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - int varIndex, boolValue; - const char *index, *subCmd; + size_t varIndex; + int boolValue; + const char *subCmd; Tcl_Obj **varPtr; if (objc < 3) { @@ -362,8 +363,7 @@ TestbooleanobjCmd( return TCL_ERROR; } - index = Tcl_GetString(objv[2]); - if (GetVariableIndex(interp, index, &varIndex) != TCL_OK) { + if (GetVariableIndex(interp, objv[2], &varIndex) != TCL_OK) { return TCL_ERROR; } @@ -452,9 +452,9 @@ TestdoubleobjCmd( int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - int varIndex; + size_t varIndex; double doubleValue; - const char *index, *subCmd, *string; + const char *subCmd; Tcl_Obj **varPtr; if (objc < 3) { @@ -465,8 +465,7 @@ TestdoubleobjCmd( varPtr = GetVarPtr(interp); - index = Tcl_GetString(objv[2]); - if (GetVariableIndex(interp, index, &varIndex) != TCL_OK) { + if (GetVariableIndex(interp, objv[2], &varIndex) != TCL_OK) { return TCL_ERROR; } @@ -475,8 +474,7 @@ TestdoubleobjCmd( if (objc != 4) { goto wrongNumArgs; } - string = Tcl_GetString(objv[3]); - if (Tcl_GetDouble(interp, string, &doubleValue) != TCL_OK) { + if (Tcl_GetDouble(interp, Tcl_GetString(objv[3]), &doubleValue) != TCL_OK) { return TCL_ERROR; } @@ -570,7 +568,8 @@ TestindexobjCmd( int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - int allowAbbrev, index, index2, setError, i, result; + int allowAbbrev, index, setError, i, result; + Tcl_WideInt index2; const char **argv; static const char *const tablePtr[] = {"a", "b", "check", NULL}; @@ -579,10 +578,9 @@ TestindexobjCmd( */ struct IndexRep { void *tablePtr; /* Pointer to the table of strings. */ - int offset; /* Offset between table entries. */ - int index; /* Selected index into table. */ - }; - struct IndexRep *indexRep; + TCL_HASH_TYPE offset; /* Offset between table entries. */ + TCL_HASH_TYPE index; /* Selected index into table. */ + } *indexRep; if ((objc == 3) && (strcmp(Tcl_GetString(objv[1]), "check") == 0)) { @@ -592,7 +590,7 @@ TestindexobjCmd( * lookups. */ - if (Tcl_GetIntFromObj(interp, objv[2], &index2) != TCL_OK) { + if (Tcl_GetWideIntFromObj(interp, objv[2], &index2) != TCL_OK) { return TCL_ERROR; } @@ -602,7 +600,7 @@ TestindexobjCmd( result = Tcl_GetIndexFromObj(NULL, objv[1], tablePtr, "token", 0, &index); if (result == TCL_OK) { - Tcl_SetIntObj(Tcl_GetObjResult(interp), index); + Tcl_SetWideIntObj(Tcl_GetObjResult(interp), index); } return result; } @@ -630,7 +628,7 @@ TestindexobjCmd( &index); ckfree(argv); if (result == TCL_OK) { - Tcl_SetIntObj(Tcl_GetObjResult(interp), index); + Tcl_SetWideIntObj(Tcl_GetObjResult(interp), index); } return result; } @@ -660,9 +658,10 @@ TestintobjCmd( int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - int intValue, varIndex, i; + size_t varIndex; + int i; Tcl_WideInt wideValue; - const char *index, *subCmd, *string; + const char *subCmd; Tcl_Obj **varPtr; if (objc < 3) { @@ -672,8 +671,7 @@ TestintobjCmd( } varPtr = GetVarPtr(interp); - index = Tcl_GetString(objv[2]); - if (GetVariableIndex(interp, index, &varIndex) != TCL_OK) { + if (GetVariableIndex(interp, objv[2], &varIndex) != TCL_OK) { return TCL_ERROR; } @@ -682,11 +680,9 @@ TestintobjCmd( if (objc != 4) { goto wrongNumArgs; } - string = Tcl_GetString(objv[3]); - if (Tcl_GetInt(interp, string, &i) != TCL_OK) { + if (Tcl_GetWideIntFromObj(interp, objv[3], &wideValue) != TCL_OK) { return TCL_ERROR; } - intValue = i; /* * If the object currently bound to the variable with index varIndex @@ -697,38 +693,34 @@ TestintobjCmd( */ if ((varPtr[varIndex] != NULL) && !Tcl_IsShared(varPtr[varIndex])) { - Tcl_SetIntObj(varPtr[varIndex], intValue); + Tcl_SetWideIntObj(varPtr[varIndex], wideValue); } else { - SetVarToObj(varPtr, varIndex, Tcl_NewIntObj(intValue)); + SetVarToObj(varPtr, varIndex, Tcl_NewWideIntObj(wideValue)); } Tcl_SetObjResult(interp, varPtr[varIndex]); } else if (strcmp(subCmd, "set2") == 0) { /* doesn't set result */ if (objc != 4) { goto wrongNumArgs; } - string = Tcl_GetString(objv[3]); - if (Tcl_GetInt(interp, string, &i) != TCL_OK) { + if (Tcl_GetWideIntFromObj(interp, objv[3], &wideValue) != TCL_OK) { return TCL_ERROR; } - intValue = i; if ((varPtr[varIndex] != NULL) && !Tcl_IsShared(varPtr[varIndex])) { - Tcl_SetIntObj(varPtr[varIndex], intValue); + Tcl_SetWideIntObj(varPtr[varIndex], wideValue); } else { - SetVarToObj(varPtr, varIndex, Tcl_NewIntObj(intValue)); + SetVarToObj(varPtr, varIndex, Tcl_NewWideIntObj(wideValue)); } } else if (strcmp(subCmd, "setint") == 0) { if (objc != 4) { goto wrongNumArgs; } - string = Tcl_GetString(objv[3]); - if (Tcl_GetInt(interp, string, &i) != TCL_OK) { + if (Tcl_GetWideIntFromObj(interp, objv[3], &wideValue) != TCL_OK) { return TCL_ERROR; } - intValue = i; if ((varPtr[varIndex] != NULL) && !Tcl_IsShared(varPtr[varIndex])) { - Tcl_SetWideIntObj(varPtr[varIndex], intValue); + Tcl_SetWideIntObj(varPtr[varIndex], wideValue); } else { - SetVarToObj(varPtr, varIndex, Tcl_NewWideIntObj(intValue)); + SetVarToObj(varPtr, varIndex, Tcl_NewWideIntObj(wideValue)); } Tcl_SetObjResult(interp, varPtr[varIndex]); } else if (strcmp(subCmd, "setmax") == 0) { @@ -768,8 +760,7 @@ TestintobjCmd( if (CheckIfVarUnset(interp, varPtr,varIndex)) { return TCL_ERROR; } - string = Tcl_GetString(varPtr[varIndex]); - Tcl_AppendToObj(Tcl_GetObjResult(interp), string, -1); + Tcl_AppendToObj(Tcl_GetObjResult(interp), Tcl_GetString(varPtr[varIndex]), -1); } else if (strcmp(subCmd, "inttoobigtest") == 0) { /* * If long ints have more bits than ints on this platform, verify that @@ -803,14 +794,14 @@ TestintobjCmd( if (CheckIfVarUnset(interp, varPtr,varIndex)) { return TCL_ERROR; } - if (Tcl_GetIntFromObj(interp, varPtr[varIndex], - &intValue) != TCL_OK) { + if (Tcl_GetWideIntFromObj(interp, varPtr[varIndex], + &wideValue) != TCL_OK) { return TCL_ERROR; } if (!Tcl_IsShared(varPtr[varIndex])) { - Tcl_SetIntObj(varPtr[varIndex], intValue * 10); + Tcl_SetWideIntObj(varPtr[varIndex], wideValue * 10); } else { - SetVarToObj(varPtr, varIndex, Tcl_NewIntObj(intValue * 10)); + SetVarToObj(varPtr, varIndex, Tcl_NewWideIntObj(wideValue * 10)); } Tcl_SetObjResult(interp, varPtr[varIndex]); } else if (strcmp(subCmd, "div10") == 0) { @@ -820,14 +811,14 @@ TestintobjCmd( if (CheckIfVarUnset(interp, varPtr,varIndex)) { return TCL_ERROR; } - if (Tcl_GetIntFromObj(interp, varPtr[varIndex], - &intValue) != TCL_OK) { + if (Tcl_GetWideIntFromObj(interp, varPtr[varIndex], + &wideValue) != TCL_OK) { return TCL_ERROR; } if (!Tcl_IsShared(varPtr[varIndex])) { - Tcl_SetIntObj(varPtr[varIndex], intValue / 10); + Tcl_SetWideIntObj(varPtr[varIndex], wideValue / 10); } else { - SetVarToObj(varPtr, varIndex, Tcl_NewIntObj(intValue / 10)); + SetVarToObj(varPtr, varIndex, Tcl_NewWideIntObj(wideValue / 10)); } Tcl_SetObjResult(interp, varPtr[varIndex]); } else { @@ -874,13 +865,11 @@ TestlistobjCmd( LISTOBJ_SET, LISTOBJ_GET, LISTOBJ_REPLACE - }; + } cmdIndex; - const char* index; /* Argument giving the variable number */ - int varIndex; /* Variable number converted to binary */ - int cmdIndex; /* Ordinal number of the subcommand */ - int first; /* First index in the list */ - int count; /* Count of elements in a list */ + size_t varIndex; /* Variable number converted to binary */ + Tcl_WideInt first; /* First index in the list */ + Tcl_WideInt count; /* Count of elements in a list */ Tcl_Obj **varPtr; if (objc < 3) { @@ -888,8 +877,7 @@ TestlistobjCmd( return TCL_ERROR; } varPtr = GetVarPtr(interp); - index = Tcl_GetString(objv[2]); - if (GetVariableIndex(interp, index, &varIndex) != TCL_OK) { + if (GetVariableIndex(interp, objv[2], &varIndex) != TCL_OK) { return TCL_ERROR; } if (Tcl_GetIndexFromObj(interp, objv[1], subcommands, "command", @@ -923,8 +911,8 @@ TestlistobjCmd( "varIndex start count ?element...?"); return TCL_ERROR; } - if (Tcl_GetIntFromObj(interp, objv[3], &first) != TCL_OK - || Tcl_GetIntFromObj(interp, objv[4], &count) != TCL_OK) { + if (Tcl_GetWideIntFromObj(interp, objv[3], &first) != TCL_OK + || Tcl_GetWideIntFromObj(interp, objv[4], &count) != TCL_OK) { return TCL_ERROR; } if (Tcl_IsShared(varPtr[varIndex])) { @@ -961,8 +949,9 @@ TestobjCmd( int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - int varIndex, destIndex, i; - const char *index, *subCmd, *string; + size_t varIndex, destIndex; + int i; + const char *subCmd; const Tcl_ObjType *targetType; Tcl_Obj **varPtr; @@ -978,15 +967,13 @@ TestobjCmd( if (objc != 4) { goto wrongNumArgs; } - index = Tcl_GetString(objv[2]); - if (GetVariableIndex(interp, index, &varIndex) != TCL_OK) { + if (GetVariableIndex(interp, objv[2], &varIndex) != TCL_OK) { return TCL_ERROR; } if (CheckIfVarUnset(interp, varPtr,varIndex)) { return TCL_ERROR; } - string = Tcl_GetString(objv[3]); - if (GetVariableIndex(interp, string, &destIndex) != TCL_OK) { + if (GetVariableIndex(interp, objv[3], &destIndex) != TCL_OK) { return TCL_ERROR; } SetVarToObj(varPtr, destIndex, varPtr[varIndex]); @@ -996,29 +983,26 @@ TestobjCmd( if (objc != 2) { goto wrongNumArgs; } - elemObjPtr = Tcl_NewIntObj(123); + elemObjPtr = Tcl_NewWideIntObj(123); listObjPtr = Tcl_NewListObj(1, &elemObjPtr); /* Replace the single list element through itself, nonsense but legal. */ Tcl_ListObjReplace(interp, listObjPtr, 0, 1, 1, &elemObjPtr); Tcl_SetObjResult(interp, listObjPtr); return TCL_OK; } else if (strcmp(subCmd, "convert") == 0) { - const char *typeName; if (objc != 4) { goto wrongNumArgs; } - index = Tcl_GetString(objv[2]); - if (GetVariableIndex(interp, index, &varIndex) != TCL_OK) { + if (GetVariableIndex(interp, objv[2], &varIndex) != TCL_OK) { return TCL_ERROR; } if (CheckIfVarUnset(interp, varPtr,varIndex)) { return TCL_ERROR; } - typeName = Tcl_GetString(objv[3]); - if ((targetType = Tcl_GetObjType(typeName)) == NULL) { + if ((targetType = Tcl_GetObjType(Tcl_GetString(objv[3]))) == NULL) { Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), - "no type ", typeName, " found", NULL); + "no type ", Tcl_GetString(objv[3]), " found", NULL); return TCL_ERROR; } if (Tcl_ConvertToType(interp, varPtr[varIndex], targetType) @@ -1030,15 +1014,13 @@ TestobjCmd( if (objc != 4) { goto wrongNumArgs; } - index = Tcl_GetString(objv[2]); - if (GetVariableIndex(interp, index, &varIndex) != TCL_OK) { + if (GetVariableIndex(interp, objv[2], &varIndex) != TCL_OK) { return TCL_ERROR; } if (CheckIfVarUnset(interp, varPtr,varIndex)) { return TCL_ERROR; } - string = Tcl_GetString(objv[3]); - if (GetVariableIndex(interp, string, &destIndex) != TCL_OK) { + if (GetVariableIndex(interp, objv[3], &destIndex) != TCL_OK) { return TCL_ERROR; } SetVarToObj(varPtr, destIndex, Tcl_DuplicateObj(varPtr[varIndex])); @@ -1057,8 +1039,7 @@ TestobjCmd( if (objc != 3) { goto wrongNumArgs; } - index = Tcl_GetString(objv[2]); - if (GetVariableIndex(interp, index, &varIndex) != TCL_OK) { + if (GetVariableIndex(interp, objv[2], &varIndex) != TCL_OK) { return TCL_ERROR; } if (CheckIfVarUnset(interp, varPtr,varIndex)) { @@ -1070,8 +1051,7 @@ TestobjCmd( if (objc != 3) { goto wrongNumArgs; } - index = Tcl_GetString(objv[2]); - if (GetVariableIndex(interp, index, &varIndex) != TCL_OK) { + if (GetVariableIndex(interp, objv[2], &varIndex) != TCL_OK) { return TCL_ERROR; } SetVarToObj(varPtr, varIndex, Tcl_NewObj()); @@ -1100,8 +1080,7 @@ TestobjCmd( if (objc != 3) { goto wrongNumArgs; } - index = Tcl_GetString(objv[2]); - if (GetVariableIndex(interp, index, &varIndex) != TCL_OK) { + if (GetVariableIndex(interp, objv[2], &varIndex) != TCL_OK) { return TCL_ERROR; } if (CheckIfVarUnset(interp, varPtr,varIndex)) { @@ -1112,8 +1091,7 @@ TestobjCmd( if (objc != 3) { goto wrongNumArgs; } - index = Tcl_GetString(objv[2]); - if (GetVariableIndex(interp, index, &varIndex) != TCL_OK) { + if (GetVariableIndex(interp, objv[2], &varIndex) != TCL_OK) { return TCL_ERROR; } if (CheckIfVarUnset(interp, varPtr,varIndex)) { @@ -1174,10 +1152,11 @@ TeststringobjCmd( Tcl_Obj *const objv[]) /* Argument objects. */ { Tcl_UniChar *unicode; - int varIndex, option, i, length; - int size; + size_t varIndex; + int size, option, i; + Tcl_WideInt length; #define MAX_STRINGS 11 - const char *index, *string, *strings[MAX_STRINGS+1]; + const char *string, *strings[MAX_STRINGS+1]; String *strPtr; Tcl_Obj **varPtr; static const char *const options[] = { @@ -1193,8 +1172,7 @@ TeststringobjCmd( } varPtr = GetVarPtr(interp); - index = Tcl_GetString(objv[2]); - if (GetVariableIndex(interp, index, &varIndex) != TCL_OK) { + if (GetVariableIndex(interp, objv[2], &varIndex) != TCL_OK) { return TCL_ERROR; } @@ -1207,7 +1185,7 @@ TeststringobjCmd( if (objc != 5) { goto wrongNumArgs; } - if (Tcl_GetIntFromObj(interp, objv[4], &length) != TCL_OK) { + if (Tcl_GetWideIntFromObj(interp, objv[4], &length) != TCL_OK) { return TCL_ERROR; } if (varPtr[varIndex] == NULL) { @@ -1222,8 +1200,7 @@ TeststringobjCmd( if (Tcl_IsShared(varPtr[varIndex])) { SetVarToObj(varPtr, varIndex, Tcl_DuplicateObj(varPtr[varIndex])); } - string = Tcl_GetString(objv[3]); - Tcl_AppendToObj(varPtr[varIndex], string, length); + Tcl_AppendToObj(varPtr[varIndex], Tcl_GetString(objv[3]), length); Tcl_SetObjResult(interp, varPtr[varIndex]); break; case 1: /* appendstrings */ @@ -1270,14 +1247,13 @@ TeststringobjCmd( if (CheckIfVarUnset(interp, varPtr, varIndex)) { return TCL_ERROR; } - string = Tcl_GetString(varPtr[varIndex]); - Tcl_AppendToObj(Tcl_GetObjResult(interp), string, -1); + Tcl_AppendToObj(Tcl_GetObjResult(interp), Tcl_GetString(varPtr[varIndex]), -1); break; case 4: /* length */ if (objc != 3) { goto wrongNumArgs; } - Tcl_SetIntObj(Tcl_GetObjResult(interp), (varPtr[varIndex] != NULL) + Tcl_SetWideIntObj(Tcl_GetObjResult(interp), (varPtr[varIndex] != NULL) ? varPtr[varIndex]->length : -1); break; case 5: /* length2 */ @@ -1292,7 +1268,7 @@ TeststringobjCmd( } else { length = -1; } - Tcl_SetIntObj(Tcl_GetObjResult(interp), length); + Tcl_SetWideIntObj(Tcl_GetObjResult(interp), length); break; case 6: /* set */ if (objc != 4) { @@ -1327,7 +1303,7 @@ TeststringobjCmd( if (objc != 4) { goto wrongNumArgs; } - if (Tcl_GetIntFromObj(interp, objv[3], &length) != TCL_OK) { + if (Tcl_GetWideIntFromObj(interp, objv[3], &length) != TCL_OK) { return TCL_ERROR; } if (varPtr[varIndex] != NULL) { @@ -1346,7 +1322,7 @@ TeststringobjCmd( } else { length = -1; } - Tcl_SetIntObj(Tcl_GetObjResult(interp), length); + Tcl_SetWideIntObj(Tcl_GetObjResult(interp), length); break; case 10: /* appendself */ if (objc != 4) { @@ -1367,16 +1343,16 @@ TeststringobjCmd( string = Tcl_GetStringFromObj(varPtr[varIndex], &size); - if (Tcl_GetIntFromObj(interp, objv[3], &i) != TCL_OK) { + if (Tcl_GetWideIntFromObj(interp, objv[3], &length) != TCL_OK) { return TCL_ERROR; } - if ((i < 0) || (i > size)) { + if ((length < 0) || (length > size)) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "index value out of range", -1)); return TCL_ERROR; } - Tcl_AppendToObj(varPtr[varIndex], string + i, size - i); + Tcl_AppendToObj(varPtr[varIndex], string + length, size - length); Tcl_SetObjResult(interp, varPtr[varIndex]); break; case 11: /* appendself2 */ @@ -1398,16 +1374,16 @@ TeststringobjCmd( unicode = Tcl_GetUnicodeFromObj(varPtr[varIndex], &size); - if (Tcl_GetIntFromObj(interp, objv[3], &i) != TCL_OK) { + if (Tcl_GetWideIntFromObj(interp, objv[3], &length) != TCL_OK) { return TCL_ERROR; } - if ((i < 0) || (i > size)) { + if ((length < 0) || (length > size)) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "index value out of range", -1)); return TCL_ERROR; } - Tcl_AppendUnicodeToObj(varPtr[varIndex], unicode + i, size - i); + Tcl_AppendUnicodeToObj(varPtr[varIndex], unicode + length, size - length); Tcl_SetObjResult(interp, varPtr[varIndex]); break; } @@ -1437,7 +1413,7 @@ TeststringobjCmd( static void SetVarToObj( Tcl_Obj **varPtr, - int varIndex, /* Designates the assignment variable. */ + size_t varIndex, /* Designates the assignment variable. */ Tcl_Obj *objPtr) /* Points to object to assign to var. */ { if (varPtr[varIndex] != NULL) { @@ -1468,14 +1444,14 @@ SetVarToObj( static int GetVariableIndex( Tcl_Interp *interp, /* Interpreter for error reporting. */ - const char *string, /* String containing a variable index + Tcl_Obj *obj, /* The variable index * specified as a nonnegative number less than * NUMBER_OF_OBJECT_VARS. */ - int *indexPtr) /* Place to store converted result. */ + size_t *indexPtr) /* Place to store converted result. */ { - int index; + Tcl_WideInt index; - if (Tcl_GetInt(interp, string, &index) != TCL_OK) { + if (Tcl_GetWideIntFromObj(interp, obj, &index) != TCL_OK) { return TCL_ERROR; } if (index < 0 || index >= NUMBER_OF_OBJECT_VARS) { @@ -1510,12 +1486,12 @@ static int CheckIfVarUnset( Tcl_Interp *interp, /* Interpreter for error reporting. */ Tcl_Obj ** varPtr, - int varIndex) /* Index of the test variable to check. */ + size_t varIndex) /* Index of the test variable to check. */ { if (varPtr[varIndex] == NULL) { char buf[32 + TCL_INTEGER_SPACE]; - sprintf(buf, "variable %d is unset (NULL)", varIndex); + sprintf(buf, "variable %" TCL_Z_MODIFIER "u is unset (NULL)", varIndex); Tcl_ResetResult(interp); Tcl_AppendToObj(Tcl_GetObjResult(interp), buf, -1); return 1; -- cgit v0.12 From b930863d81a04fae5e0e87303762437ce92b585a Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 9 Mar 2022 17:53:46 +0000 Subject: More progress --- generic/tclAssembly.c | 60 +++++++++++++-------------- generic/tclCompCmds.c | 78 +++++++++++++++++------------------ generic/tclCompCmdsGR.c | 100 ++++++++++++++++++++++----------------------- generic/tclCompCmdsSZ.c | 104 +++++++++++++++++++++++------------------------ generic/tclCompile.c | 40 +++++++++--------- generic/tclCompile.h | 16 ++++---- generic/tclDisassemble.c | 12 +++--- generic/tclEnsemble.c | 24 +++++------ generic/tclExecute.c | 14 +++---- 9 files changed, 224 insertions(+), 224 deletions(-) diff --git a/generic/tclAssembly.c b/generic/tclAssembly.c index b8a4606..3351104 100644 --- a/generic/tclAssembly.c +++ b/generic/tclAssembly.c @@ -1074,7 +1074,7 @@ TclAssembleCode( * Process the line of code. */ - if ((int)parsePtr->numWords > 0) { + if (parsePtr->numWords + 1 > 1) { size_t instLen = (int)parsePtr->commandSize; /* Length in bytes of the current command */ @@ -1304,7 +1304,7 @@ AssembleOneLine( switch (instType) { case ASSEM_PUSH: - if ((int)parsePtr->numWords != 2) { + if (parsePtr->numWords != 2) { Tcl_WrongNumArgs(interp, 1, &instNameObj, "value"); goto cleanup; } @@ -1317,7 +1317,7 @@ AssembleOneLine( break; case ASSEM_1BYTE: - if ((int)parsePtr->numWords != 1) { + if (parsePtr->numWords != 1) { Tcl_WrongNumArgs(interp, 1, &instNameObj, ""); goto cleanup; } @@ -1332,7 +1332,7 @@ AssembleOneLine( * are being resolved. */ - if ((int)parsePtr->numWords != 2) { + if (parsePtr->numWords != 2) { Tcl_WrongNumArgs(interp, 1, &instNameObj, "label"); goto cleanup; } @@ -1347,7 +1347,7 @@ AssembleOneLine( break; case ASSEM_BOOL: - if ((int)parsePtr->numWords != 2) { + if (parsePtr->numWords != 2) { Tcl_WrongNumArgs(interp, 1, &instNameObj, "boolean"); goto cleanup; } @@ -1358,7 +1358,7 @@ AssembleOneLine( break; case ASSEM_BOOL_LVT4: - if ((int)parsePtr->numWords != 3) { + if (parsePtr->numWords != 3) { Tcl_WrongNumArgs(interp, 1, &instNameObj, "boolean varName"); goto cleanup; } @@ -1374,7 +1374,7 @@ AssembleOneLine( break; case ASSEM_CLOCK_READ: - if ((int)parsePtr->numWords != 2) { + if (parsePtr->numWords != 2) { Tcl_WrongNumArgs(interp, 1, &instNameObj, "imm8"); goto cleanup; } @@ -1391,7 +1391,7 @@ AssembleOneLine( break; case ASSEM_CONCAT1: - if ((int)parsePtr->numWords != 2) { + if (parsePtr->numWords != 2) { Tcl_WrongNumArgs(interp, 1, &instNameObj, "imm8"); goto cleanup; } @@ -1405,7 +1405,7 @@ AssembleOneLine( case ASSEM_DICT_GET: case ASSEM_DICT_GET_DEF: - if ((int)parsePtr->numWords != 2) { + if (parsePtr->numWords != 2) { Tcl_WrongNumArgs(interp, 1, &instNameObj, "count"); goto cleanup; } @@ -1417,7 +1417,7 @@ AssembleOneLine( break; case ASSEM_DICT_SET: - if ((int)parsePtr->numWords != 3) { + if (parsePtr->numWords != 3) { Tcl_WrongNumArgs(interp, 1, &instNameObj, "count varName"); goto cleanup; } @@ -1434,7 +1434,7 @@ AssembleOneLine( break; case ASSEM_DICT_UNSET: - if ((int)parsePtr->numWords != 3) { + if (parsePtr->numWords != 3) { Tcl_WrongNumArgs(interp, 1, &instNameObj, "count varName"); goto cleanup; } @@ -1451,7 +1451,7 @@ AssembleOneLine( break; case ASSEM_END_CATCH: - if ((int)parsePtr->numWords != 1) { + if (parsePtr->numWords != 1) { Tcl_WrongNumArgs(interp, 1, &instNameObj, ""); goto cleanup; } @@ -1465,7 +1465,7 @@ AssembleOneLine( * code, the message ("script" or "expression") and an evaluator * callback that calls TclCompileScript or TclCompileExpr. */ - if ((int)parsePtr->numWords != 2) { + if (parsePtr->numWords != 2) { Tcl_WrongNumArgs(interp, 1, &instNameObj, ((TalInstructionTable[tblIdx].tclInstCode == INST_EVAL_STK) ? "script" : "expression")); @@ -1491,7 +1491,7 @@ AssembleOneLine( break; case ASSEM_INVOKE: - if ((int)parsePtr->numWords != 2) { + if (parsePtr->numWords != 2) { Tcl_WrongNumArgs(interp, 1, &instNameObj, "count"); goto cleanup; } @@ -1505,7 +1505,7 @@ AssembleOneLine( case ASSEM_JUMP: case ASSEM_JUMP4: - if ((int)parsePtr->numWords != 2) { + if (parsePtr->numWords != 2) { Tcl_WrongNumArgs(interp, 1, &instNameObj, "label"); goto cleanup; } @@ -1533,7 +1533,7 @@ AssembleOneLine( break; case ASSEM_JUMPTABLE: - if ((int)parsePtr->numWords != 2) { + if (parsePtr->numWords != 2) { Tcl_WrongNumArgs(interp, 1, &instNameObj, "table"); goto cleanup; } @@ -1561,7 +1561,7 @@ AssembleOneLine( break; case ASSEM_LABEL: - if ((int)parsePtr->numWords != 2) { + if (parsePtr->numWords != 2) { Tcl_WrongNumArgs(interp, 1, &instNameObj, "name"); goto cleanup; } @@ -1579,7 +1579,7 @@ AssembleOneLine( break; case ASSEM_LINDEX_MULTI: - if ((int)parsePtr->numWords != 2) { + if (parsePtr->numWords != 2) { Tcl_WrongNumArgs(interp, 1, &instNameObj, "count"); goto cleanup; } @@ -1591,7 +1591,7 @@ AssembleOneLine( break; case ASSEM_LIST: - if ((int)parsePtr->numWords != 2) { + if (parsePtr->numWords != 2) { Tcl_WrongNumArgs(interp, 1, &instNameObj, "count"); goto cleanup; } @@ -1603,7 +1603,7 @@ AssembleOneLine( break; case ASSEM_INDEX: - if ((int)parsePtr->numWords != 2) { + if (parsePtr->numWords != 2) { Tcl_WrongNumArgs(interp, 1, &instNameObj, "count"); goto cleanup; } @@ -1614,7 +1614,7 @@ AssembleOneLine( break; case ASSEM_LSET_FLAT: - if ((int)parsePtr->numWords != 2) { + if (parsePtr->numWords != 2) { Tcl_WrongNumArgs(interp, 1, &instNameObj, "count"); goto cleanup; } @@ -1633,7 +1633,7 @@ AssembleOneLine( break; case ASSEM_LVT: - if ((int)parsePtr->numWords != 2) { + if (parsePtr->numWords != 2) { Tcl_WrongNumArgs(interp, 1, &instNameObj, "varname"); goto cleanup; } @@ -1645,7 +1645,7 @@ AssembleOneLine( break; case ASSEM_LVT1: - if ((int)parsePtr->numWords != 2) { + if (parsePtr->numWords != 2) { Tcl_WrongNumArgs(interp, 1, &instNameObj, "varname"); goto cleanup; } @@ -1657,7 +1657,7 @@ AssembleOneLine( break; case ASSEM_LVT1_SINT1: - if ((int)parsePtr->numWords != 3) { + if (parsePtr->numWords != 3) { Tcl_WrongNumArgs(interp, 1, &instNameObj, "varName imm8"); goto cleanup; } @@ -1672,7 +1672,7 @@ AssembleOneLine( break; case ASSEM_LVT4: - if ((int)parsePtr->numWords != 2) { + if (parsePtr->numWords != 2) { Tcl_WrongNumArgs(interp, 1, &instNameObj, "varname"); goto cleanup; } @@ -1684,7 +1684,7 @@ AssembleOneLine( break; case ASSEM_OVER: - if ((int)parsePtr->numWords != 2) { + if (parsePtr->numWords != 2) { Tcl_WrongNumArgs(interp, 1, &instNameObj, "count"); goto cleanup; } @@ -1696,7 +1696,7 @@ AssembleOneLine( break; case ASSEM_REGEXP: - if ((int)parsePtr->numWords != 2) { + if (parsePtr->numWords != 2) { Tcl_WrongNumArgs(interp, 1, &instNameObj, "boolean"); goto cleanup; } @@ -1709,7 +1709,7 @@ AssembleOneLine( break; case ASSEM_REVERSE: - if ((int)parsePtr->numWords != 2) { + if (parsePtr->numWords != 2) { Tcl_WrongNumArgs(interp, 1, &instNameObj, "count"); goto cleanup; } @@ -1721,7 +1721,7 @@ AssembleOneLine( break; case ASSEM_SINT1: - if ((int)parsePtr->numWords != 2) { + if (parsePtr->numWords != 2) { Tcl_WrongNumArgs(interp, 1, &instNameObj, "imm8"); goto cleanup; } @@ -1733,7 +1733,7 @@ AssembleOneLine( break; case ASSEM_SINT4_LVT4: - if ((int)parsePtr->numWords != 3) { + if (parsePtr->numWords != 3) { Tcl_WrongNumArgs(interp, 1, &instNameObj, "count varName"); goto cleanup; } diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c index c9a5724..1da0b90 100644 --- a/generic/tclCompCmds.c +++ b/generic/tclCompCmds.c @@ -255,7 +255,7 @@ TclCompileArrayExistsCmd( Tcl_Token *tokenPtr; int isScalar, localIndex; - if ((int)parsePtr->numWords != 2) { + if (parsePtr->numWords != 2) { return TCL_ERROR; } @@ -293,7 +293,7 @@ TclCompileArraySetCmd( Tcl_Obj *literalObj; ForeachInfo *infoPtr; - if ((int)parsePtr->numWords != 3) { + if (parsePtr->numWords != 3) { return TCL_ERROR; } @@ -461,7 +461,7 @@ TclCompileArrayUnsetCmd( Tcl_Token *tokenPtr = TokenAfter(parsePtr->tokenPtr); int isScalar, localIndex; - if ((int)parsePtr->numWords != 2) { + if (parsePtr->numWords != 2) { return TclCompileBasic2ArgCmd(interp, parsePtr, cmdPtr, envPtr); } @@ -519,7 +519,7 @@ TclCompileBreakCmd( ExceptionRange *rangePtr; ExceptionAux *auxPtr; - if ((int)parsePtr->numWords != 1) { + if (parsePtr->numWords != 1) { return TCL_ERROR; } @@ -584,7 +584,7 @@ TclCompileCatchCmd( * Let runtime checks determine if syntax has changed. */ - if (((int)parsePtr->numWords < 2) || ((int)parsePtr->numWords > 4)) { + if ((parsePtr->numWords < 2) || (parsePtr->numWords > 4)) { return TCL_ERROR; } @@ -613,7 +613,7 @@ TclCompileCatchCmd( } /* DKF */ - if ((int)parsePtr->numWords == 4) { + if (parsePtr->numWords == 4) { optsNameTokenPtr = TokenAfter(resultNameTokenPtr); optsIndex = LocalScalarFromToken(optsNameTokenPtr, envPtr); if (optsIndex < 0) { @@ -687,7 +687,7 @@ TclCompileCatchCmd( /* Stack at this point on both branches: result returnCode */ if (TclFixupForwardJumpToHere(envPtr, &jumpFixup, 127)) { - Tcl_Panic("TclCompileCatchCmd: bad jump distance %" TCL_Z_MODIFIER "d", + Tcl_Panic("TclCompileCatchCmd: bad jump distance %" TCL_Z_MODIFIER "u", (CurrentOffset(envPtr) - jumpFixup.codeOffset)); } @@ -821,7 +821,7 @@ TclCompileClockReadingCmd( * compiled. */ CompileEnv *envPtr) /* Holds resulting instructions. */ { - if ((int)parsePtr->numWords != 1) { + if (parsePtr->numWords != 1) { return TCL_ERROR; } @@ -862,7 +862,7 @@ TclCompileConcatCmd( int i; /* TODO: Consider compiling expansion case. */ - if ((int)parsePtr->numWords == 1) { + if (parsePtr->numWords == 1) { /* * [concat] without arguments just pushes an empty object. */ @@ -949,7 +949,7 @@ TclCompileContinueCmd( * There should be no argument after the "continue". */ - if ((int)parsePtr->numWords != 1) { + if (parsePtr->numWords != 1) { return TCL_ERROR; } @@ -1043,7 +1043,7 @@ TclCompileDictSetCmd( * Now emit the instruction to do the dict manipulation. */ - TclEmitInstInt4( INST_DICT_SET, (int)parsePtr->numWords-3, envPtr); + TclEmitInstInt4( INST_DICT_SET, parsePtr->numWords-3, envPtr); TclEmitInt4( dictVarIndex, envPtr); TclAdjustStackDepth(-1, envPtr); return TCL_OK; @@ -1066,7 +1066,7 @@ TclCompileDictIncrCmd( * There must be at least two arguments after the command. */ - if ((int)parsePtr->numWords < 3 || (int)parsePtr->numWords > 4) { + if (parsePtr->numWords < 3 || parsePtr->numWords > 4) { return TCL_ERROR; } varTokenPtr = TokenAfter(parsePtr->tokenPtr); @@ -1076,7 +1076,7 @@ TclCompileDictIncrCmd( * Parse the increment amount, if present. */ - if ((int)parsePtr->numWords == 4) { + if (parsePtr->numWords == 4) { const char *word; size_t numBytes; int code; @@ -1153,7 +1153,7 @@ TclCompileDictGetCmd( CompileWord(envPtr, tokenPtr, interp, i); tokenPtr = TokenAfter(tokenPtr); } - TclEmitInstInt4(INST_DICT_GET, (int)parsePtr->numWords-2, envPtr); + TclEmitInstInt4(INST_DICT_GET, parsePtr->numWords-2, envPtr); TclAdjustStackDepth(-1, envPtr); return TCL_OK; } @@ -1184,7 +1184,7 @@ TclCompileDictGetWithDefaultCmd( CompileWord(envPtr, tokenPtr, interp, i); tokenPtr = TokenAfter(tokenPtr); } - TclEmitInstInt4(INST_DICT_GET_DEF, (int)parsePtr->numWords-3, envPtr); + TclEmitInstInt4(INST_DICT_GET_DEF, parsePtr->numWords-3, envPtr); TclAdjustStackDepth(-2, envPtr); return TCL_OK; } @@ -1220,7 +1220,7 @@ TclCompileDictExistsCmd( CompileWord(envPtr, tokenPtr, interp, i); tokenPtr = TokenAfter(tokenPtr); } - TclEmitInstInt4(INST_DICT_EXISTS, (int)parsePtr->numWords-2, envPtr); + TclEmitInstInt4(INST_DICT_EXISTS, parsePtr->numWords-2, envPtr); TclAdjustStackDepth(-1, envPtr); return TCL_OK; } @@ -1273,7 +1273,7 @@ TclCompileDictUnsetCmd( * Now emit the instruction to do the dict manipulation. */ - TclEmitInstInt4( INST_DICT_UNSET, (int)parsePtr->numWords-2, envPtr); + TclEmitInstInt4( INST_DICT_UNSET, parsePtr->numWords-2, envPtr); TclEmitInt4( dictVarIndex, envPtr); return TCL_OK; } @@ -1295,7 +1295,7 @@ TclCompileDictCreateCmd( int i; size_t len; - if (((int)parsePtr->numWords & 1) == 0) { + if ((parsePtr->numWords & 1) == 0) { return TCL_ERROR; } @@ -1394,7 +1394,7 @@ TclCompileDictMergeCmd( if ((int)parsePtr->numWords < 2) { PushStringLiteral(envPtr, ""); return TCL_OK; - } else if ((int)parsePtr->numWords == 2) { + } else if (parsePtr->numWords == 2) { tokenPtr = TokenAfter(parsePtr->tokenPtr); CompileWord(envPtr, tokenPtr, interp, 1); TclEmitOpcode( INST_DUP, envPtr); @@ -1539,7 +1539,7 @@ CompileDictEachCmd( * There must be three arguments after the command. */ - if ((int)parsePtr->numWords != 4) { + if (parsePtr->numWords != 4) { return TclCompileBasic3ArgCmd(interp, parsePtr, cmdPtr, envPtr); } @@ -1770,10 +1770,10 @@ TclCompileDictUpdateCmd( * dict update ? ...? */ - if (((int)parsePtr->numWords - 1) & 1) { + if ((parsePtr->numWords - 1) & 1) { return TCL_ERROR; } - numVars = ((int)parsePtr->numWords - 3) / 2; + numVars = (parsePtr->numWords - 3) / 2; /* * The dictionary variable must be a local scalar that is knowable at @@ -1840,7 +1840,7 @@ TclCompileDictUpdateCmd( TclEmitInstInt4( INST_BEGIN_CATCH4, range, envPtr); ExceptionRangeStarts(envPtr, range); - BODY(bodyTokenPtr, (int)parsePtr->numWords - 1); + BODY(bodyTokenPtr, parsePtr->numWords - 1); ExceptionRangeEnds(envPtr, range); /* @@ -1876,7 +1876,7 @@ TclCompileDictUpdateCmd( TclEmitInvoke(envPtr,INST_RETURN_STK); if (TclFixupForwardJumpToHere(envPtr, &jumpFixup, 127)) { - Tcl_Panic("TclCompileDictCmd(update): bad jump distance %" TCL_Z_MODIFIER "d", + Tcl_Panic("TclCompileDictCmd(update): bad jump distance %" TCL_Z_MODIFIER "u", CurrentOffset(envPtr) - jumpFixup.codeOffset); } TclStackFree(interp, keyTokenPtrs); @@ -1937,7 +1937,7 @@ TclCompileDictAppendCmd( tokenPtr = TokenAfter(tokenPtr); } if ((int)parsePtr->numWords > 4) { - TclEmitInstInt1(INST_STR_CONCAT1, (int)parsePtr->numWords-3, envPtr); + TclEmitInstInt1(INST_STR_CONCAT1, parsePtr->numWords-3, envPtr); } /* @@ -1967,7 +1967,7 @@ TclCompileDictLappendCmd( /* TODO: Consider support for compiling expanded args. */ /* Probably not. Why is INST_DICT_LAPPEND limited to one value? */ - if ((int)parsePtr->numWords != 4) { + if (parsePtr->numWords != 4) { return TCL_ERROR; } @@ -2076,7 +2076,7 @@ TclCompileDictWithCmd( CompileWord(envPtr, tokenPtr, interp, i); tokenPtr = TokenAfter(tokenPtr); } - TclEmitInstInt4(INST_LIST, (int)parsePtr->numWords-3,envPtr); + TclEmitInstInt4(INST_LIST, parsePtr->numWords-3,envPtr); Emit14Inst( INST_LOAD_SCALAR, dictVar, envPtr); TclEmitInstInt4(INST_OVER, 1, envPtr); TclEmitOpcode( INST_DICT_EXPAND, envPtr); @@ -2103,7 +2103,7 @@ TclCompileDictWithCmd( CompileWord(envPtr, tokenPtr, interp, i); tokenPtr = TokenAfter(tokenPtr); } - TclEmitInstInt4(INST_LIST, (int)parsePtr->numWords-3,envPtr); + TclEmitInstInt4(INST_LIST, parsePtr->numWords-3,envPtr); TclEmitInstInt4(INST_OVER, 1, envPtr); TclEmitOpcode( INST_LOAD_STK, envPtr); TclEmitInstInt4(INST_OVER, 1, envPtr); @@ -2158,7 +2158,7 @@ TclCompileDictWithCmd( CompileWord(envPtr, tokenPtr, interp, i); tokenPtr = TokenAfter(tokenPtr); } - TclEmitInstInt4( INST_LIST, (int)parsePtr->numWords-3,envPtr); + TclEmitInstInt4( INST_LIST, parsePtr->numWords-3,envPtr); Emit14Inst( INST_STORE_SCALAR, pathTmp, envPtr); TclEmitOpcode( INST_POP, envPtr); } @@ -2184,7 +2184,7 @@ TclCompileDictWithCmd( TclEmitInstInt4( INST_BEGIN_CATCH4, range, envPtr); ExceptionRangeStarts(envPtr, range); - BODY(tokenPtr, (int)parsePtr->numWords - 1); + BODY(tokenPtr, parsePtr->numWords - 1); ExceptionRangeEnds(envPtr, range); /* @@ -2238,7 +2238,7 @@ TclCompileDictWithCmd( */ if (TclFixupForwardJumpToHere(envPtr, &jumpFixup, 127)) { - Tcl_Panic("TclCompileDictCmd(update): bad jump distance %" TCL_Z_MODIFIER "d", + Tcl_Panic("TclCompileDictCmd(update): bad jump distance %" TCL_Z_MODIFIER "u", CurrentOffset(envPtr) - jumpFixup.codeOffset); } return TCL_OK; @@ -2374,13 +2374,13 @@ TclCompileErrorCmd( * Construct the options. Note that -code and -level are not here. */ - if ((int)parsePtr->numWords == 2) { + if (parsePtr->numWords == 2) { PushStringLiteral(envPtr, ""); } else { PushStringLiteral(envPtr, "-errorinfo"); tokenPtr = TokenAfter(tokenPtr); CompileWord(envPtr, tokenPtr, interp, 2); - if ((int)parsePtr->numWords == 3) { + if (parsePtr->numWords == 3) { TclEmitInstInt4( INST_LIST, 2, envPtr); } else { PushStringLiteral(envPtr, "-errorcode"); @@ -2427,7 +2427,7 @@ TclCompileExprCmd( { Tcl_Token *firstWordPtr; - if ((int)parsePtr->numWords == 1) { + if (parsePtr->numWords == 1) { return TCL_ERROR; } @@ -2439,7 +2439,7 @@ TclCompileExprCmd( envPtr->extCmdMapPtr->nuloc-1].line[1]; firstWordPtr = TokenAfter(parsePtr->tokenPtr); - TclCompileExprWords(interp, firstWordPtr, (int)parsePtr->numWords-1, envPtr); + TclCompileExprWords(interp, firstWordPtr, parsePtr->numWords-1, envPtr); return TCL_OK; } @@ -2475,7 +2475,7 @@ TclCompileForCmd( int bodyCodeOffset, nextCodeOffset, jumpDist; int bodyRange, nextRange; - if ((int)parsePtr->numWords != 5) { + if (parsePtr->numWords != 5) { return TCL_ERROR; } @@ -2702,7 +2702,7 @@ CompileEachloopCmd( return TCL_ERROR; } - numWords = (int)parsePtr->numWords; + numWords = parsePtr->numWords; if ((numWords < 4) || (numWords%2 != 0)) { return TCL_ERROR; } @@ -3179,7 +3179,7 @@ TclCompileFormatCmd( return TCL_ERROR; } - objv = (Tcl_Obj **)Tcl_Alloc(((int)parsePtr->numWords-2) * sizeof(Tcl_Obj *)); + objv = (Tcl_Obj **)Tcl_Alloc((parsePtr->numWords-2) * sizeof(Tcl_Obj *)); for (i=0 ; i+2 < (int)parsePtr->numWords ; i++) { tokenPtr = TokenAfter(tokenPtr); TclNewObj(objv[i]); @@ -3195,7 +3195,7 @@ TclCompileFormatCmd( */ tmpObj = Tcl_Format(interp, TclGetString(formatObj), - (int)parsePtr->numWords-2, objv); + parsePtr->numWords-2, objv); for (; --i>=0 ;) { Tcl_DecrRefCount(objv[i]); } diff --git a/generic/tclCompCmdsGR.c b/generic/tclCompCmdsGR.c index 6486b21..133e58f 100644 --- a/generic/tclCompCmdsGR.c +++ b/generic/tclCompCmdsGR.c @@ -95,7 +95,7 @@ TclCompileGlobalCmd( int localIndex, numWords, i; /* TODO: Consider support for compiling expanded args. */ - numWords = (int)parsePtr->numWords; + numWords = parsePtr->numWords; if (numWords < 2) { return TCL_ERROR; } @@ -196,7 +196,7 @@ TclCompileIfCmd( tokenPtr = parsePtr->tokenPtr; wordIdx = 0; - numWords = (int)parsePtr->numWords; + numWords = parsePtr->numWords; for (wordIdx = 0; wordIdx < numWords; wordIdx++) { if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { @@ -478,7 +478,7 @@ TclCompileIncrCmd( Tcl_Token *varTokenPtr, *incrTokenPtr; int isScalar, localIndex, haveImmValue, immValue; - if (((int)parsePtr->numWords != 2) && ((int)parsePtr->numWords != 3)) { + if ((parsePtr->numWords != 2) && (parsePtr->numWords != 3)) { return TCL_ERROR; } @@ -494,7 +494,7 @@ TclCompileIncrCmd( haveImmValue = 0; immValue = 1; - if ((int)parsePtr->numWords == 3) { + if (parsePtr->numWords == 3) { incrTokenPtr = TokenAfter(varTokenPtr); if (incrTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) { const char *word = incrTokenPtr[1].start; @@ -594,9 +594,9 @@ TclCompileInfoCommandsCmd( * We require one compile-time known argument for the case we can compile. */ - if ((int)parsePtr->numWords == 1) { + if (parsePtr->numWords == 1) { return TclCompileBasic0ArgCmd(interp, parsePtr, cmdPtr, envPtr); - } else if ((int)parsePtr->numWords != 2) { + } else if (parsePtr->numWords != 2) { return TCL_ERROR; } tokenPtr = TokenAfter(parsePtr->tokenPtr); @@ -649,7 +649,7 @@ TclCompileInfoCoroutineCmd( * Only compile [info coroutine] without arguments. */ - if ((int)parsePtr->numWords != 1) { + if (parsePtr->numWords != 1) { return TCL_ERROR; } @@ -673,7 +673,7 @@ TclCompileInfoExistsCmd( Tcl_Token *tokenPtr; int isScalar, localIndex; - if ((int)parsePtr->numWords != 2) { + if (parsePtr->numWords != 2) { return TCL_ERROR; } @@ -721,13 +721,13 @@ TclCompileInfoLevelCmd( * Only compile [info level] without arguments or with a single argument. */ - if ((int)parsePtr->numWords == 1) { + if (parsePtr->numWords == 1) { /* * Not much to do; we compile to a single instruction... */ TclEmitOpcode( INST_INFO_LEVEL_NUM, envPtr); - } else if ((int)parsePtr->numWords != 2) { + } else if (parsePtr->numWords != 2) { return TCL_ERROR; } else { DefineLineInformation; /* TIP #280 */ @@ -754,7 +754,7 @@ TclCompileInfoObjectClassCmd( DefineLineInformation; /* TIP #280 */ Tcl_Token *tokenPtr = TokenAfter(parsePtr->tokenPtr); - if ((int)parsePtr->numWords != 2) { + if (parsePtr->numWords != 2) { return TCL_ERROR; } CompileWord(envPtr, tokenPtr, interp, 1); @@ -779,7 +779,7 @@ TclCompileInfoObjectIsACmd( * engine. */ - if ((int)parsePtr->numWords != 3) { + if (parsePtr->numWords != 3) { return TCL_ERROR; } if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD || tokenPtr[1].size < 1 @@ -808,7 +808,7 @@ TclCompileInfoObjectNamespaceCmd( DefineLineInformation; /* TIP #280 */ Tcl_Token *tokenPtr = TokenAfter(parsePtr->tokenPtr); - if ((int)parsePtr->numWords != 2) { + if (parsePtr->numWords != 2) { return TCL_ERROR; } CompileWord(envPtr, tokenPtr, interp, 1); @@ -847,7 +847,7 @@ TclCompileLappendCmd( int isScalar, localIndex, numWords, i; /* TODO: Consider support for compiling expanded args. */ - numWords = (int)parsePtr->numWords; + numWords = parsePtr->numWords; if (numWords < 3) { return TCL_ERROR; } @@ -961,7 +961,7 @@ TclCompileLassignCmd( Tcl_Token *tokenPtr; int isScalar, localIndex, numWords, idx; - numWords = (int)parsePtr->numWords; + numWords = parsePtr->numWords; /* * Check for command syntax error, but we'll punt that to runtime. @@ -1062,7 +1062,7 @@ TclCompileLindexCmd( { DefineLineInformation; /* TIP #280 */ Tcl_Token *idxTokenPtr, *valTokenPtr; - int i, idx, numWords = (int)parsePtr->numWords; + int i, idx, numWords = parsePtr->numWords; /* * Quit if not enough args. @@ -1155,7 +1155,7 @@ TclCompileListCmd( int i, numWords, concat, build; Tcl_Obj *listObj, *objPtr; - if ((int)parsePtr->numWords == 1) { + if (parsePtr->numWords == 1) { /* * [list] without arguments just pushes an empty object. */ @@ -1169,7 +1169,7 @@ TclCompileListCmd( * implement with a simple push. */ - numWords = (int)parsePtr->numWords; + numWords = parsePtr->numWords; valueTokenPtr = TokenAfter(parsePtr->tokenPtr); TclNewObj(listObj); for (i = 1; i < numWords && listObj != NULL; i++) { @@ -1192,7 +1192,7 @@ TclCompileListCmd( * Push the all values onto the stack. */ - numWords = (int)parsePtr->numWords; + numWords = parsePtr->numWords; valueTokenPtr = TokenAfter(parsePtr->tokenPtr); concat = build = 0; for (i = 1; i < numWords; i++) { @@ -1266,7 +1266,7 @@ TclCompileLlengthCmd( DefineLineInformation; /* TIP #280 */ Tcl_Token *varTokenPtr; - if ((int)parsePtr->numWords != 2) { + if (parsePtr->numWords != 2) { return TCL_ERROR; } varTokenPtr = TokenAfter(parsePtr->tokenPtr); @@ -1299,7 +1299,7 @@ TclCompileLrangeCmd( Tcl_Token *tokenPtr, *listTokenPtr; int idx1, idx2; - if ((int)parsePtr->numWords != 4) { + if (parsePtr->numWords != 4) { return TCL_ERROR; } listTokenPtr = TokenAfter(parsePtr->tokenPtr); @@ -1392,7 +1392,7 @@ TclCompileLinsertCmd( */ CompileWord(envPtr, listTokenPtr, interp, 1); - if ((int)parsePtr->numWords == 3) { + if (parsePtr->numWords == 3) { TclEmitInstInt4( INST_LIST_RANGE_IMM, 0, envPtr); TclEmitInt4( (int)TCL_INDEX_END, envPtr); return TCL_OK; @@ -1524,7 +1524,7 @@ TclCompileLreplaceCmd( emptyPrefix = 0; } - if ((idx1 == suffixStart) && ((int)parsePtr->numWords == 4)) { + if ((idx1 == suffixStart) && (parsePtr->numWords == 4)) { /* * This is a "no-op". Example: [lreplace {a b c} 2 0] * We still do a list operation to get list-verification @@ -1669,9 +1669,9 @@ TclCompileLsetCmd( if (localIndex < 0) { if (isScalar) { - tempDepth = (int)parsePtr->numWords - 2; + tempDepth = parsePtr->numWords - 2; } else { - tempDepth = (int)parsePtr->numWords - 1; + tempDepth = parsePtr->numWords - 1; } TclEmitInstInt4( INST_OVER, tempDepth, envPtr); } @@ -1682,9 +1682,9 @@ TclCompileLsetCmd( if (!isScalar) { if (localIndex < 0) { - tempDepth = (int)parsePtr->numWords - 1; + tempDepth = parsePtr->numWords - 1; } else { - tempDepth = (int)parsePtr->numWords - 2; + tempDepth = parsePtr->numWords - 2; } TclEmitInstInt4( INST_OVER, tempDepth, envPtr); } @@ -1711,10 +1711,10 @@ TclCompileLsetCmd( * Emit the correct variety of 'lset' instruction. */ - if ((int)parsePtr->numWords == 4) { + if (parsePtr->numWords == 4) { TclEmitOpcode( INST_LSET_LIST, envPtr); } else { - TclEmitInstInt4( INST_LSET_FLAT, (int)parsePtr->numWords-1, envPtr); + TclEmitInstInt4( INST_LSET_FLAT, parsePtr->numWords-1, envPtr); } /* @@ -1770,7 +1770,7 @@ TclCompileNamespaceCurrentCmd( * Only compile [namespace current] without arguments. */ - if ((int)parsePtr->numWords != 1) { + if (parsePtr->numWords != 1) { return TCL_ERROR; } @@ -1793,7 +1793,7 @@ TclCompileNamespaceCodeCmd( DefineLineInformation; /* TIP #280 */ Tcl_Token *tokenPtr; - if ((int)parsePtr->numWords != 2) { + if (parsePtr->numWords != 2) { return TCL_ERROR; } tokenPtr = TokenAfter(parsePtr->tokenPtr); @@ -1842,7 +1842,7 @@ TclCompileNamespaceOriginCmd( DefineLineInformation; /* TIP #280 */ Tcl_Token *tokenPtr; - if ((int)parsePtr->numWords != 2) { + if (parsePtr->numWords != 2) { return TCL_ERROR; } tokenPtr = TokenAfter(parsePtr->tokenPtr); @@ -1864,7 +1864,7 @@ TclCompileNamespaceQualifiersCmd( Tcl_Token *tokenPtr = TokenAfter(parsePtr->tokenPtr); int off; - if ((int)parsePtr->numWords != 2) { + if (parsePtr->numWords != 2) { return TCL_ERROR; } @@ -1899,7 +1899,7 @@ TclCompileNamespaceTailCmd( Tcl_Token *tokenPtr = TokenAfter(parsePtr->tokenPtr); JumpFixup jumpFixup; - if ((int)parsePtr->numWords != 2) { + if (parsePtr->numWords != 2) { return TCL_ERROR; } @@ -1943,7 +1943,7 @@ TclCompileNamespaceUpvarCmd( * Only compile [namespace upvar ...]: needs an even number of args, >=4 */ - numWords = (int)parsePtr->numWords; + numWords = parsePtr->numWords; if ((numWords % 2) || (numWords < 4)) { return TCL_ERROR; } @@ -1995,7 +1995,7 @@ TclCompileNamespaceWhichCmd( Tcl_Token *tokenPtr, *opt; int idx; - if ((int)parsePtr->numWords < 2 || (int)parsePtr->numWords > 3) { + if (parsePtr->numWords < 2 || parsePtr->numWords > 3) { return TCL_ERROR; } tokenPtr = TokenAfter(parsePtr->tokenPtr); @@ -2006,7 +2006,7 @@ TclCompileNamespaceWhichCmd( * "-variable" (currently) and anything else is an error. */ - if ((int)parsePtr->numWords == 3) { + if (parsePtr->numWords == 3) { if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { return TCL_ERROR; } @@ -2109,7 +2109,7 @@ TclCompileRegexpCmd( } } - if (((int)parsePtr->numWords - i) != 2) { + if ((parsePtr->numWords - i) != 2) { /* * We don't support capturing to variables. */ @@ -2162,7 +2162,7 @@ TclCompileRegexpCmd( } if (!simple) { - CompileWord(envPtr, varTokenPtr, interp, (int)parsePtr->numWords - 2); + CompileWord(envPtr, varTokenPtr, interp, parsePtr->numWords - 2); } /* @@ -2170,7 +2170,7 @@ TclCompileRegexpCmd( */ varTokenPtr = TokenAfter(varTokenPtr); - CompileWord(envPtr, varTokenPtr, interp, (int)parsePtr->numWords - 1); + CompileWord(envPtr, varTokenPtr, interp, parsePtr->numWords - 1); if (simple) { if (exact && !nocase) { @@ -2247,7 +2247,7 @@ TclCompileRegsubCmd( int exact, quantified, result = TCL_ERROR; size_t len; - if ((int)parsePtr->numWords < 5 || (int)parsePtr->numWords > 6) { + if (parsePtr->numWords < 5 || parsePtr->numWords > 6) { return TCL_ERROR; } @@ -2274,7 +2274,7 @@ TclCompileRegsubCmd( } if (TclGetString(patternObj)[0] == '-') { if (strcmp(TclGetString(patternObj), "--") != 0 - || (int)parsePtr->numWords == 5) { + || parsePtr->numWords == 5) { goto done; } tokenPtr = TokenAfter(tokenPtr); @@ -2283,7 +2283,7 @@ TclCompileRegsubCmd( if (!TclWordKnownAtCompileTime(tokenPtr, patternObj)) { goto done; } - } else if ((int)parsePtr->numWords == 6) { + } else if (parsePtr->numWords == 6) { goto done; } @@ -2354,7 +2354,7 @@ TclCompileRegsubCmd( PushLiteral(envPtr, bytes, len); bytes = Tcl_GetStringFromObj(replacementObj, &len); PushLiteral(envPtr, bytes, len); - CompileWord(envPtr, stringTokenPtr, interp, (int)parsePtr->numWords - 2); + CompileWord(envPtr, stringTokenPtr, interp, parsePtr->numWords - 2); TclEmitOpcode( INST_STR_MAP, envPtr); done: @@ -2401,7 +2401,7 @@ TclCompileReturnCmd( */ int level, code, objc, status = TCL_OK; size_t size; - int numWords = (int)parsePtr->numWords; + int numWords = parsePtr->numWords; int explicitResult = (0 == (numWords % 2)); int numOptionWords = numWords - 1 - explicitResult; Tcl_Obj *returnOpts, **objv; @@ -2655,7 +2655,7 @@ TclCompileUpvarCmd( return TCL_ERROR; } - numWords = (int)parsePtr->numWords; + numWords = parsePtr->numWords; if (numWords < 3) { return TCL_ERROR; } @@ -2756,7 +2756,7 @@ TclCompileVariableCmd( Tcl_Token *varTokenPtr, *valueTokenPtr; int localIndex, numWords, i; - numWords = (int)parsePtr->numWords; + numWords = parsePtr->numWords; if (numWords < 2) { return TCL_ERROR; } @@ -2954,7 +2954,7 @@ TclCompileObjectNextToCmd( Tcl_Token *tokenPtr = parsePtr->tokenPtr; int i; - if ((int)parsePtr->numWords < 2 || (int)parsePtr->numWords > 255) { + if (parsePtr->numWords < 2 || parsePtr->numWords > 255) { return TCL_ERROR; } @@ -2980,9 +2980,9 @@ TclCompileObjectSelfCmd( * bytecoding is at all reasonable. */ - if ((int)parsePtr->numWords == 1) { + if (parsePtr->numWords == 1) { goto compileSelfObject; - } else if ((int)parsePtr->numWords == 2) { + } else if (parsePtr->numWords == 2) { Tcl_Token *tokenPtr = TokenAfter(parsePtr->tokenPtr), *subcmd; if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD || tokenPtr[1].size==0) { diff --git a/generic/tclCompCmdsSZ.c b/generic/tclCompCmdsSZ.c index 0e782ac..581df02 100644 --- a/generic/tclCompCmdsSZ.c +++ b/generic/tclCompCmdsSZ.c @@ -133,7 +133,7 @@ TclCompileSetCmd( Tcl_Token *varTokenPtr, *valueTokenPtr; int isAssignment, isScalar, localIndex, numWords; - numWords = (int)parsePtr->numWords; + numWords = parsePtr->numWords; if ((numWords != 2) && (numWords != 3)) { return TCL_ERROR; } @@ -223,7 +223,7 @@ TclCompileStringCatCmd( CompileEnv *envPtr) /* Holds resulting instructions. */ { DefineLineInformation; /* TIP #280 */ - int i, numWords = (int)parsePtr->numWords, numArgs; + int i, numWords = parsePtr->numWords, numArgs; Tcl_Token *wordTokenPtr; Tcl_Obj *obj, *folded; @@ -300,7 +300,7 @@ TclCompileStringCmpCmd( * We don't support any flags; the bytecode isn't that sophisticated. */ - if ((int)parsePtr->numWords != 3) { + if (parsePtr->numWords != 3) { return TCL_ERROR; } @@ -331,7 +331,7 @@ TclCompileStringEqualCmd( * We don't support any flags; the bytecode isn't that sophisticated. */ - if ((int)parsePtr->numWords != 3) { + if (parsePtr->numWords != 3) { return TCL_ERROR; } @@ -362,7 +362,7 @@ TclCompileStringFirstCmd( * We don't support any flags; the bytecode isn't that sophisticated. */ - if ((int)parsePtr->numWords != 3) { + if (parsePtr->numWords != 3) { return TCL_ERROR; } @@ -393,7 +393,7 @@ TclCompileStringLastCmd( * We don't support any flags; the bytecode isn't that sophisticated. */ - if ((int)parsePtr->numWords != 3) { + if (parsePtr->numWords != 3) { return TCL_ERROR; } @@ -420,7 +420,7 @@ TclCompileStringIndexCmd( DefineLineInformation; /* TIP #280 */ Tcl_Token *tokenPtr; - if ((int)parsePtr->numWords != 3) { + if (parsePtr->numWords != 3) { return TCL_ERROR; } @@ -448,7 +448,7 @@ TclCompileStringInsertCmd( Tcl_Token *tokenPtr; int idx; - if ((int)parsePtr->numWords != 4) { + if (parsePtr->numWords != 4) { return TCL_ERROR; } @@ -523,7 +523,7 @@ TclCompileStringIsCmd( InstStringClassType strClassType; Tcl_Obj *isClass; - if ((int)parsePtr->numWords < 3 || (int)parsePtr->numWords > 6) { + if (parsePtr->numWords < 3 || parsePtr->numWords > 6) { return TCL_ERROR; } TclNewObj(isClass); @@ -549,12 +549,12 @@ TclCompileStringIsCmd( * way to have more than 4 arguments. */ - if ((int)parsePtr->numWords != 3 && (int)parsePtr->numWords != 4) { + if (parsePtr->numWords != 3 && parsePtr->numWords != 4) { return TCL_ERROR; } tokenPtr = TokenAfter(tokenPtr); - if ((int)parsePtr->numWords == 3) { + if (parsePtr->numWords == 3) { allowEmpty = 1; } else { if (!GotLiteral(tokenPtr, "-strict")) { @@ -573,7 +573,7 @@ TclCompileStringIsCmd( * 5. Lists */ - CompileWord(envPtr, tokenPtr, interp, (int)parsePtr->numWords-1); + CompileWord(envPtr, tokenPtr, interp, parsePtr->numWords-1); switch ((enum isClassesEnum) t) { case STR_IS_ALNUM: @@ -798,7 +798,7 @@ TclCompileStringMatchCmd( int i, exactMatch = 0, nocase = 0; const char *str; - if ((int)parsePtr->numWords < 3 || (int)parsePtr->numWords > 4) { + if (parsePtr->numWords < 3 || parsePtr->numWords > 4) { return TCL_ERROR; } tokenPtr = TokenAfter(parsePtr->tokenPtr); @@ -807,7 +807,7 @@ TclCompileStringMatchCmd( * Check if we have a -nocase flag. */ - if ((int)parsePtr->numWords == 4) { + if (parsePtr->numWords == 4) { if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { return TclCompileBasic3ArgCmd(interp, parsePtr, cmdPtr, envPtr); } @@ -877,7 +877,7 @@ TclCompileStringLenCmd( Tcl_Token *tokenPtr; Tcl_Obj *objPtr; - if ((int)parsePtr->numWords != 2) { + if (parsePtr->numWords != 2) { return TCL_ERROR; } @@ -929,7 +929,7 @@ TclCompileStringMapCmd( * thing to map). */ - if ((int)parsePtr->numWords != 3) { + if (parsePtr->numWords != 3) { return TCL_ERROR; } mapTokenPtr = TokenAfter(parsePtr->tokenPtr); @@ -979,7 +979,7 @@ TclCompileStringRangeCmd( Tcl_Token *stringTokenPtr, *fromTokenPtr, *toTokenPtr; int idx1, idx2; - if ((int)parsePtr->numWords != 4) { + if (parsePtr->numWords != 4) { return TCL_ERROR; } stringTokenPtr = TokenAfter(parsePtr->tokenPtr); @@ -1054,7 +1054,7 @@ TclCompileStringReplaceCmd( Tcl_Token *tokenPtr, *valueTokenPtr; int first, last; - if ((int)parsePtr->numWords < 4 || (int)parsePtr->numWords > 5) { + if (parsePtr->numWords < 4 || parsePtr->numWords > 5) { return TCL_ERROR; } @@ -1119,7 +1119,7 @@ TclCompileStringReplaceCmd( */ || ((first >= (int)TCL_INDEX_START) && (last >= (int)TCL_INDEX_START) && (last < first))) { /* Know (last < first) */ - if ((int)parsePtr->numWords == 5) { + if (parsePtr->numWords == 5) { tokenPtr = TokenAfter(tokenPtr); CompileWord(envPtr, tokenPtr, interp, 4); OP( POP); /* Pop newString */ @@ -1128,7 +1128,7 @@ TclCompileStringReplaceCmd( return TCL_OK; } - if ((int)parsePtr->numWords == 5) { + if (parsePtr->numWords == 5) { /* * When we have a string replacement, we have to take care about * not replacing empty substrings that [string replace] promises @@ -1230,7 +1230,7 @@ TclCompileStringReplaceCmd( CompileWord(envPtr, tokenPtr, interp, 2); tokenPtr = TokenAfter(tokenPtr); CompileWord(envPtr, tokenPtr, interp, 3); - if ((int)parsePtr->numWords == 5) { + if (parsePtr->numWords == 5) { tokenPtr = TokenAfter(tokenPtr); CompileWord(envPtr, tokenPtr, interp, 4); } else { @@ -1251,13 +1251,13 @@ TclCompileStringTrimLCmd( DefineLineInformation; /* TIP #280 */ Tcl_Token *tokenPtr; - if ((int)parsePtr->numWords != 2 && (int)parsePtr->numWords != 3) { + if (parsePtr->numWords != 2 && parsePtr->numWords != 3) { return TCL_ERROR; } tokenPtr = TokenAfter(parsePtr->tokenPtr); CompileWord(envPtr, tokenPtr, interp, 1); - if ((int)parsePtr->numWords == 3) { + if (parsePtr->numWords == 3) { tokenPtr = TokenAfter(tokenPtr); CompileWord(envPtr, tokenPtr, interp, 2); } else { @@ -1278,13 +1278,13 @@ TclCompileStringTrimRCmd( DefineLineInformation; /* TIP #280 */ Tcl_Token *tokenPtr; - if ((int)parsePtr->numWords != 2 && (int)parsePtr->numWords != 3) { + if (parsePtr->numWords != 2 && parsePtr->numWords != 3) { return TCL_ERROR; } tokenPtr = TokenAfter(parsePtr->tokenPtr); CompileWord(envPtr, tokenPtr, interp, 1); - if ((int)parsePtr->numWords == 3) { + if (parsePtr->numWords == 3) { tokenPtr = TokenAfter(tokenPtr); CompileWord(envPtr, tokenPtr, interp, 2); } else { @@ -1305,13 +1305,13 @@ TclCompileStringTrimCmd( DefineLineInformation; /* TIP #280 */ Tcl_Token *tokenPtr; - if ((int)parsePtr->numWords != 2 && (int)parsePtr->numWords != 3) { + if (parsePtr->numWords != 2 && parsePtr->numWords != 3) { return TCL_ERROR; } tokenPtr = TokenAfter(parsePtr->tokenPtr); CompileWord(envPtr, tokenPtr, interp, 1); - if ((int)parsePtr->numWords == 3) { + if (parsePtr->numWords == 3) { tokenPtr = TokenAfter(tokenPtr); CompileWord(envPtr, tokenPtr, interp, 2); } else { @@ -1333,7 +1333,7 @@ TclCompileStringToUpperCmd( DefineLineInformation; /* TIP #280 */ Tcl_Token *tokenPtr; - if ((int)parsePtr->numWords != 2) { + if (parsePtr->numWords != 2) { return TclCompileBasic1To3ArgCmd(interp, parsePtr, cmdPtr, envPtr); } @@ -1355,7 +1355,7 @@ TclCompileStringToLowerCmd( DefineLineInformation; /* TIP #280 */ Tcl_Token *tokenPtr; - if ((int)parsePtr->numWords != 2) { + if (parsePtr->numWords != 2) { return TclCompileBasic1To3ArgCmd(interp, parsePtr, cmdPtr, envPtr); } @@ -1377,7 +1377,7 @@ TclCompileStringToTitleCmd( DefineLineInformation; /* TIP #280 */ Tcl_Token *tokenPtr; - if ((int)parsePtr->numWords != 2) { + if (parsePtr->numWords != 2) { return TclCompileBasic1To3ArgCmd(interp, parsePtr, cmdPtr, envPtr); } @@ -1452,7 +1452,7 @@ TclCompileSubstCmd( CompileEnv *envPtr) /* Holds resulting instructions. */ { DefineLineInformation; /* TIP #280 */ - int numArgs = (int)parsePtr->numWords - 1; + int numArgs = parsePtr->numWords - 1; int numOpts = numArgs - 1; int objc, flags = TCL_SUBST_ALL; Tcl_Obj **objv/*, *toSubst = NULL*/; @@ -1616,7 +1616,7 @@ TclSubstCompile( /* Start */ if (TclFixupForwardJumpToHere(envPtr, &startFixup, 127)) { - Tcl_Panic("TclCompileSubstCmd: bad start jump distance %" TCL_Z_MODIFIER "d", + Tcl_Panic("TclCompileSubstCmd: bad start jump distance %" TCL_Z_MODIFIER "u", CurrentOffset(envPtr) - startFixup.codeOffset); } } @@ -1675,7 +1675,7 @@ TclSubstCompile( TclAdjustStackDepth(1, envPtr); /* BREAK destination */ if (TclFixupForwardJumpToHere(envPtr, &breakFixup, 127)) { - Tcl_Panic("TclCompileSubstCmd: bad break jump distance %" TCL_Z_MODIFIER "d", + Tcl_Panic("TclCompileSubstCmd: bad break jump distance %" TCL_Z_MODIFIER "u", CurrentOffset(envPtr) - breakFixup.codeOffset); } OP( POP); @@ -1691,7 +1691,7 @@ TclSubstCompile( TclAdjustStackDepth(2, envPtr); /* CONTINUE destination */ if (TclFixupForwardJumpToHere(envPtr, &continueFixup, 127)) { - Tcl_Panic("TclCompileSubstCmd: bad continue jump distance %" TCL_Z_MODIFIER "d", + Tcl_Panic("TclCompileSubstCmd: bad continue jump distance %" TCL_Z_MODIFIER "u", CurrentOffset(envPtr) - continueFixup.codeOffset); } OP( POP); @@ -1701,11 +1701,11 @@ TclSubstCompile( TclAdjustStackDepth(2, envPtr); /* RETURN + other destination */ if (TclFixupForwardJumpToHere(envPtr, &returnFixup, 127)) { - Tcl_Panic("TclCompileSubstCmd: bad return jump distance %" TCL_Z_MODIFIER "d", + Tcl_Panic("TclCompileSubstCmd: bad return jump distance %" TCL_Z_MODIFIER "u", CurrentOffset(envPtr) - returnFixup.codeOffset); } if (TclFixupForwardJumpToHere(envPtr, &otherFixup, 127)) { - Tcl_Panic("TclCompileSubstCmd: bad other jump distance %" TCL_Z_MODIFIER "d", + Tcl_Panic("TclCompileSubstCmd: bad other jump distance %" TCL_Z_MODIFIER "u", CurrentOffset(envPtr) - otherFixup.codeOffset); } @@ -1718,7 +1718,7 @@ TclSubstCompile( /* OK destination */ if (TclFixupForwardJumpToHere(envPtr, &okFixup, 127)) { - Tcl_Panic("TclCompileSubstCmd: bad ok jump distance %" TCL_Z_MODIFIER "d", + Tcl_Panic("TclCompileSubstCmd: bad ok jump distance %" TCL_Z_MODIFIER "u", CurrentOffset(envPtr) - okFixup.codeOffset); } if (count > 1) { @@ -1728,7 +1728,7 @@ TclSubstCompile( /* CONTINUE jump to here */ if (TclFixupForwardJumpToHere(envPtr, &endFixup, 127)) { - Tcl_Panic("TclCompileSubstCmd: bad end jump distance %" TCL_Z_MODIFIER "d", + Tcl_Panic("TclCompileSubstCmd: bad end jump distance %" TCL_Z_MODIFIER "u", CurrentOffset(envPtr) - endFixup.codeOffset); } bline = envPtr->line; @@ -1822,7 +1822,7 @@ TclCompileSwitchCmd( tokenPtr = TokenAfter(parsePtr->tokenPtr); valueIndex = 1; - numWords = (int)parsePtr->numWords-1; + numWords = parsePtr->numWords-1; /* * Check for options. @@ -2664,7 +2664,7 @@ TclCompileTailcallCmd( Tcl_Token *tokenPtr = parsePtr->tokenPtr; int i; - if ((int)parsePtr->numWords < 2 || (int)parsePtr->numWords > 256 + if (parsePtr->numWords < 2 || parsePtr->numWords > 256 || envPtr->procPtr == NULL) { return TCL_ERROR; } @@ -2676,7 +2676,7 @@ TclCompileTailcallCmd( tokenPtr = TokenAfter(tokenPtr); CompileWord(envPtr, tokenPtr, interp, i); } - TclEmitInstInt1( INST_TAILCALL, (int)parsePtr->numWords, envPtr); + TclEmitInstInt1( INST_TAILCALL, parsePtr->numWords, envPtr); return TCL_OK; } @@ -2707,7 +2707,7 @@ TclCompileThrowCmd( CompileEnv *envPtr) /* Holds resulting instructions. */ { DefineLineInformation; /* TIP #280 */ - int numWords = (int)parsePtr->numWords; + int numWords = parsePtr->numWords; Tcl_Token *codeToken, *msgToken; Tcl_Obj *objPtr; int codeKnown, codeIsList, codeIsValid; @@ -2810,7 +2810,7 @@ TclCompileTryCmd( TCL_UNUSED(Command *), CompileEnv *envPtr) /* Holds resulting instructions. */ { - int numWords = (int)parsePtr->numWords, numHandlers, result = TCL_ERROR; + int numWords = parsePtr->numWords, numHandlers, result = TCL_ERROR; Tcl_Token *bodyToken, *finallyToken, *tokenPtr; Tcl_Token **handlerTokens = NULL; Tcl_Obj **matchClauses = NULL; @@ -3767,7 +3767,7 @@ TclCompileWhileCmd( * infinite loop. */ Tcl_Obj *boolObj; - if ((int)parsePtr->numWords != 3) { + if (parsePtr->numWords != 3) { return TCL_ERROR; } @@ -3936,11 +3936,11 @@ TclCompileYieldCmd( TCL_UNUSED(Command *), CompileEnv *envPtr) /* Holds resulting instructions. */ { - if ((int)parsePtr->numWords < 1 || (int)parsePtr->numWords > 2) { + if (parsePtr->numWords < 1 || parsePtr->numWords > 2) { return TCL_ERROR; } - if ((int)parsePtr->numWords == 1) { + if (parsePtr->numWords == 1) { PUSH(""); } else { DefineLineInformation; /* TIP #280 */ @@ -4024,7 +4024,7 @@ CompileUnaryOpCmd( DefineLineInformation; /* TIP #280 */ Tcl_Token *tokenPtr; - if ((int)parsePtr->numWords != 2) { + if (parsePtr->numWords != 2) { return TCL_ERROR; } tokenPtr = TokenAfter(parsePtr->tokenPtr); @@ -4116,7 +4116,7 @@ CompileStrictlyBinaryOpCmd( int instruction, CompileEnv *envPtr) { - if ((int)parsePtr->numWords != 3) { + if (parsePtr->numWords != 3) { return TCL_ERROR; } return CompileAssociativeBinaryOpCmd(interp, parsePtr, @@ -4154,7 +4154,7 @@ CompileComparisonOpCmd( /* TODO: Consider support for compiling expanded args. */ if ((int)parsePtr->numWords < 3) { PUSH("1"); - } else if ((int)parsePtr->numWords == 3) { + } else if (parsePtr->numWords == 3) { tokenPtr = TokenAfter(parsePtr->tokenPtr); CompileWord(envPtr, tokenPtr, interp, 1); tokenPtr = TokenAfter(tokenPtr); @@ -4508,7 +4508,7 @@ TclCompileMinusOpCmd( int words; /* TODO: Consider support for compiling expanded args. */ - if ((int)parsePtr->numWords == 1) { + if (parsePtr->numWords == 1) { /* * Fallback to direct eval to report syntax error. */ @@ -4553,14 +4553,14 @@ TclCompileDivOpCmd( int words; /* TODO: Consider support for compiling expanded args. */ - if ((int)parsePtr->numWords == 1) { + if (parsePtr->numWords == 1) { /* * Fallback to direct eval to report syntax error. */ return TCL_ERROR; } - if ((int)parsePtr->numWords == 2) { + if (parsePtr->numWords == 2) { PUSH("1.0"); } for (words=1 ; words<(int)parsePtr->numWords ; words++) { diff --git a/generic/tclCompile.c b/generic/tclCompile.c index e86a363..a34ce82 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -2044,7 +2044,7 @@ CompileCommandTokens( EnterCmdWordData(eclPtr, parsePtr->commandStart - envPtr->source, parsePtr->tokenPtr, parsePtr->commandStart, - (int)parsePtr->numWords, cmdLine, + parsePtr->numWords, cmdLine, clNext, &wlines, envPtr); wlineat = eclPtr->nuloc - 1; @@ -2071,7 +2071,7 @@ CompileCommandTokens( } } if (cmdPtr && !(cmdPtr->flags & CMD_COMPILES_EXPANDED)) { - expand = ExpandRequested(parsePtr->tokenPtr, (int)parsePtr->numWords); + expand = ExpandRequested(parsePtr->tokenPtr, parsePtr->numWords); if (expand) { /* We need to expand, but compileProc cannot. */ cmdPtr = NULL; @@ -2086,15 +2086,15 @@ CompileCommandTokens( if (code == TCL_ERROR) { if (expand < 0) { - expand = ExpandRequested(parsePtr->tokenPtr, (int)parsePtr->numWords); + expand = ExpandRequested(parsePtr->tokenPtr, parsePtr->numWords); } if (expand) { CompileExpanded(interp, parsePtr->tokenPtr, - cmdKnown ? cmdObj : NULL, (int)parsePtr->numWords, envPtr); + cmdKnown ? cmdObj : NULL, parsePtr->numWords, envPtr); } else { TclCompileInvocation(interp, parsePtr->tokenPtr, - cmdKnown ? cmdObj : NULL, (int)parsePtr->numWords, envPtr); + cmdKnown ? cmdObj : NULL, parsePtr->numWords, envPtr); } } @@ -2215,7 +2215,7 @@ TclCompileScript( numBytes -= next - p; p = next; - if ((int)parsePtr->numWords == 0) { + if (parsePtr->numWords == 0) { /* * The "command" parsed has no words. In this case we can skip * the rest of the loop body. With no words, clearly @@ -3198,7 +3198,7 @@ EnterCmdStartData( } if (cmdIndex > 0) { - if (codeOffset < envPtr->cmdMapPtr[cmdIndex-1].codeOffset) { + if (codeOffset < (int)envPtr->cmdMapPtr[cmdIndex-1].codeOffset) { Tcl_Panic("EnterCmdStartData: cmd map not sorted by code offset"); } } @@ -3207,7 +3207,7 @@ EnterCmdStartData( cmdLocPtr->codeOffset = codeOffset; cmdLocPtr->srcOffset = srcOffset; cmdLocPtr->numSrcBytes = -1; - cmdLocPtr->numCodeBytes = -1; + cmdLocPtr->numCodeBytes = TCL_INDEX_NONE; } /* @@ -3378,7 +3378,7 @@ TclCreateExceptRange( size_t currBytes = envPtr->exceptArrayNext * sizeof(ExceptionRange); size_t currBytes2 = envPtr->exceptArrayNext * sizeof(ExceptionAux); - int newElems = 2*envPtr->exceptArrayEnd; + size_t newElems = 2*envPtr->exceptArrayEnd; size_t newBytes = newElems * sizeof(ExceptionRange); size_t newBytes2 = newElems * sizeof(ExceptionAux); @@ -3409,8 +3409,8 @@ TclCreateExceptRange( rangePtr = &envPtr->exceptArrayPtr[index]; rangePtr->type = type; rangePtr->nestingLevel = envPtr->exceptDepth; - rangePtr->codeOffset = -1; - rangePtr->numCodeBytes = -1; + rangePtr->codeOffset = TCL_INDEX_NONE; + rangePtr->numCodeBytes = TCL_INDEX_NONE; rangePtr->breakOffset = -1; rangePtr->continueOffset = -1; rangePtr->catchOffset = -1; @@ -3435,9 +3435,9 @@ TclCreateExceptRange( * * Returns the innermost exception range that covers the current code * creation point, and optionally the stack depth that is expected at - * that point. Relies on the fact that the range has a numCodeBytes = -1 - * when it is being populated and that inner ranges come after outer - * ranges. + * that point. Relies on the fact that the range has a numCodeBytes = + * TCL_INDEX_NONE when it is being populated and that inner ranges + * come after outer ranges. * * --------------------------------------------------------------------- */ @@ -3448,15 +3448,15 @@ TclGetInnermostExceptionRange( int returnCode, ExceptionAux **auxPtrPtr) { - int i = envPtr->exceptArrayNext; + size_t i = envPtr->exceptArrayNext; ExceptionRange *rangePtr = envPtr->exceptArrayPtr + i; while (i > 0) { rangePtr--; i--; - if (CurrentOffset(envPtr) >= rangePtr->codeOffset && - (rangePtr->numCodeBytes == -1 || CurrentOffset(envPtr) < - rangePtr->codeOffset+rangePtr->numCodeBytes) && + if (CurrentOffset(envPtr) >= (int)rangePtr->codeOffset && + (rangePtr->numCodeBytes == TCL_INDEX_NONE || CurrentOffset(envPtr) < + (int)rangePtr->codeOffset+(int)rangePtr->numCodeBytes) && (returnCode != TCL_CONTINUE || envPtr->exceptAuxArrayPtr[i].supportsContinue)) { @@ -3603,10 +3603,10 @@ StartExpanding( * Ignore loops unless they're still being built. */ - if (rangePtr->codeOffset > CurrentOffset(envPtr)) { + if ((int)rangePtr->codeOffset > CurrentOffset(envPtr)) { continue; } - if (rangePtr->numCodeBytes != -1) { + if (rangePtr->numCodeBytes != TCL_INDEX_NONE) { continue; } diff --git a/generic/tclCompile.h b/generic/tclCompile.h index 9f47a03..0ec34dc 100644 --- a/generic/tclCompile.h +++ b/generic/tclCompile.h @@ -92,9 +92,9 @@ typedef struct { int nestingLevel; /* Static depth of the exception range. Used * to find the most deeply-nested range * surrounding a PC at runtime. */ - int codeOffset; /* Offset of the first instruction byte of the + size_t codeOffset; /* Offset of the first instruction byte of the * code range. */ - int numCodeBytes; /* Number of bytes in the code range. */ + size_t numCodeBytes; /* Number of bytes in the code range. */ int breakOffset; /* If LOOP_EXCEPTION_RANGE, the target PC * offset for a break command in the range. */ int continueOffset; /* If LOOP_EXCEPTION_RANGE and not -1, the @@ -163,8 +163,8 @@ typedef struct ExceptionAux { */ typedef struct { - int codeOffset; /* Offset of first byte of command code. */ - int numCodeBytes; /* Number of bytes for command's code. */ + size_t codeOffset; /* Offset of first byte of command code. */ + size_t numCodeBytes; /* Number of bytes for command's code. */ int srcOffset; /* Offset of first char of the command. */ int numSrcBytes; /* Number of command source chars. */ } CmdLocation; @@ -297,7 +297,7 @@ typedef struct CompileEnv { * information provided by ObjInterpProc in * tclProc.c. */ size_t numCommands; /* Number of commands compiled. */ - int exceptDepth; /* Current exception range nesting level; -1 + size_t exceptDepth; /* Current exception range nesting level; -1 * if not in any range currently. */ int maxExceptDepth; /* Max nesting level of exception ranges; -1 * if no ranges have been compiled. */ @@ -461,7 +461,7 @@ typedef struct ByteCode { * by AuxData entries. */ int numCommands; /* Number of commands compiled. */ int numSrcBytes; /* Number of source bytes compiled. */ - int numCodeBytes; /* Number of code bytes. */ + size_t numCodeBytes; /* Number of code bytes. */ int numLitObjects; /* Number of objects in literal array. */ int numExceptRanges; /* Number of ExceptionRange array elems. */ int numAuxDataItems; /* Number of AuxData items. */ @@ -944,7 +944,7 @@ typedef enum { typedef struct JumpFixup { TclJumpType jumpType; /* Indicates the kind of jump. */ - unsigned int codeOffset; /* Offset of the first byte of the one-byte + TCL_HASH_TYPE codeOffset; /* Offset of the first byte of the one-byte * forward jump's code. */ int cmdIndex; /* Index of the first command after the one * for which the jump was emitted. Used to @@ -1584,7 +1584,7 @@ MODULE_SCOPE int TclPushProcCallFrame(void *clientData, #define ExceptionRangeStarts(envPtr, index) \ (((envPtr)->exceptDepth++), \ ((envPtr)->maxExceptDepth = \ - TclMax((envPtr)->exceptDepth, (envPtr)->maxExceptDepth)), \ + TclMax((int)(envPtr)->exceptDepth, (envPtr)->maxExceptDepth)), \ ((envPtr)->exceptArrayPtr[(index)].codeOffset = CurrentOffset(envPtr))) #define ExceptionRangeEnds(envPtr, index) \ (((envPtr)->exceptDepth--), \ diff --git a/generic/tclDisassemble.c b/generic/tclDisassemble.c index 1cdee5c..7138b92 100644 --- a/generic/tclDisassemble.c +++ b/generic/tclDisassemble.c @@ -288,7 +288,7 @@ DisassembleByteCodeObj( TclGetString(fileObj), line); } Tcl_AppendPrintfToObj(bufferObj, - "\n Cmds %d, src %d, inst %d, litObjs %u, aux %d, stkDepth %u, code/src %.2f\n", + "\n Cmds %d, src %d, inst %" TCL_Z_MODIFIER "u, litObjs %u, aux %d, stkDepth %u, code/src %.2f\n", numCmds, codePtr->numSrcBytes, codePtr->numCodeBytes, codePtr->numLitObjects, codePtr->numAuxDataItems, codePtr->maxStackDepth, @@ -300,7 +300,7 @@ DisassembleByteCodeObj( #ifdef TCL_COMPILE_STATS Tcl_AppendPrintfToObj(bufferObj, - " Code %lu = header %lu+inst %d+litObj %lu+exc %lu+aux %lu+cmdMap %d\n", + " Code %lu = header %lu+inst %" TCL_Z_MODIFIER "u+litObj %lu+exc %lu+aux %lu+cmdMap %d\n", (unsigned long) codePtr->structureSize, (unsigned long) (sizeof(ByteCode) - sizeof(size_t) - sizeof(Tcl_Time)), codePtr->numCodeBytes, @@ -358,7 +358,7 @@ DisassembleByteCodeObj( ExceptionRange *rangePtr = &codePtr->exceptArrayPtr[i]; Tcl_AppendPrintfToObj(bufferObj, - " %d: level %d, %s, pc %d-%d, ", + " %d: level %d, %s, pc %" TCL_Z_MODIFIER "u-%" TCL_Z_MODIFIER "u, ", i, rangePtr->nestingLevel, (rangePtr->type==LOOP_EXCEPTION_RANGE ? "loop" : "catch"), rangePtr->codeOffset, @@ -1008,7 +1008,7 @@ DisassembleByteCodeAsDicts( */ TclNewObj(instructions); - for (pc=codePtr->codeStart; pccodeStart+codePtr->numCodeBytes;){ + for (pc=codePtr->codeStart; pccodeStart+(int)codePtr->numCodeBytes;){ const InstructionDesc *instDesc = &tclInstructionTable[*pc]; int address = pc - codePtr->codeStart; @@ -1144,14 +1144,14 @@ DisassembleByteCodeAsDicts( switch (rangePtr->type) { case LOOP_EXCEPTION_RANGE: Tcl_ListObjAppendElement(NULL, exn, Tcl_ObjPrintf( - "type %s level %d from %d to %d break %d continue %d", + "type %s level %d from %" TCL_Z_MODIFIER "u to %" TCL_Z_MODIFIER "u break %d continue %d", "loop", rangePtr->nestingLevel, rangePtr->codeOffset, rangePtr->codeOffset + rangePtr->numCodeBytes - 1, rangePtr->breakOffset, rangePtr->continueOffset)); break; case CATCH_EXCEPTION_RANGE: Tcl_ListObjAppendElement(NULL, exn, Tcl_ObjPrintf( - "type %s level %d from %d to %d catch %d", + "type %s level %d from %" TCL_Z_MODIFIER "u to %" TCL_Z_MODIFIER "u catch %d", "catch", rangePtr->nestingLevel, rangePtr->codeOffset, rangePtr->codeOffset + rangePtr->numCodeBytes - 1, rangePtr->catchOffset)); diff --git a/generic/tclEnsemble.c b/generic/tclEnsemble.c index 56dc3c1..509dd17 100644 --- a/generic/tclEnsemble.c +++ b/generic/tclEnsemble.c @@ -3254,7 +3254,7 @@ TclAttemptCompileProc( int savedAuxDataArrayNext = envPtr->auxDataArrayNext; int savedExceptArrayNext = envPtr->exceptArrayNext; #ifdef TCL_COMPILE_DEBUG - int savedExceptDepth = envPtr->exceptDepth; + size_t savedExceptDepth = envPtr->exceptDepth; #endif int depth = depth1; @@ -3439,7 +3439,7 @@ CompileToInvokedCommand( * Do the replacing dispatch. */ - TclEmitInvoke(envPtr, INST_INVOKE_REPLACE, (int)parsePtr->numWords,numWords+1); + TclEmitInvoke(envPtr, INST_INVOKE_REPLACE, parsePtr->numWords,numWords+1); } /* @@ -3469,7 +3469,7 @@ CompileBasicNArgCommand( Tcl_IncrRefCount(objPtr); Tcl_GetCommandFullName(interp, (Tcl_Command) cmdPtr, objPtr); TclCompileInvocation(interp, parsePtr->tokenPtr, objPtr, - (int)parsePtr->numWords, envPtr); + parsePtr->numWords, envPtr); Tcl_DecrRefCount(objPtr); return TCL_OK; } @@ -3489,7 +3489,7 @@ TclCompileBasic0ArgCmd( * which is the only code that sees the shenanigans of ensemble dispatch. */ - if ((int)parsePtr->numWords != 1) { + if (parsePtr->numWords != 1) { return TCL_ERROR; } @@ -3511,7 +3511,7 @@ TclCompileBasic1ArgCmd( * which is the only code that sees the shenanigans of ensemble dispatch. */ - if ((int)parsePtr->numWords != 2) { + if (parsePtr->numWords != 2) { return TCL_ERROR; } @@ -3533,7 +3533,7 @@ TclCompileBasic2ArgCmd( * which is the only code that sees the shenanigans of ensemble dispatch. */ - if ((int)parsePtr->numWords != 3) { + if (parsePtr->numWords != 3) { return TCL_ERROR; } @@ -3555,7 +3555,7 @@ TclCompileBasic3ArgCmd( * which is the only code that sees the shenanigans of ensemble dispatch. */ - if ((int)parsePtr->numWords != 4) { + if (parsePtr->numWords != 4) { return TCL_ERROR; } @@ -3577,7 +3577,7 @@ TclCompileBasic0Or1ArgCmd( * which is the only code that sees the shenanigans of ensemble dispatch. */ - if ((int)parsePtr->numWords != 1 && (int)parsePtr->numWords != 2) { + if (parsePtr->numWords != 1 && parsePtr->numWords != 2) { return TCL_ERROR; } @@ -3599,7 +3599,7 @@ TclCompileBasic1Or2ArgCmd( * which is the only code that sees the shenanigans of ensemble dispatch. */ - if ((int)parsePtr->numWords != 2 && (int)parsePtr->numWords != 3) { + if (parsePtr->numWords != 2 && parsePtr->numWords != 3) { return TCL_ERROR; } @@ -3621,7 +3621,7 @@ TclCompileBasic2Or3ArgCmd( * which is the only code that sees the shenanigans of ensemble dispatch. */ - if ((int)parsePtr->numWords != 3 && (int)parsePtr->numWords != 4) { + if (parsePtr->numWords != 3 && parsePtr->numWords != 4) { return TCL_ERROR; } @@ -3643,7 +3643,7 @@ TclCompileBasic0To2ArgCmd( * which is the only code that sees the shenanigans of ensemble dispatch. */ - if ((int)parsePtr->numWords < 1 || (int)parsePtr->numWords > 3) { + if (parsePtr->numWords < 1 || parsePtr->numWords > 3) { return TCL_ERROR; } @@ -3665,7 +3665,7 @@ TclCompileBasic1To3ArgCmd( * which is the only code that sees the shenanigans of ensemble dispatch. */ - if ((int)parsePtr->numWords < 2 || (int)parsePtr->numWords > 4) { + if (parsePtr->numWords < 2 || parsePtr->numWords > 4) { return TCL_ERROR; } diff --git a/generic/tclExecute.c b/generic/tclExecute.c index 925fcdd..6ca8ede 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -7230,7 +7230,7 @@ TEBCresume( if (result == TCL_BREAK) { result = TCL_OK; pc = (codePtr->codeStart + rangePtr->breakOffset); - TRACE_APPEND(("%s, range at %d, new pc %d\n", + TRACE_APPEND(("%s, range at %" TCL_Z_MODIFIER "u, new pc %d\n", StringForResultCode(result), rangePtr->codeOffset, rangePtr->breakOffset)); NEXT_INST_F(0, 0, 0); @@ -7242,7 +7242,7 @@ TEBCresume( } result = TCL_OK; pc = (codePtr->codeStart + rangePtr->continueOffset); - TRACE_APPEND(("%s, range at %d, new pc %d\n", + TRACE_APPEND(("%s, range at %" TCL_Z_MODIFIER "u, new pc %d\n", StringForResultCode(result), rangePtr->codeOffset, rangePtr->continueOffset)); NEXT_INST_F(0, 0, 0); @@ -7414,7 +7414,7 @@ TEBCresume( } #ifdef TCL_COMPILE_DEBUG if (traceInstructions) { - fprintf(stdout, " ... found catch at %d, catchTop=%d, " + fprintf(stdout, " ... found catch at %" TCL_Z_MODIFIER "u, catchTop=%d, " "unwound to %ld, new pc %" TCL_Z_MODIFIER "u\n", rangePtr->codeOffset, (int) (catchTop - initCatchTop - 1), (long)*catchTop, (size_t) rangePtr->catchOffset); @@ -8682,7 +8682,7 @@ PrintByteCodeInfo( fprintf(stdout, " Source: "); TclPrintSource(stdout, codePtr->source, 60); - fprintf(stdout, "\n Cmds %d, src %d, inst %u, litObjs %u, aux %d, stkDepth %u, code/src %.2f\n", + fprintf(stdout, "\n Cmds %d, src %d, inst %" TCL_Z_MODIFIER "u, litObjs %u, aux %d, stkDepth %u, code/src %.2f\n", codePtr->numCommands, codePtr->numSrcBytes, codePtr->numCodeBytes, codePtr->numLitObjects, codePtr->numAuxDataItems, codePtr->maxStackDepth, @@ -8693,7 +8693,7 @@ PrintByteCodeInfo( 0.0); #ifdef TCL_COMPILE_STATS - fprintf(stdout, " Code %lu = header %lu+inst %d+litObj %lu+exc %lu+aux %lu+cmdMap %d\n", + fprintf(stdout, " Code %lu = header %lu+inst %" TCL_Z_MODIFIER "u+litObj %lu+exc %lu+aux %lu+cmdMap %d\n", (unsigned long) codePtr->structureSize, (unsigned long) (sizeof(ByteCode)-sizeof(size_t)-sizeof(Tcl_Time)), codePtr->numCodeBytes, @@ -8980,7 +8980,7 @@ GetSrcInfoForPc( int bestCmdIdx = -1; /* The pc must point within the bytecode */ - assert (pcOffset < (size_t)codePtr->numCodeBytes); + assert (pcOffset < codePtr->numCodeBytes); /* * Decode the code and source offset and length for each command. The @@ -9141,7 +9141,7 @@ GetExceptRangeForPc( while (--rangePtr >= rangeArrayPtr) { start = rangePtr->codeOffset; if ((start <= pcOffset) && - (pcOffset < (start + rangePtr->numCodeBytes))) { + (pcOffset < (start + (int)rangePtr->numCodeBytes))) { if (rangePtr->type == CATCH_EXCEPTION_RANGE) { return rangePtr; } -- cgit v0.12 From a455c140eaab90a3f1f588ce4e8a841e2b260fa6 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 10 Mar 2022 10:26:01 +0000 Subject: Unused variable warning --- generic/tclTestObj.c | 2 ++ 1 file changed, 2 insertions(+) diff --git a/generic/tclTestObj.c b/generic/tclTestObj.c index 9081bcf..a235002 100644 --- a/generic/tclTestObj.c +++ b/generic/tclTestObj.c @@ -659,7 +659,9 @@ TestintobjCmd( Tcl_Obj *const objv[]) /* Argument objects. */ { size_t varIndex; +#if (INT_MAX != LONG_MAX) /* int is not the same size as long */ int i; +#endif Tcl_WideInt wideValue; const char *subCmd; Tcl_Obj **varPtr; -- cgit v0.12 From a9c0e83fb00eef6b3be5db888dfa2cfad2c0eb52 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 10 Mar 2022 10:37:44 +0000 Subject: Eliminate nmake build warning --- win/makefile.vc | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/win/makefile.vc b/win/makefile.vc index 6b2a682..1ef64f2 100644 --- a/win/makefile.vc +++ b/win/makefile.vc @@ -819,7 +819,8 @@ $(TMP_DIR)\tclEvent.obj: $(GENERICDIR)\tclEvent.c $(TMP_DIR)\tclUuid.h -Fo$@ $(GENERICDIR)\tclEvent.c $(TMP_DIR)\tclTest.obj: $(GENERICDIR)\tclTest.c $(TMP_DIR)\tclUuid.h - $(cc32) $(appcflags) -I$(TMP_DIR) -Fo$@ $? + $(cc32) $(appcflags) -I$(TMP_DIR) \ + -Fo$@ $(GENERICDIR)\tclTest.c $(TMP_DIR)\tclTestObj.obj: $(GENERICDIR)\tclTestObj.c $(cc32) $(appcflags) -Fo$@ $? -- cgit v0.12 From 500e2ceb70e7a57505c5d12828ed6a1145736ae9 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 10 Mar 2022 11:43:16 +0000 Subject: Add ::tcl::test::build-info command to tcl::test package, so we can find out which compiler/options the test package is compiled with (TIP #599) --- generic/tclTest.c | 90 ++++++++++++++++++++++++++++++++++++++++++++++++++++++- 1 file changed, 89 insertions(+), 1 deletion(-) diff --git a/generic/tclTest.c b/generic/tclTest.c index 1564bd5..ee29cb1 100644 --- a/generic/tclTest.c +++ b/generic/tclTest.c @@ -41,6 +41,8 @@ */ #include "tclIO.h" +#include "tclUuid.h" + /* * Declare external functions used in Windows tests. */ @@ -438,10 +440,84 @@ static const Tcl_Filesystem simpleFilesystem = { *---------------------------------------------------------------------- */ +#ifndef STRINGIFY +# define STRINGIFY(x) STRINGIFY1(x) +# define STRINGIFY1(x) #x +#endif + +static const char version[] = TCL_PATCH_LEVEL "+" STRINGIFY(TCL_VERSION_UUID) +#if defined(__clang__) && defined(__clang_major__) + ".clang-" STRINGIFY(__clang_major__) +#if __clang_minor__ < 10 + "0" +#endif + STRINGIFY(__clang_minor__) +#endif +#ifdef TCL_COMPILE_DEBUG + ".compiledebug" +#endif +#ifdef TCL_COMPILE_STATS + ".compilestats" +#endif +#if defined(__cplusplus) && !defined(__OBJC__) + ".cplusplus" +#endif +#ifndef NDEBUG + ".debug" +#endif +#if !defined(__clang__) && !defined(__INTEL_COMPILER) && defined(__GNUC__) + ".gcc-" STRINGIFY(__GNUC__) +#if __GNUC_MINOR__ < 10 + "0" +#endif + STRINGIFY(__GNUC_MINOR__) +#endif +#ifdef __INTEL_COMPILER + ".icc-" STRINGIFY(__INTEL_COMPILER) +#endif +#if (defined(_WIN32) && !defined(_WIN64)) || (ULONG_MAX == 0xffffffffUL) + ".ilp32" +#endif +#ifdef TCL_MEM_DEBUG + ".memdebug" +#endif +#if defined(_MSC_VER) + ".msvc-" STRINGIFY(_MSC_VER) +#endif +#ifdef USE_NMAKE + ".nmake" +#endif +#if !TCL_THREADS + ".no-thread" +#endif +#ifndef TCL_CFG_OPTIMIZED + ".no-optimize" +#endif +#ifdef __OBJC__ + ".objective-c" +#if defined(__cplusplus) + "plusplus" +#endif +#endif +#ifdef TCL_CFG_PROFILED + ".profile" +#endif +#ifdef PURIFY + ".purify" +#endif +#ifdef STATIC_BUILD + ".static" +#endif +#if TCL_UTF_MAX < 4 + ".utf-16" +#endif +; + int Tcltest_Init( Tcl_Interp *interp) /* Interpreter for application. */ { + Tcl_CmdInfo info; Tcl_Obj **objv, *objPtr; int objc, index; static const char *const specialOptions[] = { @@ -460,8 +536,11 @@ Tcltest_Init( if (Tcl_OOInitStubs(interp) == NULL) { return TCL_ERROR; } - /* TIP #268: Full patchlevel instead of just major.minor */ + if (Tcl_GetCommandInfo(interp, "::tcl::build-info", &info)) { + Tcl_CreateObjCommand(interp, "::tcl::test::build-info", + info.objProc, (void *)version, NULL); + } if (Tcl_PkgProvideEx(interp, "tcl::test", TCL_PATCH_LEVEL, NULL) == TCL_ERROR) { return TCL_ERROR; } @@ -706,9 +785,18 @@ int Tcltest_SafeInit( Tcl_Interp *interp) /* Interpreter for application. */ { + Tcl_CmdInfo info; + if (Tcl_InitStubs(interp, "8.5-", 0) == NULL) { return TCL_ERROR; } + if (Tcl_GetCommandInfo(interp, "::tcl::build-info", &info)) { + Tcl_CreateObjCommand(interp, "::tcl::test::build-info", + info.objProc, (void *)version, NULL); + } + if (Tcl_PkgProvideEx(interp, "tcl::test", TCL_PATCH_LEVEL, NULL) == TCL_ERROR) { + return TCL_ERROR; + } return Procbodytest_SafeInit(interp); } -- cgit v0.12 From 643fbd40d93f1432a5465323319edaa756f309f8 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 10 Mar 2022 14:03:08 +0000 Subject: Enhance internal "struct CoroutineData" such that it can handle more than 2^31 levels/arguments --- generic/tclBasic.c | 27 +++++++++++++-------------- generic/tclInt.h | 4 ++-- generic/tclZipfs.c | 18 ++++++------------ 3 files changed, 21 insertions(+), 28 deletions(-) diff --git a/generic/tclBasic.c b/generic/tclBasic.c index 2d86e9c..dbb20a5 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -220,8 +220,8 @@ MODULE_SCOPE const TclStubs tclStubs; #define CORO_ACTIVATE_YIELD PTR2INT(NULL) #define CORO_ACTIVATE_YIELDM PTR2INT(NULL)+1 -#define COROUTINE_ARGUMENTS_SINGLE_OPTIONAL (-1) -#define COROUTINE_ARGUMENTS_ARBITRARY (-2) +#define COROUTINE_ARGUMENTS_SINGLE_OPTIONAL ((size_t)-1) +#define COROUTINE_ARGUMENTS_ARBITRARY ((size_t)-2) /* * The following structure define the commands in the Tcl core. @@ -8956,9 +8956,8 @@ TclNRCoroutineActivateCallback( TCL_UNUSED(int) /*result*/) { CoroutineData *corPtr = (CoroutineData *)data[0]; - int type = PTR2INT(data[1]); - int numLevels, unused; - int *stackLevel = &unused; + int unused, type = PTR2INT(data[1]); + size_t numLevels; if (!corPtr->stackLevel) { /* @@ -8975,7 +8974,7 @@ TclNRCoroutineActivateCallback( * the interp's environment to make it suitable to run this coroutine. */ - corPtr->stackLevel = stackLevel; + corPtr->stackLevel = &unused; numLevels = corPtr->auxNumLevels; corPtr->auxNumLevels = iPtr->numLevels; @@ -8989,7 +8988,7 @@ TclNRCoroutineActivateCallback( * Coroutine is active: yield */ - if (corPtr->stackLevel != stackLevel) { + if (corPtr->stackLevel != &unused) { NRE_callback *runPtr; iPtr->execEnvPtr = corPtr->callerEEPtr; @@ -9217,8 +9216,8 @@ TclNRCoroProbeObjCmd( { CoroutineData *corPtr; ExecEnv *savedEEPtr = iPtr->execEnvPtr; - int numLevels, unused; - int *stackLevel = &unused; + size_t numLevels; + int unused; /* * Usage more or less like tailcall: @@ -9268,7 +9267,7 @@ TclNRCoroProbeObjCmd( * the interp's environment to make it suitable to run this coroutine. */ - corPtr->stackLevel = stackLevel; + corPtr->stackLevel = &unused; numLevels = corPtr->auxNumLevels; corPtr->auxNumLevels = iPtr->numLevels; @@ -9313,7 +9312,7 @@ InjectHandler( { CoroutineData *corPtr = (CoroutineData *)data[0]; Tcl_Obj *listPtr = (Tcl_Obj *)data[1]; - int nargs = PTR2INT(data[2]); + size_t nargs = PTR2INT(data[2]); void *isProbe = data[3]; int objc; Tcl_Obj **objv; @@ -9334,7 +9333,7 @@ InjectHandler( * I don't think this is reachable... */ - Tcl_ListObjAppendElement(NULL, listPtr, Tcl_NewIntObj(nargs)); + Tcl_ListObjAppendElement(NULL, listPtr, Tcl_NewWideIntObj((Tcl_WideInt)(nargs + 1U) - 1)); } Tcl_ListObjAppendElement(NULL, listPtr, Tcl_GetObjResult(interp)); } @@ -9359,7 +9358,7 @@ InjectHandlerPostCall( { CoroutineData *corPtr = (CoroutineData *)data[0]; Tcl_Obj *listPtr = (Tcl_Obj *)data[1]; - int nargs = PTR2INT(data[2]); + size_t nargs = PTR2INT(data[2]); void *isProbe = data[3]; int numLevels; @@ -9479,7 +9478,7 @@ TclNRInterpCoroutine( } break; default: - if (corPtr->nargs != objc-1) { + if (corPtr->nargs + 1 != (size_t)objc) { Tcl_SetObjResult(interp, Tcl_NewStringObj("wrong coro nargs; how did we get here? " "not implemented!", -1)); diff --git a/generic/tclInt.h b/generic/tclInt.h index 8678a57..bdf7990 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -1473,11 +1473,11 @@ typedef struct CoroutineData { CorContext running; Tcl_HashTable *lineLABCPtr; /* See Interp.lineLABCPtr */ void *stackLevel; - int auxNumLevels; /* While the coroutine is running the + size_t auxNumLevels; /* While the coroutine is running the * numLevels of the create/resume command is * stored here; for suspended coroutines it * holds the nesting numLevels at yield. */ - int nargs; /* Number of args required for resuming this + size_t nargs; /* Number of args required for resuming this * coroutine; COROUTINE_ARGUMENTS_SINGLE_OPTIONAL means "0 or 1" * (default), COROUTINE_ARGUMENTS_ARBITRARY means "any" */ Tcl_Obj *yieldPtr; /* The command to yield to. Stored here in diff --git a/generic/tclZipfs.c b/generic/tclZipfs.c index b63cce7..906eff4 100644 --- a/generic/tclZipfs.c +++ b/generic/tclZipfs.c @@ -428,12 +428,6 @@ static Tcl_ChannelType ZipChannelType = { }; /* - * Miscellaneous constants. - */ - -#define ERROR_LENGTH ((size_t) -1) - -/* *------------------------------------------------------------------------- * * ZipReadInt, ZipReadShort, ZipWriteInt, ZipWriteShort -- @@ -1387,7 +1381,7 @@ ZipFSOpenArchive( */ zf->length = Tcl_Seek(zf->chan, 0, SEEK_END); - if (zf->length == ERROR_LENGTH) { + if (zf->length == TCL_INDEX_NONE) { ZIPFS_POSIX_ERROR(interp, "seek error"); goto error; } @@ -1486,7 +1480,7 @@ ZipMapArchive( */ zf->length = lseek(fd, 0, SEEK_END); - if (zf->length == ERROR_LENGTH || zf->length < ZIP_CENTRAL_END_LEN) { + if (zf->length == TCL_INDEX_NONE || zf->length < ZIP_CENTRAL_END_LEN) { ZIPFS_POSIX_ERROR(interp, "invalid file size"); return TCL_ERROR; } @@ -2582,7 +2576,7 @@ ZipAddFile( nbyte = nbytecompr = 0; while (1) { len = Tcl_Read(in, buf, bufsize); - if (len == ERROR_LENGTH) { + if (len == TCL_INDEX_NONE) { Tcl_DStringFree(&zpathDs); if (nbyte == 0 && errno == EISDIR) { Tcl_Close(interp, in); @@ -2712,7 +2706,7 @@ ZipAddFile( do { len = Tcl_Read(in, buf, bufsize); - if (len == ERROR_LENGTH) { + if (len == TCL_INDEX_NONE) { deflateEnd(&stream); goto readErrorWithChannelOpen; } @@ -2776,7 +2770,7 @@ ZipAddFile( nbytecompr = (passwd ? 12 : 0); while (1) { len = Tcl_Read(in, buf, bufsize); - if (len == ERROR_LENGTH) { + if (len == TCL_INDEX_NONE) { goto readErrorWithChannelOpen; } else if (len == 0) { break; @@ -3299,7 +3293,7 @@ CopyImageFile( */ i = Tcl_Seek(in, 0, SEEK_END); - if (i == ERROR_LENGTH) { + if (i == TCL_INDEX_NONE) { errMsg = "seek error"; goto copyError; } -- cgit v0.12 From 0b39585b19e94e663d35f0618c748abfb37de5cd Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 10 Mar 2022 15:02:24 +0000 Subject: Enhance internal "struct Interp" such that it can handle more than 2^31 levels --- generic/tclBasic.c | 2 +- generic/tclExecute.c | 18 +++++++++--------- generic/tclInt.h | 4 ++-- generic/tclInterp.c | 2 +- generic/tclTest.c | 8 ++++---- 5 files changed, 17 insertions(+), 17 deletions(-) diff --git a/generic/tclBasic.c b/generic/tclBasic.c index dbb20a5..b7b58a7 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -3930,7 +3930,7 @@ TclInterpReady( * probably because of an infinite loop somewhere. */ - if (((iPtr->numLevels) <= iPtr->maxNestingDepth)) { + if ((iPtr->numLevels <= iPtr->maxNestingDepth)) { return TCL_OK; } diff --git a/generic/tclExecute.c b/generic/tclExecute.c index 197b1e9..6b47f02 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -379,7 +379,7 @@ VarHashCreateVar( #ifdef TCL_COMPILE_DEBUG # define TRACE(a) \ while (traceInstructions) { \ - fprintf(stdout, "%2d: %2d (%" TCL_Z_MODIFIER "u) %s ", iPtr->numLevels, \ + fprintf(stdout, "%2" TCL_Z_MODIFIER "d: %2d (%" TCL_Z_MODIFIER "u) %s ", iPtr->numLevels, \ (int) CURR_DEPTH, \ (size_t) (pc - codePtr->codeStart), \ GetOpcodeName(pc)); \ @@ -395,7 +395,7 @@ VarHashCreateVar( TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp)))); # define TRACE_WITH_OBJ(a, objPtr) \ while (traceInstructions) { \ - fprintf(stdout, "%2d: %2d (%" TCL_Z_MODIFIER "u) %s ", iPtr->numLevels, \ + fprintf(stdout, "%2" TCL_Z_MODIFIER "d: %2d (%" TCL_Z_MODIFIER "u) %s ", iPtr->numLevels, \ (int) CURR_DEPTH, \ (size_t) (pc - codePtr->codeStart), \ GetOpcodeName(pc)); \ @@ -2269,7 +2269,7 @@ TEBCresume( CHECK_STACK(); if (traceInstructions) { - fprintf(stdout, "%2d: %2d ", iPtr->numLevels, (int) CURR_DEPTH); + fprintf(stdout, "%2" TCL_Z_MODIFIER "d: %2d ", iPtr->numLevels, (int) CURR_DEPTH); TclPrintInstruction(codePtr, pc); fflush(stdout); } @@ -2389,7 +2389,7 @@ TEBCresume( if (traceInstructions) { TRACE_APPEND(("YIELD...\n")); } else { - fprintf(stdout, "%d: (%" TCL_Z_MODIFIER "u) yielding value \"%.30s\"\n", + fprintf(stdout, "%" TCL_Z_MODIFIER "d: (%" TCL_Z_MODIFIER "u) yielding value \"%.30s\"\n", iPtr->numLevels, (size_t)(pc - codePtr->codeStart), Tcl_GetString(OBJ_AT_TOS)); } @@ -2432,7 +2432,7 @@ TEBCresume( TRACE(("[%.30s] => YIELD...\n", O2S(valuePtr))); } else { /* FIXME: What is the right thing to trace? */ - fprintf(stdout, "%d: (%" TCL_Z_MODIFIER "u) yielding to [%.30s]\n", + fprintf(stdout, "%" TCL_Z_MODIFIER "d: (%" TCL_Z_MODIFIER "u) yielding to [%.30s]\n", iPtr->numLevels, (size_t)(pc - codePtr->codeStart), TclGetString(valuePtr)); } @@ -2791,7 +2791,7 @@ TEBCresume( strncpy(cmdNameBuf, TclGetString(objv[0]), 20); TRACE(("%u => call ", objc)); } else { - fprintf(stdout, "%d: (%" TCL_Z_MODIFIER "u) invoking ", iPtr->numLevels, + fprintf(stdout, "%" TCL_Z_MODIFIER "d: (%" TCL_Z_MODIFIER "u) invoking ", iPtr->numLevels, (size_t)(pc - codePtr->codeStart)); } for (i = 0; i < objc; i++) { @@ -2839,7 +2839,7 @@ TEBCresume( TRACE(("%u => call (implementation %s) ", objc, O2S(objPtr))); } else { fprintf(stdout, - "%d: (%" TCL_Z_MODIFIER "u) invoking (using implementation %s) ", + "%" TCL_Z_MODIFIER "d: (%" TCL_Z_MODIFIER "u) invoking (using implementation %s) ", iPtr->numLevels, (size_t)(pc - codePtr->codeStart), O2S(objPtr)); } @@ -4424,7 +4424,7 @@ TEBCresume( if (traceInstructions) { strncpy(cmdNameBuf, TclGetString(objv[0]), 20); } else { - fprintf(stdout, "%d: (%" TCL_Z_MODIFIER "u) invoking ", + fprintf(stdout, "%" TCL_Z_MODIFIER "d: (%" TCL_Z_MODIFIER "u) invoking ", iPtr->numLevels, (size_t)(pc - codePtr->codeStart)); } @@ -4526,7 +4526,7 @@ TEBCresume( if (traceInstructions) { strncpy(cmdNameBuf, TclGetString(objv[0]), 20); } else { - fprintf(stdout, "%d: (%" TCL_Z_MODIFIER "u) invoking ", + fprintf(stdout, "%" TCL_Z_MODIFIER "d: (%" TCL_Z_MODIFIER "u) invoking ", iPtr->numLevels, (size_t)(pc - codePtr->codeStart)); } for (i = 0; i < opnd; i++) { diff --git a/generic/tclInt.h b/generic/tclInt.h index bdf7990..b7f35ca 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -1848,12 +1848,12 @@ typedef struct Interp { * tclVar.c for usage. */ - int numLevels; /* Keeps track of how many nested calls to + size_t numLevels; /* Keeps track of how many nested calls to * Tcl_Eval are in progress for this * interpreter. It's used to delay deletion of * the table until all Tcl_Eval invocations * are completed. */ - int maxNestingDepth; /* If numLevels exceeds this value then Tcl + size_t maxNestingDepth; /* If numLevels exceeds this value then Tcl * assumes that infinite recursion has * occurred and it generates an error. */ CallFrame *framePtr; /* Points to top-most in stack of all nested diff --git a/generic/tclInterp.c b/generic/tclInterp.c index adf113d..2e57ff5 100644 --- a/generic/tclInterp.c +++ b/generic/tclInterp.c @@ -3016,7 +3016,7 @@ ChildRecursionLimit( } Tcl_SetRecursionLimit(childInterp, limit); iPtr = (Interp *) childInterp; - if (interp == childInterp && iPtr->numLevels > limit) { + if (interp == childInterp && iPtr->numLevels > (size_t)limit) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "falling back due to new recursion limit", -1)); Tcl_SetErrorCode(interp, "TCL", "RECURSION", NULL); diff --git a/generic/tclTest.c b/generic/tclTest.c index cead18c..94a3fea 100644 --- a/generic/tclTest.c +++ b/generic/tclTest.c @@ -7398,7 +7398,7 @@ TestNRELevels( static ptrdiff_t *refDepth = NULL; ptrdiff_t depth; Tcl_Obj *levels[6]; - int i = 0; + size_t i = 0; NRE_callback *cbPtr = iPtr->execEnvPtr->callbackPtr; if (refDepth == NULL) { @@ -7408,9 +7408,9 @@ TestNRELevels( depth = (refDepth - &depth); levels[0] = Tcl_NewWideIntObj(depth); - levels[1] = Tcl_NewWideIntObj(iPtr->numLevels); - levels[2] = Tcl_NewWideIntObj(iPtr->cmdFramePtr->level); - levels[3] = Tcl_NewWideIntObj(iPtr->varFramePtr->level); + levels[1] = Tcl_NewWideIntObj((Tcl_WideInt)((Tcl_WideUInt)(iPtr->numLevels + 1U)) - 1); + levels[2] = Tcl_NewWideIntObj((Tcl_WideInt)((Tcl_WideUInt)(iPtr->cmdFramePtr->level + 1U)) - 1); + levels[3] = Tcl_NewWideIntObj((Tcl_WideInt)((Tcl_WideUInt)(iPtr->varFramePtr->level + 1U)) - 1); levels[4] = Tcl_NewWideIntObj(iPtr->execEnvPtr->execStackPtr->tosPtr - iPtr->execEnvPtr->execStackPtr->stackWords); -- cgit v0.12 From eb31ffcba4c70826a0766a12f72e6ed03d5c605d Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 10 Mar 2022 16:17:11 +0000 Subject: Update doc, fix PrintSourceToObj signature --- doc/AddErrInfo.3 | 4 ++-- doc/CrtChannel.3 | 2 +- doc/ParseCmd.3 | 2 +- generic/tclCompile.h | 10 +++++----- generic/tclDisassemble.c | 6 +++--- 5 files changed, 12 insertions(+), 12 deletions(-) diff --git a/doc/AddErrInfo.3 b/doc/AddErrInfo.3 index ba998c0..b273c70 100644 --- a/doc/AddErrInfo.3 +++ b/doc/AddErrInfo.3 @@ -76,8 +76,8 @@ The line number of a script where an error occurred. Pointer to first character in script containing command (must be <= command) .AP "const char" *command in Pointer to first character in command that generated the error -.AP int commandLength in -Number of bytes in command; -1 means use all bytes up to first null byte +.AP size_t commandLength in +Number of bytes in command; TCL_INDEX_NONE means use all bytes up to first null byte .BE .SH DESCRIPTION .PP diff --git a/doc/CrtChannel.3 b/doc/CrtChannel.3 index 299bc29..968328c 100644 --- a/doc/CrtChannel.3 +++ b/doc/CrtChannel.3 @@ -136,7 +136,7 @@ means the output handle is wanted. .AP void **handlePtr out Points to the location where the desired OS-specific handle should be stored. -.AP int size in +.AP size_t size in The size, in bytes, of buffers to allocate in this channel. .AP int mask in An OR-ed combination of \fBTCL_READABLE\fR, \fBTCL_WRITABLE\fR diff --git a/doc/ParseCmd.3 b/doc/ParseCmd.3 index d93f00c..5235325 100644 --- a/doc/ParseCmd.3 +++ b/doc/ParseCmd.3 @@ -45,7 +45,7 @@ For \fBTcl_EvalTokensStandard\fR, determines the context for evaluating the script and also is used for error reporting; must not be NULL. .AP "const char" *start in Pointer to first character in string to parse. -.AP int numBytes in +.AP size_t numBytes in Number of bytes in string to parse, not including any terminating null character. If less than 0 then the script consists of all characters following \fIstart\fR up to the first null character. diff --git a/generic/tclCompile.h b/generic/tclCompile.h index 9f47a03..b0491be 100644 --- a/generic/tclCompile.h +++ b/generic/tclCompile.h @@ -1501,15 +1501,15 @@ MODULE_SCOPE int TclPushProcCallFrame(void *clientData, (*((p)+3)))) /* - * Macros used to compute the minimum and maximum of two integers. The ANSI C + * Macros used to compute the minimum and maximum of two values. The ANSI C * "prototypes" for these macros are: * - * int TclMin(int i, int j); - * int TclMax(int i, int j); + * size_t TclMin(size_t i, size_t j); + * size_t TclMax(size_t i, size_t j); */ -#define TclMin(i, j) ((((int) i) < ((int) j))? (i) : (j)) -#define TclMax(i, j) ((((int) i) > ((int) j))? (i) : (j)) +#define TclMin(i, j) ((((size_t) i) + 1 < ((size_t) j) + 1 )? (i) : (j)) +#define TclMax(i, j) ((((size_t) i) + 1 > ((size_t) j) + 1 )? (i) : (j)) /* * Convenience macros for use when compiling bodies of commands. The ANSI C diff --git a/generic/tclDisassemble.c b/generic/tclDisassemble.c index 1cdee5c..1cef2d2 100644 --- a/generic/tclDisassemble.c +++ b/generic/tclDisassemble.c @@ -28,7 +28,7 @@ static int FormatInstruction(ByteCode *codePtr, static void GetLocationInformation(Proc *procPtr, Tcl_Obj **fileObjPtr, int *linePtr); static void PrintSourceToObj(Tcl_Obj *appendObj, - const char *stringPtr, int maxChars); + const char *stringPtr, size_t maxChars); static void UpdateStringOfInstName(Tcl_Obj *objPtr); /* @@ -858,10 +858,10 @@ static void PrintSourceToObj( Tcl_Obj *appendObj, /* The object to print the source to. */ const char *stringPtr, /* The string to print. */ - int maxChars) /* Maximum number of chars to print. */ + size_t maxChars) /* Maximum number of chars to print. */ { const char *p; - int i = 0, len; + size_t i = 0, len; if (stringPtr == NULL) { Tcl_AppendToObj(appendObj, "\"\"", -1); -- cgit v0.12 From fb115db64ceb2b31b68345ef5fa6a0c2442cab8e Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 10 Mar 2022 17:37:18 +0000 Subject: clarify 'yieldparameter'. Eliminate variable 'unused' --- generic/tclBasic.c | 14 ++++++-------- generic/tclExecute.c | 6 +++--- 2 files changed, 9 insertions(+), 11 deletions(-) diff --git a/generic/tclBasic.c b/generic/tclBasic.c index 2e684e7..9214994 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -8955,9 +8955,8 @@ TclNRCoroutineActivateCallback( Tcl_Interp *interp, TCL_UNUSED(int) /*result*/) { + size_t numLevels, type = PTR2INT(data[1]); CoroutineData *corPtr = (CoroutineData *)data[0]; - int unused, type = PTR2INT(data[1]); - size_t numLevels; if (!corPtr->stackLevel) { /* @@ -8974,7 +8973,7 @@ TclNRCoroutineActivateCallback( * the interp's environment to make it suitable to run this coroutine. */ - corPtr->stackLevel = &unused; + corPtr->stackLevel = &corPtr; numLevels = corPtr->auxNumLevels; corPtr->auxNumLevels = iPtr->numLevels; @@ -8988,7 +8987,7 @@ TclNRCoroutineActivateCallback( * Coroutine is active: yield */ - if (corPtr->stackLevel != &unused) { + if (corPtr->stackLevel != &corPtr) { NRE_callback *runPtr; iPtr->execEnvPtr = corPtr->callerEEPtr; @@ -9214,10 +9213,9 @@ TclNRCoroProbeObjCmd( int objc, Tcl_Obj *const objv[]) { - CoroutineData *corPtr; ExecEnv *savedEEPtr = iPtr->execEnvPtr; size_t numLevels; - int unused; + CoroutineData *corPtr; /* * Usage more or less like tailcall: @@ -9267,7 +9265,7 @@ TclNRCoroProbeObjCmd( * the interp's environment to make it suitable to run this coroutine. */ - corPtr->stackLevel = &unused; + corPtr->stackLevel = &corPtr; numLevels = corPtr->auxNumLevels; corPtr->auxNumLevels = iPtr->numLevels; @@ -9360,7 +9358,7 @@ InjectHandlerPostCall( Tcl_Obj *listPtr = (Tcl_Obj *)data[1]; size_t nargs = PTR2INT(data[2]); void *isProbe = data[3]; - int numLevels; + size_t numLevels; /* * Delete the command words for what we just executed. diff --git a/generic/tclExecute.c b/generic/tclExecute.c index b4fcbb5..b9b6459 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -2369,7 +2369,7 @@ TEBCresume( { CoroutineData *corPtr; - int yieldParameter; + size_t yieldParameter; case INST_YIELD: corPtr = iPtr->execEnvPtr->corPtr; @@ -2397,7 +2397,7 @@ TEBCresume( fflush(stdout); } #endif - yieldParameter = 0; + yieldParameter = PTR2INT(NULL); /*==CORO_ACTIVATE_YIELD*/ Tcl_SetObjResult(interp, OBJ_AT_TOS); goto doYield; @@ -2452,7 +2452,7 @@ TEBCresume( TclSetTailcall(interp, valuePtr); corPtr->yieldPtr = valuePtr; iPtr->execEnvPtr = corPtr->eePtr; - yieldParameter = (PTR2INT(NULL)+1); /*==CORO_ACTIVATE_YIELDM*/ + yieldParameter = PTR2INT(NULL)+1; /*==CORO_ACTIVATE_YIELDM*/ doYield: /* TIP #280: Record the last piece of info needed by -- cgit v0.12 From 4d7a8ad5822f483b50234b719fd70d98816f7ff6 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 11 Mar 2022 08:48:28 +0000 Subject: Fix [8a7ec8a389]: error when compiling a fat binary for Mac M1 --- generic/tclTest.c | 6 +++--- unix/tclUnixCompat.c | 5 +++-- 2 files changed, 6 insertions(+), 5 deletions(-) diff --git a/generic/tclTest.c b/generic/tclTest.c index 9c94f91..8f12715 100644 --- a/generic/tclTest.c +++ b/generic/tclTest.c @@ -326,7 +326,7 @@ static Tcl_NRPostProc NREUnwind_callback; static Tcl_ObjCmdProc TestNREUnwind; static Tcl_ObjCmdProc TestNRELevels; static Tcl_ObjCmdProc TestInterpResolverCmd; -#if defined(HAVE_CPUID) +#if defined(HAVE_CPUID) && !defined(MAC_OSX_TCL) static Tcl_ObjCmdProc TestcpuidCmd; #endif @@ -600,7 +600,7 @@ Tcltest_Init( NULL, NULL); Tcl_CreateCommand(interp, "testexitmainloop", TestexitmainloopCmd, NULL, NULL); -#if defined(HAVE_CPUID) +#if defined(HAVE_CPUID) && !defined(MAC_OSX_TCL) Tcl_CreateObjCommand(interp, "testcpuid", TestcpuidCmd, NULL, NULL); #endif @@ -6955,7 +6955,7 @@ TestFindLastCmd( return TCL_OK; } -#if defined(HAVE_CPUID) +#if defined(HAVE_CPUID) && !defined(MAC_OSX_TCL) /* *---------------------------------------------------------------------- * diff --git a/unix/tclUnixCompat.c b/unix/tclUnixCompat.c index 00e9737..2034db9 100644 --- a/unix/tclUnixCompat.c +++ b/unix/tclUnixCompat.c @@ -1003,15 +1003,16 @@ TclWinCPUID( "xchgq %%rsi, %%rbx \n\t" /* restore the old %rbx */ : "=a"(regsPtr[0]), "=S"(regsPtr[1]), "=c"(regsPtr[2]), "=d"(regsPtr[3]) : "a"(index)); -#else + status = TCL_OK; +#elif defined(__i386__) || defined(_M_IX86) __asm__ __volatile__("mov %%ebx, %%esi \n\t" /* save %ebx */ "cpuid \n\t" "xchg %%esi, %%ebx \n\t" /* restore the old %ebx */ : "=a"(regsPtr[0]), "=S"(regsPtr[1]), "=c"(regsPtr[2]), "=d"(regsPtr[3]) : "a"(index)); -#endif status = TCL_OK; #endif +#endif return status; } -- cgit v0.12 From e5fe428a4336e7ec7bf809c207bbf610877bb21e Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 11 Mar 2022 13:34:58 +0000 Subject: clarify 'yieldparameter'. Eliminate variable 'unused', reduce coroutine stackspace --- generic/tclBasic.c | 25 +++++++++++-------------- generic/tclExecute.c | 4 ++-- 2 files changed, 13 insertions(+), 16 deletions(-) diff --git a/generic/tclBasic.c b/generic/tclBasic.c index ae7a3dc..1131a09 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -233,8 +233,8 @@ MODULE_SCOPE const TclStubs tclStubs; * after particular kinds of [yield]. */ -#define CORO_ACTIVATE_YIELD PTR2INT(NULL) -#define CORO_ACTIVATE_YIELDM PTR2INT(NULL)+1 +#define CORO_ACTIVATE_YIELD (0) +#define CORO_ACTIVATE_YIELDM (1) #define COROUTINE_ARGUMENTS_SINGLE_OPTIONAL (-1) #define COROUTINE_ARGUMENTS_ARBITRARY (-2) @@ -9724,9 +9724,6 @@ TclNRCoroutineActivateCallback( TCL_UNUSED(int) /*result*/) { CoroutineData *corPtr = (CoroutineData *)data[0]; - int type = PTR2INT(data[1]); - int numLevels, unused; - int *stackLevel = &unused; if (!corPtr->stackLevel) { /* @@ -9743,8 +9740,8 @@ TclNRCoroutineActivateCallback( * the interp's environment to make it suitable to run this coroutine. */ - corPtr->stackLevel = stackLevel; - numLevels = corPtr->auxNumLevels; + corPtr->stackLevel = &corPtr; + int numLevels = corPtr->auxNumLevels; corPtr->auxNumLevels = iPtr->numLevels; SAVE_CONTEXT(corPtr->caller); @@ -9757,7 +9754,7 @@ TclNRCoroutineActivateCallback( * Coroutine is active: yield */ - if (corPtr->stackLevel != stackLevel) { + if (corPtr->stackLevel != &corPtr) { NRE_callback *runPtr; iPtr->execEnvPtr = corPtr->callerEEPtr; @@ -9781,6 +9778,7 @@ TclNRCoroutineActivateCallback( return TCL_ERROR; } + int type = PTR2INT(data[1]); if (type == CORO_ACTIVATE_YIELD) { corPtr->nargs = COROUTINE_ARGUMENTS_SINGLE_OPTIONAL; } else if (type == CORO_ACTIVATE_YIELDM) { @@ -9792,7 +9790,7 @@ TclNRCoroutineActivateCallback( corPtr->yieldPtr = NULL; corPtr->stackLevel = NULL; - numLevels = iPtr->numLevels; + int numLevels = iPtr->numLevels; iPtr->numLevels = corPtr->auxNumLevels; corPtr->auxNumLevels = numLevels - corPtr->auxNumLevels; @@ -9939,7 +9937,6 @@ TclNRCoroInjectObjCmd( Tcl_Obj *const objv[]) { CoroutineData *corPtr; - ExecEnv *savedEEPtr = iPtr->execEnvPtr; /* * Usage more or less like tailcall: @@ -9968,6 +9965,7 @@ TclNRCoroInjectObjCmd( * to happen when the coro is resumed. */ + ExecEnv *savedEEPtr = iPtr->execEnvPtr; iPtr->execEnvPtr = corPtr->eePtr; TclNRAddCallback(interp, InjectHandler, corPtr, Tcl_NewListObj(objc - 2, objv + 2), INT2PTR(corPtr->nargs), NULL); @@ -9983,10 +9981,9 @@ TclNRCoroProbeObjCmd( int objc, Tcl_Obj *const objv[]) { - CoroutineData *corPtr; ExecEnv *savedEEPtr = iPtr->execEnvPtr; - int numLevels, unused; - int *stackLevel = &unused; + int numLevels; + CoroutineData *corPtr; /* * Usage more or less like tailcall: @@ -10036,7 +10033,7 @@ TclNRCoroProbeObjCmd( * the interp's environment to make it suitable to run this coroutine. */ - corPtr->stackLevel = stackLevel; + corPtr->stackLevel = &corPtr; numLevels = corPtr->auxNumLevels; corPtr->auxNumLevels = iPtr->numLevels; diff --git a/generic/tclExecute.c b/generic/tclExecute.c index 0279218..a890d83 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -2453,7 +2453,7 @@ TEBCresume( fflush(stdout); } #endif - yieldParameter = 0; + yieldParameter = PTR2INT(NULL); /*==CORO_ACTIVATE_YIELD*/ Tcl_SetObjResult(interp, OBJ_AT_TOS); goto doYield; @@ -2508,7 +2508,7 @@ TEBCresume( TclSetTailcall(interp, valuePtr); corPtr->yieldPtr = valuePtr; iPtr->execEnvPtr = corPtr->eePtr; - yieldParameter = (PTR2INT(NULL)+1); /*==CORO_ACTIVATE_YIELDM*/ + yieldParameter = PTR2INT(NULL)+1; /*==CORO_ACTIVATE_YIELDM*/ doYield: /* TIP #280: Record the last piece of info needed by -- cgit v0.12 From 1dd0bb1ddca878a48f9d226c2ad859665022eaaf Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 11 Mar 2022 13:58:49 +0000 Subject: More tweaks --- generic/tclBasic.c | 8 ++++---- generic/tclExecute.c | 8 ++++---- 2 files changed, 8 insertions(+), 8 deletions(-) diff --git a/generic/tclBasic.c b/generic/tclBasic.c index 1131a09..4e56088 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -233,8 +233,8 @@ MODULE_SCOPE const TclStubs tclStubs; * after particular kinds of [yield]. */ -#define CORO_ACTIVATE_YIELD (0) -#define CORO_ACTIVATE_YIELDM (1) +#define CORO_ACTIVATE_YIELD NULL +#define CORO_ACTIVATE_YIELDM INT2PTR(1) #define COROUTINE_ARGUMENTS_SINGLE_OPTIONAL (-1) #define COROUTINE_ARGUMENTS_ARBITRARY (-2) @@ -9563,7 +9563,7 @@ TclNRYieldToObjCmd( corPtr->yieldPtr = listPtr; iPtr->execEnvPtr = corPtr->eePtr; - return TclNRYieldObjCmd(INT2PTR(CORO_ACTIVATE_YIELDM), interp, 1, objv); + return TclNRYieldObjCmd(CORO_ACTIVATE_YIELDM, interp, 1, objv); } static int @@ -9778,7 +9778,7 @@ TclNRCoroutineActivateCallback( return TCL_ERROR; } - int type = PTR2INT(data[1]); + void *type = data[1]; if (type == CORO_ACTIVATE_YIELD) { corPtr->nargs = COROUTINE_ARGUMENTS_SINGLE_OPTIONAL; } else if (type == CORO_ACTIVATE_YIELDM) { diff --git a/generic/tclExecute.c b/generic/tclExecute.c index a890d83..0ec2404 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -2425,7 +2425,7 @@ TEBCresume( { CoroutineData *corPtr; - int yieldParameter; + void *yieldParameter; case INST_YIELD: corPtr = iPtr->execEnvPtr->corPtr; @@ -2453,7 +2453,7 @@ TEBCresume( fflush(stdout); } #endif - yieldParameter = PTR2INT(NULL); /*==CORO_ACTIVATE_YIELD*/ + yieldParameter = NULL; /*==CORO_ACTIVATE_YIELD*/ Tcl_SetObjResult(interp, OBJ_AT_TOS); goto doYield; @@ -2508,7 +2508,7 @@ TEBCresume( TclSetTailcall(interp, valuePtr); corPtr->yieldPtr = valuePtr; iPtr->execEnvPtr = corPtr->eePtr; - yieldParameter = PTR2INT(NULL)+1; /*==CORO_ACTIVATE_YIELDM*/ + yieldParameter = INT2PTR(1); /*==CORO_ACTIVATE_YIELDM*/ doYield: /* TIP #280: Record the last piece of info needed by @@ -2526,7 +2526,7 @@ TEBCresume( cleanup = 1; TEBC_YIELD(); TclNRAddCallback(interp, TclNRCoroutineActivateCallback, corPtr, - INT2PTR(yieldParameter), NULL, NULL); + yieldParameter, NULL, NULL); return TCL_OK; } -- cgit v0.12 From c079597c246630f1982fc12887cb5b199fe98961 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 11 Mar 2022 14:52:27 +0000 Subject: Experiment: full UTF for 8.7. (WIP) --- .github/workflows/linux-build.yml | 2 +- .github/workflows/win-build.yml | 3 +-- generic/tcl.h | 6 +++++- 3 files changed, 7 insertions(+), 4 deletions(-) diff --git a/.github/workflows/linux-build.yml b/.github/workflows/linux-build.yml index b410aab..cb93bd4 100644 --- a/.github/workflows/linux-build.yml +++ b/.github/workflows/linux-build.yml @@ -7,7 +7,7 @@ jobs: matrix: cfgopt: - "" - - "CFLAGS=-DTCL_UTF_MAX=4" + - "CFLAGS=-DTCL_UTF_MAX=3" - "CFLAGS=-DTCL_NO_DEPRECATED=1" - "--disable-shared" - "--enable-symbols" diff --git a/.github/workflows/win-build.yml b/.github/workflows/win-build.yml index a8019ee..0ff696c 100644 --- a/.github/workflows/win-build.yml +++ b/.github/workflows/win-build.yml @@ -13,7 +13,6 @@ jobs: matrix: cfgopt: - "" - - "OPTS=utfmax" - "CHECKS=nodep" - "OPTS=static" - "OPTS=symbols" @@ -52,7 +51,7 @@ jobs: matrix: cfgopt: - "" - - "CFLAGS=-DTCL_UTF_MAX=4" + - "CFLAGS=-DTCL_UTF_MAX=3" - "CFLAGS=-DTCL_NO_DEPRECATED=1" - "--disable-shared" - "--enable-symbols" diff --git a/generic/tcl.h b/generic/tcl.h index b82cf0a..742a548 100644 --- a/generic/tcl.h +++ b/generic/tcl.h @@ -2128,7 +2128,11 @@ typedef struct Tcl_EncodingType { */ #ifndef TCL_UTF_MAX -#define TCL_UTF_MAX 3 +# ifdef BUILD_tcl +# define TCL_UTF_MAX 4 +# else +# define TCL_UTF_MAX 3 +# endif #endif /* -- cgit v0.12 From f4a4c6610033116db3172a719caf8cc7d32bac4f Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 11 Mar 2022 15:12:26 +0000 Subject: TIP #617 implementation fix: Don't panic on Tcl_UniCharLen() when compiled with TCL_UTF_MAX=4 --- generic/tclDecls.h | 1 - generic/tclStubInit.c | 2 -- 2 files changed, 3 deletions(-) diff --git a/generic/tclDecls.h b/generic/tclDecls.h index 87a90af..e84a7e8 100644 --- a/generic/tclDecls.h +++ b/generic/tclDecls.h @@ -4122,7 +4122,6 @@ extern const TclStubs *tclStubsPtr; #undef Tcl_GetStringResult #undef Tcl_GetDefaultEncodingDir #undef Tcl_SetDefaultEncodingDir -#undef Tcl_UniCharLen #undef Tcl_UniCharNcmp #undef Tcl_EvalTokens #undef Tcl_UniCharNcasecmp diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c index 6374ab5..1aec652 100644 --- a/generic/tclStubInit.c +++ b/generic/tclStubInit.c @@ -93,7 +93,6 @@ static void uniCodePanic(void) { # define Tcl_AppendUnicodeToObj (void(*)(Tcl_Obj *, const Tcl_UniChar *, int))(void *)uniCodePanic # define Tcl_UniCharNcasecmp (int(*)(const Tcl_UniChar *, const Tcl_UniChar *, unsigned long))(void *)uniCodePanic # define Tcl_UniCharCaseMatch (int(*)(const Tcl_UniChar *, const Tcl_UniChar *, int))(void *)uniCodePanic -# define Tcl_UniCharLen (int(*)(const Tcl_UniChar *))(void *)uniCodePanic # define Tcl_UniCharNcmp (int(*)(const Tcl_UniChar *, const Tcl_UniChar *, unsigned long))(void *)uniCodePanic #endif @@ -688,7 +687,6 @@ static int utfNcasecmp(const char *s1, const char *s2, unsigned int n){ #if TCL_UTF_MAX < 4 # define Tcl_AppendUnicodeToObj 0 # define Tcl_UniCharCaseMatch 0 -# define Tcl_UniCharLen 0 # define Tcl_UniCharNcasecmp 0 # define Tcl_UniCharNcmp 0 #endif -- cgit v0.12 From 6311ec94d64b5fada86f6b55baa95c27322faed1 Mon Sep 17 00:00:00 2001 From: dgp Date: Fri, 11 Mar 2022 16:47:29 +0000 Subject: Alternatve patch to replace UB treatment of int overflow. --- generic/tclBinary.c | 29 ++++++++++++++++------------- 1 file changed, 16 insertions(+), 13 deletions(-) diff --git a/generic/tclBinary.c b/generic/tclBinary.c index 1c97728..c0569a5 100644 --- a/generic/tclBinary.c +++ b/generic/tclBinary.c @@ -179,11 +179,12 @@ const Tcl_ObjType tclByteArrayType = { */ typedef struct ByteArray { - int used; /* The number of bytes used in the byte + unsigned int used; /* The number of bytes used in the byte * array. */ - int allocated; /* The amount of space actually allocated - * minus 1 byte. */ - unsigned char bytes[TCLFLEXARRAY]; /* The array of bytes. The actual size of this + unsigned int allocated; /* The number of bytes allocated for storage + * of the following "bytes" field. */ + unsigned char bytes[TCLFLEXARRAY]; + /* The array of bytes. The actual size of this * field depends on the 'allocated' field * above. */ } ByteArray; @@ -401,7 +402,9 @@ Tcl_SetByteArrayLength( if (objPtr->typePtr != &tclByteArrayType) { SetByteArrayFromAny(NULL, objPtr); } - + if (length < 0) { + length = 0; + } byteArrayPtr = GET_BYTEARRAY(objPtr); if (length > byteArrayPtr->allocated) { byteArrayPtr = (ByteArray *)ckrealloc(byteArrayPtr, BYTEARRAY_SIZE(length)); @@ -507,7 +510,7 @@ DupByteArrayInternalRep( Tcl_Obj *srcPtr, /* Object with internal rep to copy. */ Tcl_Obj *copyPtr) /* Object with internal rep to set. */ { - int length; + unsigned int length; ByteArray *srcArrayPtr, *copyArrayPtr; srcArrayPtr = GET_BYTEARRAY(srcPtr); @@ -549,7 +552,7 @@ UpdateStringOfByteArray( Tcl_Obj *objPtr) /* ByteArray object whose string rep to * update. */ { - int i, length, size; + unsigned int i, length, size; unsigned char *src; char *dst; ByteArray *byteArrayPtr; @@ -563,16 +566,16 @@ UpdateStringOfByteArray( */ size = length; - for (i = 0; i < length && size >= 0; i++) { + for (i = 0; i < length && size < INT_MAX; i++) { if ((src[i] == 0) || (src[i] > 127)) { - size = (int)((unsigned int)size + 1U); + size++; } } - if (size < 0) { + if (i < length) { Tcl_Panic("max size for a Tcl value (%d bytes) exceeded", INT_MAX); } - dst = (char *)ckalloc((unsigned int)size + 1U); + dst = (char *)ckalloc(size + 1U); objPtr->bytes = dst; objPtr->length = size; @@ -613,7 +616,7 @@ TclAppendBytesToByteArray( int len) { ByteArray *byteArrayPtr; - int needed; + unsigned int needed; if (Tcl_IsShared(objPtr)) { Tcl_Panic("%s called with shared object","TclAppendBytesToByteArray"); @@ -645,7 +648,7 @@ TclAppendBytesToByteArray( if (needed > byteArrayPtr->allocated) { ByteArray *ptr = NULL; - int attempt; + unsigned int attempt; if (needed <= INT_MAX/2) { /* -- cgit v0.12 From bb7ee39d95f814300c0965014259a6d7049d8507 Mon Sep 17 00:00:00 2001 From: dgp Date: Fri, 11 Mar 2022 19:30:42 +0000 Subject: Revise the loop logic to be more correct, more clear, and more consisten with other branches. --- generic/tclBinary.c | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/generic/tclBinary.c b/generic/tclBinary.c index c0569a5..8b9d510 100644 --- a/generic/tclBinary.c +++ b/generic/tclBinary.c @@ -566,12 +566,12 @@ UpdateStringOfByteArray( */ size = length; - for (i = 0; i < length && size < INT_MAX; i++) { + for (i = 0; i < length && size <= INT_MAX; i++) { if ((src[i] == 0) || (src[i] > 127)) { size++; } } - if (i < length) { + if (size > INT_MAX) { Tcl_Panic("max size for a Tcl value (%d bytes) exceeded", INT_MAX); } -- cgit v0.12 From faf6b59bc281418a6a1cdf37dbee88c7fbd2429b Mon Sep 17 00:00:00 2001 From: dgp Date: Fri, 11 Mar 2022 20:56:53 +0000 Subject: Update overflow protections to the size_t type. --- generic/tclBinary.c | 40 +++++++++++++++++++++------------------- 1 file changed, 21 insertions(+), 19 deletions(-) diff --git a/generic/tclBinary.c b/generic/tclBinary.c index dd8bbc0..1955d85 100644 --- a/generic/tclBinary.c +++ b/generic/tclBinary.c @@ -183,7 +183,9 @@ typedef struct { } ByteArray; #define BYTEARRAY_SIZE(len) \ - (offsetof(ByteArray, bytes) + (len)) + ( (offsetof(ByteArray, bytes) + (len) < offsetof(ByteArray, bytes)) \ + ? (Tcl_Panic("max size of a Tcl value exceeded"), 0) \ + : (offsetof(ByteArray, bytes) + (len)) ) #define GET_BYTEARRAY(irPtr) ((ByteArray *) (irPtr)->twoPtrValue.ptr1) #define SET_BYTEARRAY(irPtr, baPtr) \ (irPtr)->twoPtrValue.ptr1 = (baPtr) @@ -785,31 +787,28 @@ TclAppendBytesToByteArray( } byteArrayPtr = GET_BYTEARRAY(irPtr); - /* Size limit check now commented out. Used to protect calls to - * Tcl_*Alloc*() limited by unsigned int arguments. - * - if (len > UINT_MAX - byteArrayPtr->used) { - Tcl_Panic("max size for a Tcl value (%u bytes) exceeded", UINT_MAX); - } - * - */ - - needed = byteArrayPtr->used + len; /* * If we need to, resize the allocated space in the byte array. */ + needed = byteArrayPtr->used + len; + if (needed < byteArrayPtr->used) { + /* Wrapped around SIZE_MAX!! */ + Tcl_Panic("max size of a Tcl value exceeded"); + } if (needed > byteArrayPtr->allocated) { ByteArray *ptr = NULL; - size_t attempt; - if (needed <= INT_MAX/2) { - /* - * Try to allocate double the total space that is needed. - */ + /* + * Try to allocate double the total space that is needed. + */ - attempt = 2 * needed; - ptr = (ByteArray *)Tcl_AttemptRealloc(byteArrayPtr, BYTEARRAY_SIZE(attempt)); + size_t attempt = 2 * needed; + + /* Protection just in case we wrapped around SIZE_MAX */ + if (attempt >= needed) { + ptr = (ByteArray *) Tcl_AttemptRealloc(byteArrayPtr, + BYTEARRAY_SIZE(attempt)); } if (ptr == NULL) { /* @@ -817,7 +816,10 @@ TclAppendBytesToByteArray( */ attempt = needed + len + TCL_MIN_GROWTH; - ptr = (ByteArray *)Tcl_AttemptRealloc(byteArrayPtr, BYTEARRAY_SIZE(attempt)); + if (attempt >= needed) { + ptr = (ByteArray *) Tcl_AttemptRealloc(byteArrayPtr, + BYTEARRAY_SIZE(attempt)); + } } if (ptr == NULL) { /* -- cgit v0.12 From 3ab43f6d833639cadd33faec67aefb712f5a1798 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 11 Mar 2022 22:11:45 +0000 Subject: Handle TclUniCharNcmp() --- generic/tcl.decls | 2 +- generic/tclCmdMZ.c | 4 ++-- generic/tclDecls.h | 6 +++--- generic/tclInt.h | 28 ++++++++++------------------ generic/tclStringObj.c | 2 +- generic/tclStubInit.c | 15 --------------- generic/tclUtf.c | 34 +++++++++++++++++++++++++++++----- 7 files changed, 46 insertions(+), 45 deletions(-) diff --git a/generic/tcl.decls b/generic/tcl.decls index 8e21b1d..4a637ad 100644 --- a/generic/tcl.decls +++ b/generic/tcl.decls @@ -1248,7 +1248,7 @@ declare 352 { int Tcl_Char16Len(const unsigned short *uniStr) } declare 353 {deprecated {Use Tcl_UtfNcmp}} { - int Tcl_UniCharNcmp(const Tcl_UniChar *ucs, const Tcl_UniChar *uct, + int Tcl_UniCharNcmp(const unsigned short *ucs, const unsigned short *uct, unsigned long numChars) } declare 354 { diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c index f394035..5e95217 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_UniCharNcasecmp : Tcl_UniCharNcmp; + strCmpFn = nocase ? Tcl_UniCharNcasecmp : TclUniCharNcmp; wsrc = Tcl_GetUnicodeFromObj(objv[0], &slen); wstring = Tcl_GetUnicodeFromObj(objv[1], &wlen); @@ -2070,7 +2070,7 @@ StringMapCmd( } end = ustring1 + length1; - strCmpFn = (nocase ? Tcl_UniCharNcasecmp : Tcl_UniCharNcmp); + strCmpFn = (nocase ? Tcl_UniCharNcasecmp : TclUniCharNcmp); /* * Force result to be Unicode diff --git a/generic/tclDecls.h b/generic/tclDecls.h index e84a7e8..49ce21d 100644 --- a/generic/tclDecls.h +++ b/generic/tclDecls.h @@ -1066,8 +1066,8 @@ EXTERN int Tcl_UniCharIsWordChar(int ch); EXTERN int Tcl_Char16Len(const unsigned short *uniStr); /* 353 */ TCL_DEPRECATED("Use Tcl_UtfNcmp") -int Tcl_UniCharNcmp(const Tcl_UniChar *ucs, - const Tcl_UniChar *uct, +int Tcl_UniCharNcmp(const unsigned short *ucs, + const unsigned short *uct, unsigned long numChars); /* 354 */ EXTERN char * Tcl_Char16ToUtfDString(const unsigned short *uniStr, @@ -2345,7 +2345,7 @@ typedef struct TclStubs { int (*tcl_UniCharIsUpper) (int ch); /* 350 */ int (*tcl_UniCharIsWordChar) (int ch); /* 351 */ int (*tcl_Char16Len) (const unsigned short *uniStr); /* 352 */ - TCL_DEPRECATED_API("Use Tcl_UtfNcmp") int (*tcl_UniCharNcmp) (const Tcl_UniChar *ucs, const Tcl_UniChar *uct, unsigned long numChars); /* 353 */ + TCL_DEPRECATED_API("Use Tcl_UtfNcmp") int (*tcl_UniCharNcmp) (const unsigned short *ucs, const unsigned short *uct, unsigned long numChars); /* 353 */ char * (*tcl_Char16ToUtfDString) (const unsigned short *uniStr, int uniLength, Tcl_DString *dsPtr); /* 354 */ unsigned short * (*tcl_UtfToChar16DString) (const char *src, int length, Tcl_DString *dsPtr); /* 355 */ Tcl_RegExp (*tcl_GetRegExpFromObj) (Tcl_Interp *interp, Tcl_Obj *patObj, int flags); /* 356 */ diff --git a/generic/tclInt.h b/generic/tclInt.h index 2873ad3..a0f9622 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -3319,6 +3319,16 @@ MODULE_SCOPE void TclErrorStackResetIf(Tcl_Interp *interp, MODULE_SCOPE int TclZipfs_Init(Tcl_Interp *interp); +MODULE_SCOPE int *TclGetUnicode(Tcl_Obj *); +MODULE_SCOPE int *TclGetUnicodeFromObj_(Tcl_Obj *, int *); +MODULE_SCOPE Tcl_Obj *TclNewUnicodeObj(const int *, int); +MODULE_SCOPE void TclSetUnicodeObj(Tcl_Obj *, const int *, int); +MODULE_SCOPE void TclAppendUnicodeToObj(Tcl_Obj *, const int *, int); +MODULE_SCOPE int TclUniCharNcasecmp(const int *, const int *, unsigned long); +MODULE_SCOPE int TclUniCharCaseMatch(const int *, const int *, int); +MODULE_SCOPE int TclUniCharNcmp(const int *, const int *, unsigned long); + + /* * Many parsing tasks need a common definition of whitespace. * Use this routine and macro to achieve that and place @@ -4777,24 +4787,6 @@ MODULE_SCOPE int TclIsPureByteArray(Tcl_Obj *objPtr); /* *---------------------------------------------------------------- - * Macro used by the Tcl core to compare Unicode strings. On big-endian - * systems we can use the more efficient memcmp, but this would not be - * lexically correct on little-endian systems. The ANSI C "prototype" for - * this macro is: - * - * MODULE_SCOPE int TclUniCharNcmp(const Tcl_UniChar *cs, - * const Tcl_UniChar *ct, unsigned long n); - *---------------------------------------------------------------- - */ - -#if defined(WORDS_BIGENDIAN) && (TCL_UTF_MAX > 3) -# define TclUniCharNcmp(cs,ct,n) memcmp((cs),(ct),(n)*sizeof(Tcl_UniChar)) -#else /* !WORDS_BIGENDIAN */ -# define TclUniCharNcmp Tcl_UniCharNcmp -#endif /* WORDS_BIGENDIAN */ - -/* - *---------------------------------------------------------------- * Macro used by the Tcl core to increment a namespace's export epoch * counter. The ANSI C "prototype" for this macro is: * diff --git a/generic/tclStringObj.c b/generic/tclStringObj.c index 7d4aef3..521d13b 100644 --- a/generic/tclStringObj.c +++ b/generic/tclStringObj.c @@ -3492,7 +3492,7 @@ TclStringCmp( s1len *= sizeof(Tcl_UniChar); s2len *= sizeof(Tcl_UniChar); } else { - memCmpFn = (memCmpFn_t)(void *)Tcl_UniCharNcmp; + memCmpFn = (memCmpFn_t)(void *)TclUniCharNcmp; } } } diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c index 1aec652..f9430cb 100644 --- a/generic/tclStubInit.c +++ b/generic/tclStubInit.c @@ -81,21 +81,6 @@ #define TclWinConvertError (void (*)(DWORD))(void *)Tcl_WinConvertError #endif - -#if TCL_UTF_MAX > 3 -static void uniCodePanic(void) { - 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 *))(void *)uniCodePanic -# define Tcl_GetUnicodeFromObj (int *(*)(Tcl_Obj *, Tcl_UniChar *))(void *)uniCodePanic -# define Tcl_NewUnicodeObj (Tcl_Obj *(*)(const int *, Tcl_UniChar))(void *)uniCodePanic -# define Tcl_SetUnicodeObj (void(*)(Tcl_Obj *, const Tcl_UniChar *, int))(void *)uniCodePanic -# define Tcl_AppendUnicodeToObj (void(*)(Tcl_Obj *, const Tcl_UniChar *, int))(void *)uniCodePanic -# define Tcl_UniCharNcasecmp (int(*)(const Tcl_UniChar *, const Tcl_UniChar *, unsigned long))(void *)uniCodePanic -# define Tcl_UniCharCaseMatch (int(*)(const Tcl_UniChar *, const Tcl_UniChar *, int))(void *)uniCodePanic -# define Tcl_UniCharNcmp (int(*)(const Tcl_UniChar *, const Tcl_UniChar *, unsigned long))(void *)uniCodePanic -#endif - #define TclUtfCharComplete UtfCharComplete #define TclUtfNext UtfNext #define TclUtfPrev UtfPrev diff --git a/generic/tclUtf.c b/generic/tclUtf.c index 169f240..e024b65 100644 --- a/generic/tclUtf.c +++ b/generic/tclUtf.c @@ -1849,9 +1849,36 @@ Tcl_UniCharLen( */ int +TclUniCharNcmp( + 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. */ +{ +#if defined(WORDS_BIGENDIAN) && (TCL_UTF_MAX > 3) + /* + * We are definitely on a big-endian machine; memcmp() is safe + */ + + return memcmp(ucs, uct, numChars*sizeof(Tcl_UniChar)); + +#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 */ +} + +int Tcl_UniCharNcmp( - const Tcl_UniChar *ucs, /* Unicode string to compare to uct. */ - const Tcl_UniChar *uct, /* Unicode string ucs is compared to. */ + 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. */ { #if defined(WORDS_BIGENDIAN) && (TCL_UTF_MAX > 3) @@ -1868,21 +1895,18 @@ Tcl_UniCharNcmp( for ( ; numChars != 0; ucs++, uct++, numChars--) { if (*ucs != *uct) { -#if TCL_UTF_MAX < 4 /* special case for handling upper surrogates */ if (((*ucs & 0xFC00) == 0xD800) && ((*uct & 0xFC00) != 0xD800)) { return 1; } else if (((*uct & 0xFC00) == 0xD800)) { return -1; } -#endif return (*ucs - *uct); } } return 0; #endif /* WORDS_BIGENDIAN */ } - /* *---------------------------------------------------------------------- * -- cgit v0.12 From 5f4d25842d6e58ab6e37998a654b80487ae80c29 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 11 Mar 2022 22:43:51 +0000 Subject: 2 more functions --- generic/tcl.decls | 6 +- generic/tclCmdMZ.c | 4 +- generic/tclDecls.h | 12 +-- generic/tclStringObj.c | 2 +- generic/tclUtf.c | 206 ++++++++++++++++++++++++++++++++++++++++++++++--- 5 files changed, 208 insertions(+), 22 deletions(-) diff --git a/generic/tcl.decls b/generic/tcl.decls index 4a637ad..5a32bfd 100644 --- a/generic/tcl.decls +++ b/generic/tcl.decls @@ -1483,12 +1483,12 @@ declare 418 { int Tcl_IsChannelExisting(const char *channelName) } declare 419 {deprecated {Use Tcl_UtfNcasecmp}} { - int Tcl_UniCharNcasecmp(const Tcl_UniChar *ucs, const Tcl_UniChar *uct, + int Tcl_UniCharNcasecmp(const unsigned short *ucs, const unsigned short *uct, unsigned long numChars) } declare 420 {deprecated {Use Tcl_StringCaseMatch}} { - int Tcl_UniCharCaseMatch(const Tcl_UniChar *uniStr, - const Tcl_UniChar *uniPattern, int nocase) + int Tcl_UniCharCaseMatch(const unsigned short *uniStr, + const unsigned short *uniPattern, int nocase) } declare 421 { Tcl_HashEntry *Tcl_FindHashEntry(Tcl_HashTable *tablePtr, const void *key) diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c index 5e95217..b178085 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_UniCharNcasecmp : TclUniCharNcmp; + strCmpFn = nocase ? TclUniCharNcasecmp : TclUniCharNcmp; wsrc = Tcl_GetUnicodeFromObj(objv[0], &slen); wstring = Tcl_GetUnicodeFromObj(objv[1], &wlen); @@ -2070,7 +2070,7 @@ StringMapCmd( } end = ustring1 + length1; - strCmpFn = (nocase ? Tcl_UniCharNcasecmp : TclUniCharNcmp); + strCmpFn = (nocase ? TclUniCharNcasecmp : TclUniCharNcmp); /* * Force result to be Unicode diff --git a/generic/tclDecls.h b/generic/tclDecls.h index 49ce21d..0a336f1 100644 --- a/generic/tclDecls.h +++ b/generic/tclDecls.h @@ -1256,13 +1256,13 @@ EXTERN void Tcl_ClearChannelHandlers(Tcl_Channel channel); EXTERN int Tcl_IsChannelExisting(const char *channelName); /* 419 */ TCL_DEPRECATED("Use Tcl_UtfNcasecmp") -int Tcl_UniCharNcasecmp(const Tcl_UniChar *ucs, - const Tcl_UniChar *uct, +int Tcl_UniCharNcasecmp(const unsigned short *ucs, + const unsigned short *uct, unsigned long numChars); /* 420 */ TCL_DEPRECATED("Use Tcl_StringCaseMatch") -int Tcl_UniCharCaseMatch(const Tcl_UniChar *uniStr, - const Tcl_UniChar *uniPattern, int nocase); +int Tcl_UniCharCaseMatch(const unsigned short *uniStr, + const unsigned short *uniPattern, int nocase); /* 421 */ EXTERN Tcl_HashEntry * Tcl_FindHashEntry(Tcl_HashTable *tablePtr, const void *key); @@ -2411,8 +2411,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 */ - 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_DEPRECATED_API("Use Tcl_UtfNcasecmp") int (*tcl_UniCharNcasecmp) (const unsigned short *ucs, const unsigned short *uct, unsigned long numChars); /* 419 */ + TCL_DEPRECATED_API("Use Tcl_StringCaseMatch") 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 */ diff --git a/generic/tclStringObj.c b/generic/tclStringObj.c index 521d13b..4ab595f 100644 --- a/generic/tclStringObj.c +++ b/generic/tclStringObj.c @@ -3467,7 +3467,7 @@ TclStringCmp( if (nocase) { s1 = (char *) Tcl_GetUnicodeFromObj(value1Ptr, &s1len); s2 = (char *) Tcl_GetUnicodeFromObj(value2Ptr, &s2len); - memCmpFn = (memCmpFn_t)(void *)Tcl_UniCharNcasecmp; + memCmpFn = (memCmpFn_t)(void *)TclUniCharNcasecmp; } else { s1len = Tcl_GetCharLength(value1Ptr); s2len = Tcl_GetCharLength(value2Ptr); diff --git a/generic/tclUtf.c b/generic/tclUtf.c index e024b65..68a0e32 100644 --- a/generic/tclUtf.c +++ b/generic/tclUtf.c @@ -1927,30 +1927,48 @@ Tcl_UniCharNcmp( int Tcl_UniCharNcasecmp( - const Tcl_UniChar *ucs, /* Unicode string to compare to uct. */ - const Tcl_UniChar *uct, /* Unicode string ucs is compared to. */ + 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. */ { for ( ; numChars != 0; numChars--, ucs++, uct++) { if (*ucs != *uct) { - Tcl_UniChar lcs = Tcl_UniCharToLower(*ucs); - Tcl_UniChar lct = Tcl_UniCharToLower(*uct); + unsigned short lcs = Tcl_UniCharToLower(*ucs); + unsigned short lct = Tcl_UniCharToLower(*uct); if (lcs != lct) { -#if TCL_UTF_MAX < 4 /* special case for handling upper surrogates */ if (((lcs & 0xFC00) == 0xD800) && ((lct & 0xFC00) != 0xD800)) { return 1; } else if (((lct & 0xFC00) == 0xD800)) { return -1; } -#endif return (lcs - lct); } } } return 0; } + +int +TclUniCharNcasecmp( + 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; +} + /* *---------------------------------------------------------------------- @@ -2314,14 +2332,181 @@ Tcl_UniCharIsWordChar( */ int +TclUniCharCaseMatch( + 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 (TclUniCharCaseMatch(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++; + } +} + +int Tcl_UniCharCaseMatch( - const Tcl_UniChar *uniStr, /* Unicode String. */ - const Tcl_UniChar *uniPattern, + 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 */ { - Tcl_UniChar ch1 = 0, p; + unsigned short ch1 = 0, p; while (1) { p = *uniPattern; @@ -2409,7 +2594,7 @@ Tcl_UniCharCaseMatch( */ if (p == '[') { - Tcl_UniChar startChar, endChar; + unsigned short startChar, endChar; uniPattern++; ch1 = (nocase ? Tcl_UniCharToLower(*uniStr) : *uniStr); @@ -2480,6 +2665,7 @@ Tcl_UniCharCaseMatch( } } + /* *---------------------------------------------------------------------- * -- cgit v0.12 From e709f7c5392a8506414be6727a3f8b6bdd7fbae4 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Sat, 12 Mar 2022 22:30:12 +0000 Subject: More progress --- .github/workflows/linux-build.yml | 2 +- .github/workflows/win-build.yml | 3 +- generic/tcl.decls | 8 ++-- generic/tclCmdMZ.c | 10 ++--- generic/tclDecls.h | 16 +++---- generic/tclExecute.c | 2 +- generic/tclInt.h | 2 - generic/tclStringObj.c | 88 ++++++++++++++++++++------------------- generic/tclTestObj.c | 4 +- 9 files changed, 68 insertions(+), 67 deletions(-) diff --git a/.github/workflows/linux-build.yml b/.github/workflows/linux-build.yml index cb93bd4..b410aab 100644 --- a/.github/workflows/linux-build.yml +++ b/.github/workflows/linux-build.yml @@ -7,7 +7,7 @@ jobs: matrix: cfgopt: - "" - - "CFLAGS=-DTCL_UTF_MAX=3" + - "CFLAGS=-DTCL_UTF_MAX=4" - "CFLAGS=-DTCL_NO_DEPRECATED=1" - "--disable-shared" - "--enable-symbols" diff --git a/.github/workflows/win-build.yml b/.github/workflows/win-build.yml index 0ff696c..a8019ee 100644 --- a/.github/workflows/win-build.yml +++ b/.github/workflows/win-build.yml @@ -13,6 +13,7 @@ jobs: matrix: cfgopt: - "" + - "OPTS=utfmax" - "CHECKS=nodep" - "OPTS=static" - "OPTS=symbols" @@ -51,7 +52,7 @@ jobs: matrix: cfgopt: - "" - - "CFLAGS=-DTCL_UTF_MAX=3" + - "CFLAGS=-DTCL_UTF_MAX=4" - "CFLAGS=-DTCL_NO_DEPRECATED=1" - "--disable-shared" - "--enable-symbols" diff --git a/generic/tcl.decls b/generic/tcl.decls index 5a32bfd..9c83e81 100644 --- a/generic/tcl.decls +++ b/generic/tcl.decls @@ -1338,10 +1338,10 @@ 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_NewUnicodeObj(const unsigned char *unicode, int numChars) } declare 379 { - void Tcl_SetUnicodeObj(Tcl_Obj *objPtr, const Tcl_UniChar *unicode, + void Tcl_SetUnicodeObj(Tcl_Obj *objPtr, const unsigned short *unicode, int numChars) } declare 380 { @@ -1351,7 +1351,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) @@ -2417,7 +2417,7 @@ declare 651 { char *TclGetStringFromObj(Tcl_Obj *objPtr, size_t *lengthPtr) } declare 652 { - Tcl_UniChar *TclGetUnicodeFromObj(Tcl_Obj *objPtr, size_t *lengthPtr) + unsigned short *TclGetUnicodeFromObj(Tcl_Obj *objPtr, size_t *lengthPtr) } declare 653 { unsigned char *TclGetByteArrayFromObj(Tcl_Obj *objPtr, size_t *numBytesPtr) diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c index b178085..11b383f 100644 --- a/generic/tclCmdMZ.c +++ b/generic/tclCmdMZ.c @@ -619,7 +619,7 @@ 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); @@ -636,7 +636,7 @@ 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) { @@ -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) { /* @@ -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 { TclNewObj(args[idx + numParts]); @@ -2076,7 +2076,7 @@ StringMapCmd( * Force result to be Unicode */ - resultPtr = Tcl_NewUnicodeObj(ustring1, 0); + resultPtr = TclNewUnicodeObj(ustring1, 0); if (mapElemc == 2) { /* diff --git a/generic/tclDecls.h b/generic/tclDecls.h index 0a336f1..4217e9c 100644 --- a/generic/tclDecls.h +++ b/generic/tclDecls.h @@ -1142,18 +1142,18 @@ 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_NewUnicodeObj(const unsigned char *unicode, int numChars); /* 379 */ EXTERN void Tcl_SetUnicodeObj(Tcl_Obj *objPtr, - const Tcl_UniChar *unicode, int numChars); + const unsigned short *unicode, int numChars); /* 380 */ EXTERN int Tcl_GetCharLength(Tcl_Obj *objPtr); /* 381 */ 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 */ @@ -1930,7 +1930,7 @@ EXTERN unsigned char * Tcl_GetBytesFromObj(Tcl_Interp *interp, EXTERN char * TclGetStringFromObj(Tcl_Obj *objPtr, size_t *lengthPtr); /* 652 */ -EXTERN Tcl_UniChar * TclGetUnicodeFromObj(Tcl_Obj *objPtr, +EXTERN unsigned short * TclGetUnicodeFromObj(Tcl_Obj *objPtr, size_t *lengthPtr); /* 653 */ EXTERN unsigned char * TclGetByteArrayFromObj(Tcl_Obj *objPtr, @@ -2370,11 +2370,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 */ - void (*tcl_SetUnicodeObj) (Tcl_Obj *objPtr, const Tcl_UniChar *unicode, int numChars); /* 379 */ + Tcl_Obj * (*tcl_NewUnicodeObj) (const unsigned char *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") 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 */ TCL_DEPRECATED_API("Use Tcl_AppendStringsToObj") 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 */ @@ -2644,7 +2644,7 @@ typedef struct TclStubs { unsigned char * (*tclGetBytesFromObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, int *numBytesPtr); /* 649 */ unsigned char * (*tcl_GetBytesFromObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, size_t *numBytesPtr); /* 650 */ char * (*tclGetStringFromObj) (Tcl_Obj *objPtr, size_t *lengthPtr); /* 651 */ - Tcl_UniChar * (*tclGetUnicodeFromObj) (Tcl_Obj *objPtr, size_t *lengthPtr); /* 652 */ + unsigned short * (*tclGetUnicodeFromObj) (Tcl_Obj *objPtr, size_t *lengthPtr); /* 652 */ unsigned char * (*tclGetByteArrayFromObj) (Tcl_Obj *objPtr, size_t *numBytesPtr); /* 653 */ int (*tcl_UtfCharComplete) (const char *src, int length); /* 654 */ const char * (*tcl_UtfNext) (const char *src); /* 655 */ diff --git a/generic/tclExecute.c b/generic/tclExecute.c index 0279218..7cc002f 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -5514,7 +5514,7 @@ TEBCresume( } ustring3 = Tcl_GetUnicodeFromObj(value3Ptr, &length3); - objResultPtr = Tcl_NewUnicodeObj(ustring1, 0); + objResultPtr = TclNewUnicodeObj(ustring1, 0); p = ustring1; end = ustring1 + length; for (; ustring1 < end; ustring1++) { diff --git a/generic/tclInt.h b/generic/tclInt.h index a0f9622..ed607cd 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -3319,10 +3319,8 @@ MODULE_SCOPE void TclErrorStackResetIf(Tcl_Interp *interp, MODULE_SCOPE int TclZipfs_Init(Tcl_Interp *interp); -MODULE_SCOPE int *TclGetUnicode(Tcl_Obj *); MODULE_SCOPE int *TclGetUnicodeFromObj_(Tcl_Obj *, int *); MODULE_SCOPE Tcl_Obj *TclNewUnicodeObj(const int *, int); -MODULE_SCOPE void TclSetUnicodeObj(Tcl_Obj *, const int *, int); MODULE_SCOPE void TclAppendUnicodeToObj(Tcl_Obj *, const int *, int); MODULE_SCOPE int TclUniCharNcasecmp(const int *, const int *, unsigned long); MODULE_SCOPE int TclUniCharCaseMatch(const int *, const int *, int); diff --git a/generic/tclStringObj.c b/generic/tclStringObj.c index 4ab595f..972eef7 100644 --- a/generic/tclStringObj.c +++ b/generic/tclStringObj.c @@ -374,8 +374,8 @@ Tcl_DbNewStringObj( */ Tcl_Obj * -Tcl_NewUnicodeObj( - const Tcl_UniChar *unicode, /* The unicode string used to initialize the +TclNewUnicodeObj( + const int *unicode, /* The unicode string used to initialize the * new object. */ int numChars) /* Number of characters in the unicode * string. */ @@ -387,6 +387,22 @@ Tcl_NewUnicodeObj( return objPtr; } +Tcl_Obj * +Tcl_NewUnicodeObj( + const unsigned char *unicode, /* The unicode string used to initialize the + * new object. */ + int numChars) /* Number of characters in the unicode + * string. */ +{ + Tcl_Obj *objPtr; + (void)unicode; + (void)numChars; + + TclNewObj(objPtr); + /* TODO JN */ + return objPtr; +} + /* *---------------------------------------------------------------------- * @@ -612,12 +628,12 @@ Tcl_GetUniChar( #undef Tcl_GetUnicodeFromObj #ifndef TCL_NO_DEPRECATED #undef Tcl_GetUnicode -Tcl_UniChar * +unsigned short * Tcl_GetUnicode( Tcl_Obj *objPtr) /* The object to find the unicode string * for. */ { - return Tcl_GetUnicodeFromObj(objPtr, (int *)NULL); + return TclGetUnicodeFromObj(objPtr, NULL); } #endif /* TCL_NO_DEPRECATED */ @@ -663,7 +679,7 @@ Tcl_GetUnicodeFromObj( } return stringPtr->unicode; } -Tcl_UniChar * +unsigned short * TclGetUnicodeFromObj( Tcl_Obj *objPtr, /* The object to find the unicode string * for. */ @@ -671,24 +687,10 @@ TclGetUnicodeFromObj( * rep's unichar length should be stored. If * NULL, no length is stored. */ { - String *stringPtr; - - SetStringFromAny(NULL, objPtr); - stringPtr = GET_STRING(objPtr); - - if (stringPtr->hasUnicode == 0) { - FillUnicodeRep(objPtr); - stringPtr = GET_STRING(objPtr); - } - - if (lengthPtr != NULL) { -#if TCL_MAJOR_VERSION > 8 - *lengthPtr = stringPtr->numChars; -#else - *lengthPtr = ((size_t)(unsigned)(stringPtr->numChars + 1)) - 1; -#endif - } - return stringPtr->unicode; + (void)objPtr; + (void)lengthPtr; + /* TODO JN */ + return NULL; } /* @@ -797,7 +799,7 @@ Tcl_GetRange( ++last; } #endif - return Tcl_NewUnicodeObj(stringPtr->unicode + first, last - first + 1); + return TclNewUnicodeObj(stringPtr->unicode + first, last - first + 1); } /* @@ -1092,16 +1094,16 @@ Tcl_AttemptSetObjLength( void Tcl_SetUnicodeObj( Tcl_Obj *objPtr, /* The object to set the string of. */ - const Tcl_UniChar *unicode, /* The unicode string used to initialize the + const unsigned short *unicode, /* The unicode string used to initialize the * object. */ int numChars) /* Number of characters in the unicode * string. */ { - if (Tcl_IsShared(objPtr)) { - Tcl_Panic("%s called with shared object", "Tcl_SetUnicodeObj"); - } - TclFreeInternalRep(objPtr); - SetUnicodeObj(objPtr, unicode, numChars); + (void)objPtr; + (void)unicode; + (void)numChars; + + /* TODO JN */ } static int @@ -1228,7 +1230,7 @@ Tcl_AppendLimitedToObj( /* If appended string starts with a continuation byte or a lower surrogate, * force objPtr to unicode representation. See [7f1162a867] */ if (bytes && ISCONTINUATION(bytes)) { - Tcl_GetUnicode(objPtr); + Tcl_GetUnicodeFromObj(objPtr, NULL); stringPtr = GET_STRING(objPtr); } if (stringPtr->hasUnicode && stringPtr->numChars > 0) { @@ -1432,7 +1434,7 @@ Tcl_AppendObjToObj( * force objPtr to unicode representation. See [7f1162a867] * This fixes append-3.4, append-3.7 and utf-1.18 testcases. */ if (ISCONTINUATION(TclGetString(appendObjPtr))) { - Tcl_GetUnicode(objPtr); + Tcl_GetUnicodeFromObj(objPtr, NULL); stringPtr = GET_STRING(objPtr); } /* @@ -2976,7 +2978,7 @@ TclStringRepeat( */ if (!inPlace || Tcl_IsShared(objPtr)) { - objResultPtr = Tcl_NewUnicodeObj(Tcl_GetUnicode(objPtr), length); + objResultPtr = TclNewUnicodeObj(Tcl_GetUnicodeFromObj(objPtr, NULL), length); } else { TclInvalidateStringRep(objPtr); objResultPtr = objPtr; @@ -2997,7 +2999,7 @@ TclStringRepeat( Tcl_AppendObjToObj(objResultPtr, objResultPtr); done *= 2; } - Tcl_AppendUnicodeToObj(objResultPtr, Tcl_GetUnicode(objResultPtr), + Tcl_AppendUnicodeToObj(objResultPtr, Tcl_GetUnicodeFromObj(objResultPtr, NULL), (count - done) * length); } else { /* @@ -3318,12 +3320,12 @@ TclStringCat( } return NULL; } - dst = Tcl_GetUnicode(objResultPtr) + start; + dst = Tcl_GetUnicodeFromObj(objResultPtr, NULL) + start; } else { 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) { @@ -3335,7 +3337,7 @@ TclStringCat( } return NULL; } - dst = Tcl_GetUnicode(objResultPtr); + dst = Tcl_GetUnicodeFromObj(objResultPtr, NULL); } while (objc--) { Tcl_Obj *objPtr = *objv++; @@ -3479,8 +3481,8 @@ TclStringCmp( s2 = value2Ptr->bytes; memCmpFn = memcmp; } else { - s1 = (char *) Tcl_GetUnicode(value1Ptr); - s2 = (char *) Tcl_GetUnicode(value2Ptr); + s1 = (char *) Tcl_GetUnicodeFromObj(value1Ptr, NULL); + s2 = (char *) Tcl_GetUnicodeFromObj(value2Ptr, NULL); if ( #if defined(WORDS_BIGENDIAN) && (TCL_UTF_MAX > 3) 1 @@ -3854,7 +3856,7 @@ TclStringReverse( stringPtr = GET_STRING(objPtr); if (stringPtr->hasUnicode) { - Tcl_UniChar *from = Tcl_GetUnicode(objPtr); + Tcl_UniChar *from = Tcl_GetUnicodeFromObj(objPtr, NULL); stringPtr = GET_STRING(objPtr); Tcl_UniChar *src = from + stringPtr->numChars; Tcl_UniChar *to; @@ -3865,9 +3867,9 @@ 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); + to = Tcl_GetUnicodeFromObj(objPtr, NULL); stringPtr = GET_STRING(objPtr); while (--src >= from) { #if TCL_UTF_MAX < 4 @@ -4101,7 +4103,7 @@ TclStringReplace( /* 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); } diff --git a/generic/tclTestObj.c b/generic/tclTestObj.c index a235002..9814cfe 100644 --- a/generic/tclTestObj.c +++ b/generic/tclTestObj.c @@ -13,7 +13,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ - +#undef BUILD_tcl #ifndef USE_TCL_STUBS # define USE_TCL_STUBS #endif @@ -1153,7 +1153,7 @@ TeststringobjCmd( int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - Tcl_UniChar *unicode; + unsigned short *unicode; size_t varIndex; int size, option, i; Tcl_WideInt length; -- cgit v0.12 From d05ac0b98bbc039639b7784e313620b8d3757ddf Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Sat, 12 Mar 2022 23:21:12 +0000 Subject: Start defining "utf32string" type --- generic/tcl.decls | 4 +- generic/tclCmdMZ.c | 62 +++++++++++----------- generic/tclDecls.h | 8 +-- generic/tclExecute.c | 18 +++---- generic/tclRegexp.c | 2 +- generic/tclStringObj.c | 139 ++++++++++++++++++++++++++++++++++--------------- generic/tclTestObj.c | 1 + generic/tclUtil.c | 4 +- tests/string.test | 2 +- 9 files changed, 149 insertions(+), 91 deletions(-) diff --git a/generic/tcl.decls b/generic/tcl.decls index 9c83e81..6dbb457 100644 --- a/generic/tcl.decls +++ b/generic/tcl.decls @@ -1357,7 +1357,7 @@ declare 383 { Tcl_Obj *Tcl_GetRange(Tcl_Obj *objPtr, int first, int last) } declare 384 {deprecated {Use Tcl_AppendStringsToObj}} { - void Tcl_AppendUnicodeToObj(Tcl_Obj *objPtr, const Tcl_UniChar *unicode, + void Tcl_AppendUnicodeToObj(Tcl_Obj *objPtr, const unsigned short *unicode, int length) } declare 385 { @@ -1541,7 +1541,7 @@ declare 433 { # introduced in 8.4a3 declare 434 { - Tcl_UniChar *Tcl_GetUnicodeFromObj(Tcl_Obj *objPtr, int *lengthPtr) + unsigned short *Tcl_GetUnicodeFromObj(Tcl_Obj *objPtr, int *lengthPtr) } # TIP#15 (math function introspection) dkf diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c index 11b383f..db4002a 100644 --- a/generic/tclCmdMZ.c +++ b/generic/tclCmdMZ.c @@ -606,9 +606,9 @@ Tcl_RegsubObjCmd( nocase = (cflags & TCL_REG_NOCASE); strCmpFn = nocase ? TclUniCharNcasecmp : TclUniCharNcmp; - 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; @@ -622,8 +622,8 @@ Tcl_RegsubObjCmd( 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; @@ -640,14 +640,14 @@ Tcl_RegsubObjCmd( 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; @@ -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 @@ -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, @@ -2060,7 +2060,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. @@ -2089,7 +2089,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)) { /* @@ -2098,7 +2098,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) || @@ -2106,14 +2106,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); } } } @@ -2134,7 +2134,7 @@ StringMapCmd( u2lc = (int *)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]); @@ -2158,7 +2158,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; @@ -2174,7 +2174,7 @@ StringMapCmd( * Append the map value to the unicode string. */ - Tcl_AppendUnicodeToObj(resultPtr, + TclAppendUnicodeToObj(resultPtr, mapStrings[index+1], mapLens[index+1]); break; } @@ -2191,7 +2191,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: @@ -2506,7 +2506,7 @@ StringStartCmd( return TCL_ERROR; } - string = Tcl_GetUnicodeFromObj(objv[1], &length); + string = TclGetUnicodeFromObj_(objv[1], &length); if (TclGetIntForIndexM(interp, objv[2], length-1, &index) != TCL_OK) { return TCL_ERROR; } @@ -2576,7 +2576,7 @@ StringEndCmd( return TCL_ERROR; } - string = Tcl_GetUnicodeFromObj(objv[1], &length); + string = TclGetUnicodeFromObj_(objv[1], &length); if (TclGetIntForIndexM(interp, objv[2], length-1, &index) != TCL_OK) { return TCL_ERROR; } diff --git a/generic/tclDecls.h b/generic/tclDecls.h index 4217e9c..bf15862 100644 --- a/generic/tclDecls.h +++ b/generic/tclDecls.h @@ -1159,7 +1159,7 @@ EXTERN Tcl_Obj * Tcl_GetRange(Tcl_Obj *objPtr, int first, int last); /* 384 */ TCL_DEPRECATED("Use Tcl_AppendStringsToObj") void Tcl_AppendUnicodeToObj(Tcl_Obj *objPtr, - const Tcl_UniChar *unicode, int length); + const unsigned short *unicode, int length); /* 385 */ EXTERN int Tcl_RegExpMatchObj(Tcl_Interp *interp, Tcl_Obj *textObj, Tcl_Obj *patternObj); @@ -1304,7 +1304,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, +EXTERN unsigned short * Tcl_GetUnicodeFromObj(Tcl_Obj *objPtr, int *lengthPtr); /* 435 */ TCL_DEPRECATED("") @@ -2376,7 +2376,7 @@ typedef struct TclStubs { 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 */ - TCL_DEPRECATED_API("Use Tcl_AppendStringsToObj") void (*tcl_AppendUnicodeToObj) (Tcl_Obj *objPtr, const Tcl_UniChar *unicode, int length); /* 384 */ + TCL_DEPRECATED_API("Use Tcl_AppendStringsToObj") 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) (const Tcl_NotifierProcs *notifierProcPtr); /* 386 */ Tcl_Mutex * (*tcl_GetAllocMutex) (void); /* 387 */ @@ -2426,7 +2426,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_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/tclExecute.c b/generic/tclExecute.c index 7cc002f..7a1025d 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -5495,12 +5495,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; @@ -5512,7 +5512,7 @@ TEBCresume( } goto doneStringMap; } - ustring3 = Tcl_GetUnicodeFromObj(value3Ptr, &length3); + ustring3 = TclGetUnicodeFromObj_(value3Ptr, &length3); objResultPtr = TclNewUnicodeObj(ustring1, 0); p = ustring1; @@ -5524,14 +5524,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) { @@ -5539,7 +5539,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 => ", @@ -5565,7 +5565,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) { int ch; @@ -5596,8 +5596,8 @@ TEBCresume( || TclHasInternalRep(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/tclRegexp.c b/generic/tclRegexp.c index 8e588ac..bb8a6ad 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 972eef7..a723586 100644 --- a/generic/tclStringObj.c +++ b/generic/tclStringObj.c @@ -80,14 +80,41 @@ static void UpdateStringOfString(Tcl_Obj *objPtr); * functions that can be invoked by generic object code. */ -const Tcl_ObjType tclStringType = { - "string", /* name */ +static const Tcl_ObjType utf32StringType = { + "utf32string", /* name */ FreeStringInternalRep, /* freeIntRepPro */ DupStringInternalRep, /* dupIntRepProc */ UpdateStringOfString, /* updateStringProc */ SetStringFromAny /* setFromAnyProc */ }; +typedef struct { + int numChars; /* The number of chars in the string. */ + int allocated; /* The amount of space actually allocated for + * the UTF-16 string (minus 1 byte for the + * termination char). */ + int maxChars; /* Max number of chars that can fit in the + * space allocated for the UTF-16 array. */ + int hasUnicode; /* Boolean determining whether the string has + * a UTF-16 representation. Always 1 */ + unsigned short unicode[TCLFLEXARRAY]; /* The array of Unicode chars. The actual size + * of this field depends on the 'maxChars' + * field above. */ +} UTF16String; + +const Tcl_ObjType tclStringType = { + "string", /* name */ + FreeStringInternalRep, /* freeIntRepPro */ +#if 0 + /* TODO JN */ + DupUTF16StringInternalRep, /* dupIntRepProc */ + UpdateUTF16StringOfString, /* updateStringProc */ + SetUTF16StringFromAny /* setFromAnyProc */ +#endif + NULL, NULL, NULL +}; + + /* * TCL STRING GROWTH ALGORITHM * @@ -656,8 +683,8 @@ Tcl_GetUnicode( *---------------------------------------------------------------------- */ -Tcl_UniChar * -Tcl_GetUnicodeFromObj( +int * +TclGetUnicodeFromObj_( Tcl_Obj *objPtr, /* The object to find the unicode string * for. */ int *lengthPtr) /* If non-NULL, the location where the string @@ -679,6 +706,22 @@ Tcl_GetUnicodeFromObj( } return stringPtr->unicode; } + +unsigned short * +Tcl_GetUnicodeFromObj( + Tcl_Obj *objPtr, /* The object to find the unicode string + * for. */ + int *lengthPtr) /* If non-NULL, the location where the string + * rep's unichar length should be stored. If + * NULL, no length is stored. */ +{ + (void)objPtr; + (void)lengthPtr; + + /* TODO JN */ + return NULL; +} + unsigned short * TclGetUnicodeFromObj( Tcl_Obj *objPtr, /* The object to find the unicode string @@ -1142,7 +1185,7 @@ SetUnicodeObj( stringCheckLimits(numChars); stringPtr = stringAlloc(numChars); SET_STRING(objPtr, stringPtr); - objPtr->typePtr = &tclStringType; + objPtr->typePtr = &utf32StringType; stringPtr->maxChars = numChars; memcpy(stringPtr->unicode, unicode, numChars * sizeof(Tcl_UniChar)); @@ -1230,7 +1273,7 @@ Tcl_AppendLimitedToObj( /* If appended string starts with a continuation byte or a lower surrogate, * force objPtr to unicode representation. See [7f1162a867] */ if (bytes && ISCONTINUATION(bytes)) { - Tcl_GetUnicodeFromObj(objPtr, NULL); + TclGetUnicodeFromObj_(objPtr, NULL); stringPtr = GET_STRING(objPtr); } if (stringPtr->hasUnicode && stringPtr->numChars > 0) { @@ -1298,9 +1341,9 @@ 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 + const int *unicode, /* The unicode string to append to the * object. */ int length) /* Number of chars in "unicode". */ { @@ -1330,6 +1373,20 @@ Tcl_AppendUnicodeToObj( } } +void +Tcl_AppendUnicodeToObj( + Tcl_Obj *objPtr, /* Points to the object to append to. */ + const unsigned short *unicode, /* The unicode string to append to the + * object. */ + int length) /* Number of chars in "unicode". */ +{ + (void)objPtr; + (void)unicode; + (void)length; + + /* TODO JN */ +} + /* *---------------------------------------------------------------------- * @@ -1434,7 +1491,7 @@ Tcl_AppendObjToObj( * force objPtr to unicode representation. See [7f1162a867] * This fixes append-3.4, append-3.7 and utf-1.18 testcases. */ if (ISCONTINUATION(TclGetString(appendObjPtr))) { - Tcl_GetUnicodeFromObj(objPtr, NULL); + TclGetUnicodeFromObj_(objPtr, NULL); stringPtr = GET_STRING(objPtr); } /* @@ -1447,9 +1504,9 @@ Tcl_AppendObjToObj( * If appendObjPtr is not of the "String" type, don't convert it. */ - if (TclHasInternalRep(appendObjPtr, &tclStringType)) { + if (TclHasInternalRep(appendObjPtr, &utf32StringType)) { Tcl_UniChar *unicode = - Tcl_GetUnicodeFromObj(appendObjPtr, &numChars); + TclGetUnicodeFromObj_(appendObjPtr, &numChars); AppendUnicodeToUnicodeRep(objPtr, unicode, numChars); } else { @@ -1468,7 +1525,7 @@ Tcl_AppendObjToObj( bytes = TclGetStringFromObj(appendObjPtr, &length); numChars = stringPtr->numChars; - if ((numChars >= 0) && TclHasInternalRep(appendObjPtr, &tclStringType)) { + if ((numChars >= 0) && TclHasInternalRep(appendObjPtr, &utf32StringType)) { String *appendStringPtr = GET_STRING(appendObjPtr); appendNumChars = appendStringPtr->numChars; @@ -2877,7 +2934,7 @@ TclGetStringStorage( { String *stringPtr; - if (!TclHasInternalRep(objPtr, &tclStringType) || objPtr->bytes == NULL) { + if (!TclHasInternalRep(objPtr, &utf32StringType) || objPtr->bytes == NULL) { return TclGetStringFromObj(objPtr, (int *)sizePtr); } @@ -2925,7 +2982,7 @@ TclStringRepeat( */ if (!binary) { - if (TclHasInternalRep(objPtr, &tclStringType)) { + if (TclHasInternalRep(objPtr, &utf32StringType)) { String *stringPtr = GET_STRING(objPtr); if (stringPtr->hasUnicode) { unichar = 1; @@ -2938,7 +2995,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); @@ -2978,7 +3035,7 @@ TclStringRepeat( */ if (!inPlace || Tcl_IsShared(objPtr)) { - objResultPtr = TclNewUnicodeObj(Tcl_GetUnicodeFromObj(objPtr, NULL), length); + objResultPtr = TclNewUnicodeObj(TclGetUnicodeFromObj_(objPtr, NULL), length); } else { TclInvalidateStringRep(objPtr); objResultPtr = objPtr; @@ -2999,7 +3056,7 @@ TclStringRepeat( Tcl_AppendObjToObj(objResultPtr, objResultPtr); done *= 2; } - Tcl_AppendUnicodeToObj(objResultPtr, Tcl_GetUnicodeFromObj(objResultPtr, NULL), + TclAppendUnicodeToObj(objResultPtr, TclGetUnicodeFromObj_(objResultPtr, NULL), (count - done) * length); } else { /* @@ -3096,7 +3153,7 @@ TclStringCat( binary = 0; if (ov > objv+1 && ISCONTINUATION(TclGetString(objPtr))) { forceUniChar = 1; - } else if ((objPtr->typePtr) && (objPtr->typePtr != &tclStringType)) { + } else if ((objPtr->typePtr) && (objPtr->typePtr != &utf32StringType)) { /* Prevent shimmer of non-string types. */ allowUniChar = 0; } @@ -3104,7 +3161,7 @@ TclStringCat( } else { /* assert (objPtr->typePtr != NULL) -- stork! */ binary = 0; - if (TclHasInternalRep(objPtr, &tclStringType)) { + if (TclHasInternalRep(objPtr, &utf32StringType)) { /* Have a pure Unicode value; ask to preserve it */ requestUniChar = 1; } else { @@ -3158,7 +3215,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) { @@ -3308,7 +3365,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) { @@ -3320,7 +3377,7 @@ TclStringCat( } return NULL; } - dst = Tcl_GetUnicodeFromObj(objResultPtr, NULL) + start; + dst = TclGetUnicodeFromObj_(objResultPtr, NULL) + start; } else { Tcl_UniChar ch = 0; @@ -3337,14 +3394,14 @@ TclStringCat( } return NULL; } - dst = Tcl_GetUnicodeFromObj(objResultPtr, NULL); + dst = TclGetUnicodeFromObj_(objResultPtr, NULL); } while (objc--) { Tcl_Obj *objPtr = *objv++; 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; } @@ -3457,8 +3514,8 @@ TclStringCmp( s1 = (char *) Tcl_GetByteArrayFromObj(value1Ptr, &s1len); s2 = (char *) Tcl_GetByteArrayFromObj(value2Ptr, &s2len); memCmpFn = memcmp; - } else if (TclHasInternalRep(value1Ptr, &tclStringType) - && TclHasInternalRep(value2Ptr, &tclStringType)) { + } else if (TclHasInternalRep(value1Ptr, &utf32StringType) + && TclHasInternalRep(value2Ptr, &utf32StringType)) { /* * Do a unicode-specific comparison if both of the args are of * String type. If the char length == byte length, we can do a @@ -3467,8 +3524,8 @@ TclStringCmp( */ if (nocase) { - s1 = (char *) Tcl_GetUnicodeFromObj(value1Ptr, &s1len); - s2 = (char *) Tcl_GetUnicodeFromObj(value2Ptr, &s2len); + s1 = (char *) TclGetUnicodeFromObj_(value1Ptr, &s1len); + s2 = (char *) TclGetUnicodeFromObj_(value2Ptr, &s2len); memCmpFn = (memCmpFn_t)(void *)TclUniCharNcasecmp; } else { s1len = Tcl_GetCharLength(value1Ptr); @@ -3481,8 +3538,8 @@ TclStringCmp( s2 = value2Ptr->bytes; memCmpFn = memcmp; } else { - s1 = (char *) Tcl_GetUnicodeFromObj(value1Ptr, NULL); - s2 = (char *) Tcl_GetUnicodeFromObj(value2Ptr, NULL); + s1 = (char *) TclGetUnicodeFromObj_(value1Ptr, NULL); + s2 = (char *) TclGetUnicodeFromObj_(value2Ptr, NULL); if ( #if defined(WORDS_BIGENDIAN) && (TCL_UTF_MAX > 3) 1 @@ -3680,8 +3737,8 @@ TclStringFirst( * do only the well-defined Tcl_UniChar array search. */ - un = Tcl_GetUnicodeFromObj(needle, &ln); - uh = Tcl_GetUnicodeFromObj(haystack, &lh); + un = TclGetUnicodeFromObj_(needle, &ln); + uh = TclGetUnicodeFromObj_(haystack, &lh); if ((lh < ln) || (start > lh - ln)) { /* Don't start the loop if there cannot be a valid answer */ goto firstEnd; @@ -3763,8 +3820,8 @@ TclStringLast( goto lastEnd; } - uh = Tcl_GetUnicodeFromObj(haystack, &lh); - un = Tcl_GetUnicodeFromObj(needle, &ln); + uh = TclGetUnicodeFromObj_(haystack, &lh); + un = TclGetUnicodeFromObj_(needle, &ln); if (last >= lh) { last = lh - 1; @@ -3856,7 +3913,7 @@ TclStringReverse( stringPtr = GET_STRING(objPtr); if (stringPtr->hasUnicode) { - Tcl_UniChar *from = Tcl_GetUnicodeFromObj(objPtr, NULL); + Tcl_UniChar *from = TclGetUnicodeFromObj_(objPtr, NULL); stringPtr = GET_STRING(objPtr); Tcl_UniChar *src = from + stringPtr->numChars; Tcl_UniChar *to; @@ -3869,7 +3926,7 @@ TclStringReverse( objPtr = TclNewUnicodeObj(&ch, 1); Tcl_SetObjLength(objPtr, stringPtr->numChars); - to = Tcl_GetUnicodeFromObj(objPtr, NULL); + to = TclGetUnicodeFromObj_(objPtr, NULL); stringPtr = GET_STRING(objPtr); while (--src >= from) { #if TCL_UTF_MAX < 4 @@ -4099,7 +4156,7 @@ 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? */ @@ -4108,7 +4165,7 @@ TclStringReplace( Tcl_AppendObjToObj(result, insertPtr); } if (first + count < numChars) { - Tcl_AppendUnicodeToObj(result, ustring + first + count, + TclAppendUnicodeToObj(result, ustring + first + count, numChars - first - count); } @@ -4267,7 +4324,7 @@ DupStringInternalRep( copyStringPtr->allocated = copyPtr->bytes ? copyPtr->length : 0; SET_STRING(copyPtr, copyStringPtr); - copyPtr->typePtr = &tclStringType; + copyPtr->typePtr = &utf32StringType; } /* @@ -4292,7 +4349,7 @@ SetStringFromAny( TCL_UNUSED(Tcl_Interp *), Tcl_Obj *objPtr) /* The object to convert. */ { - if (!TclHasInternalRep(objPtr, &tclStringType)) { + if (!TclHasInternalRep(objPtr, &utf32StringType)) { String *stringPtr = stringAlloc(0); /* @@ -4312,7 +4369,7 @@ SetStringFromAny( stringPtr->maxChars = 0; stringPtr->hasUnicode = 0; SET_STRING(objPtr, stringPtr); - objPtr->typePtr = &tclStringType; + objPtr->typePtr = &utf32StringType; } return TCL_OK; } diff --git a/generic/tclTestObj.c b/generic/tclTestObj.c index 9814cfe..e99d4c1 100644 --- a/generic/tclTestObj.c +++ b/generic/tclTestObj.c @@ -1076,6 +1076,7 @@ TestobjCmd( #ifndef TCL_WIDE_INT_IS_LONG if (!strcmp(typeName, "wideInt")) typeName = "int"; #endif + if (!strcmp(typeName, "utf32string")) typeName = "string"; Tcl_SetObjResult(interp, Tcl_NewStringObj(typeName, -1)); } } else if (strcmp(subCmd, "refcount") == 0) { diff --git a/generic/tclUtil.c b/generic/tclUtil.c index 66d1009..9cc82cb 100644 --- a/generic/tclUtil.c +++ b/generic/tclUtil.c @@ -2594,8 +2594,8 @@ TclStringMatchObj( if (TclHasInternalRep(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/tests/string.test b/tests/string.test index 203d0c6..9cac73d 100644 --- a/tests/string.test +++ b/tests/string.test @@ -422,7 +422,7 @@ test string-4.16.$noComp {string first, normal string vs pure unicode string} -b # Representation checks are canaries run {list [representationpoke $s] [representationpoke $m] \ [string first $m $s]} -} -result {{string 1} {string 0} 2} +} -result {{utf32string 1} {utf32string 0} 2} test string-4.17.$noComp {string first, corner case} -body { run {string first a aaa 4294967295} } -result {-1} -- cgit v0.12 From 031021992f4f8175c8cbe0f7710d790d5f0793a2 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Sat, 12 Mar 2022 23:25:25 +0000 Subject: Fix 2 warnings: warning C4018: '>': signed/unsigned mismatch --- generic/tclBinary.c | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/generic/tclBinary.c b/generic/tclBinary.c index 8b9d510..703c35b 100644 --- a/generic/tclBinary.c +++ b/generic/tclBinary.c @@ -406,7 +406,7 @@ Tcl_SetByteArrayLength( length = 0; } byteArrayPtr = GET_BYTEARRAY(objPtr); - if (length > byteArrayPtr->allocated) { + if ((unsigned int)length > byteArrayPtr->allocated) { byteArrayPtr = (ByteArray *)ckrealloc(byteArrayPtr, BYTEARRAY_SIZE(length)); byteArrayPtr->allocated = length; SET_BYTEARRAY(objPtr, byteArrayPtr); @@ -637,7 +637,7 @@ TclAppendBytesToByteArray( } byteArrayPtr = GET_BYTEARRAY(objPtr); - if (len > INT_MAX - byteArrayPtr->used) { + if ((unsigned int)len > INT_MAX - byteArrayPtr->used) { Tcl_Panic("max size for a Tcl value (%d bytes) exceeded", INT_MAX); } -- cgit v0.12 From 9fdb32b8e254da15698c28d65e281ee946a57eb5 Mon Sep 17 00:00:00 2001 From: oehhar Date: Mon, 14 Mar 2022 15:46:35 +0000 Subject: TIP607 encoding failindex: start implementation --- generic/tclCmdAH.c | 66 +++++++++++++++++++++++++++++++++++++++--------------- 1 file changed, 48 insertions(+), 18 deletions(-) diff --git a/generic/tclCmdAH.c b/generic/tclCmdAH.c index 60a2c42..96bac4e 100644 --- a/generic/tclCmdAH.c +++ b/generic/tclCmdAH.c @@ -556,28 +556,59 @@ EncodingConvertfromObjCmd( int flags = TCL_ENCODING_NOCOMPLAIN; #endif size_t result; + Tcl_Obj *failVarObj = NULL; + int i, encodingSeen = 0; + /* + * Decode parameters: + * Possible combinations: + * 1) data -> objc = 2 + * 2) encoding data -> objc = 3 + * 3) -nocomplain data -> objc = 3 (8.7) + * 4) -nocomplain encoding data -> objc = 4 (8.7) + * 5) -failindex val data -> objc = 4 + * 6) -failindex val encoding data -> objc = 5 + * 7a) -nocomplain -failindex val data -> objc = 5 + * 7b) -failindex val -nocomplain data -> objc = 5 + * 8a) -nocomplain -failindex val encoding data -> objc = 6 + * 8b) -failindex val -nocomplain encoding data -> objc = 6 + */ - if (objc == 2) { - encoding = Tcl_GetEncoding(interp, NULL); - data = objv[1]; - } else if ((unsigned)(objc - 2) < 3) { + if (objc > 1 && objc < 7) { + int noComplaintSeen = 0; + int encodingSeen = 0; data = objv[objc - 1]; - bytesPtr = Tcl_GetString(objv[1]); - if (bytesPtr[0] == '-' && bytesPtr[1] == 'n' - && !strncmp(bytesPtr, "-nocomplain", strlen(bytesPtr))) { - flags = TCL_ENCODING_NOCOMPLAIN; - } else if (objc < 4) { - if (Tcl_GetEncodingFromObj(interp, objv[objc - 2], &encoding) != TCL_OK) { - return TCL_ERROR; + for(i = 1; i < objc-1 ; i++ ) { + bytesPtr = Tcl_GetString(objv[i]); + if (bytesPtr[0] == '-' && bytesPtr[1] == 'n' + && !strncmp(bytesPtr, "-nocomplain", strlen(bytesPtr))) { + if (noComplaintSeen) { + goto encConvFromError; + } + flags = TCL_ENCODING_NOCOMPLAIN; + noComplaintSeen = 1; + } else if (bytesPtr[0] == '-' && bytesPtr[1] == 'f' + && !strncmp(bytesPtr, "-failindex", strlen(bytesPtr))) { + /* at least two additional arguments needed */ + if (objc < i + 3) { + goto encConvFromError; + } + if (failVarObj != NULL) { + goto encConvFromError; + } + i++; + failVarObj = objv[i]; + flags = TCL_ENCODING_NOCOMPLAIN; + } else if (i == objc - 2) { + if (Tcl_GetEncodingFromObj(interp, objv[i], &encoding) != TCL_OK) { + return TCL_ERROR; + } + encodingSeen = 1; + } else { + goto encConvFromError; } - goto encConvFromOK; - } else { - goto encConvFromError; } - if (objc < 4) { + if (!encodingSeen) { encoding = Tcl_GetEncoding(interp, NULL); - } else if (Tcl_GetEncodingFromObj(interp, objv[objc - 2], &encoding) != TCL_OK) { - return TCL_ERROR; } } else { encConvFromError: @@ -585,7 +616,6 @@ EncodingConvertfromObjCmd( return TCL_ERROR; } -encConvFromOK: /* * Convert the string into a byte array in 'ds' */ -- cgit v0.12 From 46ed0441c3f458d86557c1813efb3b34c389a0e3 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 14 Mar 2022 16:06:23 +0000 Subject: More progress --- .github/workflows/linux-build.yml | 2 +- .github/workflows/win-build.yml | 4 ++-- generic/tcl.decls | 2 +- generic/tclDecls.h | 4 ++-- generic/tclInt.h | 21 +++++++++++++----- generic/tclStringObj.c | 34 +++++++++++++++++++++-------- generic/tclTestObj.c | 3 ++- generic/tclUtf.c | 46 ++++++++++++++++++++++----------------- tests/stringObj.test | 44 ++++++++++++++++++------------------- win/makefile.vc | 4 ++-- win/rules.vc | 6 ++--- 11 files changed, 101 insertions(+), 69 deletions(-) diff --git a/.github/workflows/linux-build.yml b/.github/workflows/linux-build.yml index b410aab..cb93bd4 100644 --- a/.github/workflows/linux-build.yml +++ b/.github/workflows/linux-build.yml @@ -7,7 +7,7 @@ jobs: matrix: cfgopt: - "" - - "CFLAGS=-DTCL_UTF_MAX=4" + - "CFLAGS=-DTCL_UTF_MAX=3" - "CFLAGS=-DTCL_NO_DEPRECATED=1" - "--disable-shared" - "--enable-symbols" diff --git a/.github/workflows/win-build.yml b/.github/workflows/win-build.yml index a8019ee..547d27e 100644 --- a/.github/workflows/win-build.yml +++ b/.github/workflows/win-build.yml @@ -13,7 +13,7 @@ jobs: matrix: cfgopt: - "" - - "OPTS=utfmax" + - "OPTS=utf16" - "CHECKS=nodep" - "OPTS=static" - "OPTS=symbols" @@ -52,7 +52,7 @@ jobs: matrix: cfgopt: - "" - - "CFLAGS=-DTCL_UTF_MAX=4" + - "CFLAGS=-DTCL_UTF_MAX=3" - "CFLAGS=-DTCL_NO_DEPRECATED=1" - "--disable-shared" - "--enable-symbols" diff --git a/generic/tcl.decls b/generic/tcl.decls index 6dbb457..f5b2e78 100644 --- a/generic/tcl.decls +++ b/generic/tcl.decls @@ -1338,7 +1338,7 @@ declare 377 { void Tcl_RegExpGetInfo(Tcl_RegExp regexp, Tcl_RegExpInfo *infoPtr) } declare 378 { - Tcl_Obj *Tcl_NewUnicodeObj(const unsigned char *unicode, int numChars) + Tcl_Obj *Tcl_NewUnicodeObj(const unsigned short *unicode, int numChars) } declare 379 { void Tcl_SetUnicodeObj(Tcl_Obj *objPtr, const unsigned short *unicode, diff --git a/generic/tclDecls.h b/generic/tclDecls.h index bf15862..1952641 100644 --- a/generic/tclDecls.h +++ b/generic/tclDecls.h @@ -1142,7 +1142,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 unsigned char *unicode, +EXTERN Tcl_Obj * Tcl_NewUnicodeObj(const unsigned short *unicode, int numChars); /* 379 */ EXTERN void Tcl_SetUnicodeObj(Tcl_Obj *objPtr, @@ -2370,7 +2370,7 @@ 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 unsigned char *unicode, int numChars); /* 378 */ + 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 */ diff --git a/generic/tclInt.h b/generic/tclInt.h index ed607cd..2a04aca 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -3319,12 +3319,21 @@ MODULE_SCOPE void TclErrorStackResetIf(Tcl_Interp *interp, MODULE_SCOPE int TclZipfs_Init(Tcl_Interp *interp); -MODULE_SCOPE int *TclGetUnicodeFromObj_(Tcl_Obj *, int *); -MODULE_SCOPE Tcl_Obj *TclNewUnicodeObj(const int *, int); -MODULE_SCOPE void TclAppendUnicodeToObj(Tcl_Obj *, const int *, int); -MODULE_SCOPE int TclUniCharNcasecmp(const int *, const int *, unsigned long); -MODULE_SCOPE int TclUniCharCaseMatch(const int *, const int *, int); -MODULE_SCOPE int TclUniCharNcmp(const int *, const int *, unsigned long); +#if TCL_UTF_MAX > 3 + MODULE_SCOPE int *TclGetUnicodeFromObj_(Tcl_Obj *, int *); + MODULE_SCOPE Tcl_Obj *TclNewUnicodeObj(const int *, int); + MODULE_SCOPE void TclAppendUnicodeToObj(Tcl_Obj *, const int *, int); + MODULE_SCOPE int TclUniCharNcasecmp(const int *, const int *, unsigned long); + MODULE_SCOPE int TclUniCharCaseMatch(const int *, const int *, int); + MODULE_SCOPE int TclUniCharNcmp(const int *, const int *, unsigned long); +#else +# define TclGetUnicodeFromObj_ Tcl_GetUnicodeFromObj +# define TclNewUnicodeObj Tcl_NewUnicodeObj +# define TclAppendUnicodeToObj Tcl_AppendUnicodeToObj +# define TclUniCharNcasecmp Tcl_UniCharNcasecmp +# define TclUniCharCaseMatch Tcl_UniCharCaseMatch +# define TclUniCharNcmp Tcl_UniCharNcmp +#endif /* diff --git a/generic/tclStringObj.c b/generic/tclStringObj.c index 8730331..eb5103d 100644 --- a/generic/tclStringObj.c +++ b/generic/tclStringObj.c @@ -55,8 +55,6 @@ static void AppendUtfToUtfRep(Tcl_Obj *objPtr, const char *bytes, int numBytes); static void DupStringInternalRep(Tcl_Obj *objPtr, Tcl_Obj *copyPtr); -static void DupUTF16StringInternalRep(Tcl_Obj *objPtr, - Tcl_Obj *copyPtr); static int ExtendStringRepWithUnicode(Tcl_Obj *objPtr, const Tcl_UniChar *unicode, int numChars); static void ExtendUnicodeRepWithString(Tcl_Obj *objPtr, @@ -67,12 +65,16 @@ static void FreeStringInternalRep(Tcl_Obj *objPtr); static void GrowStringBuffer(Tcl_Obj *objPtr, int needed, int flag); static void GrowUnicodeBuffer(Tcl_Obj *objPtr, int needed); static int SetStringFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr); -static int SetUTF16StringFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr); static void SetUnicodeObj(Tcl_Obj *objPtr, const Tcl_UniChar *unicode, int numChars); static int UnicodeLength(const Tcl_UniChar *unicode); static void UpdateStringOfString(Tcl_Obj *objPtr); +#if TCL_UTF_MAX < 4 +static void DupUTF16StringInternalRep(Tcl_Obj *objPtr, + Tcl_Obj *copyPtr); +static int SetUTF16StringFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr); static void UpdateStringOfUTF16String(Tcl_Obj *objPtr); +#endif #define ISCONTINUATION(bytes) (\ ((((bytes)[0] & 0xC0) == 0x80) || (((bytes)[0] == '\xED') \ @@ -84,6 +86,12 @@ static void UpdateStringOfUTF16String(Tcl_Obj *objPtr); * functions that can be invoked by generic object code. */ +#if TCL_UTF_MAX > 3 + +#define utf32StringType tclStringType + +#else + static const Tcl_ObjType utf32StringType = { "utf32string", /* name */ FreeStringInternalRep, /* freeIntRepPro */ @@ -125,7 +133,7 @@ DupUTF16StringInternalRep( size_t size = offsetof(UTF16String, unicode) + (((srcStringPtr->numChars) + 1U) * sizeof(unsigned short)); UTF16String *copyStringPtr = (UTF16String *)ckalloc(size); memcpy(copyStringPtr, srcStringPtr, size); - copyStringPtr->allocated = srcStringPtr->numChars; + copyStringPtr->allocated = srcStringPtr->numChars + 1; copyStringPtr->maxChars = srcStringPtr->numChars; copyPtr->internalRep.twoPtrValue.ptr1 = copyStringPtr; @@ -156,7 +164,7 @@ SetUTF16StringFromAny( */ stringPtr->numChars = 0; - stringPtr->allocated = objPtr->length; + stringPtr->allocated = objPtr->length + 1; stringPtr->maxChars = objPtr->length; stringPtr->hasUnicode = 1; objPtr->internalRep.twoPtrValue.ptr1 = stringPtr; @@ -172,6 +180,8 @@ UpdateStringOfUTF16String( (void)objPtr; } +#endif + /* * TCL STRING GROWTH ALGORITHM * @@ -459,7 +469,7 @@ Tcl_DbNewStringObj( Tcl_Obj * TclNewUnicodeObj( - const int *unicode, /* The unicode string used to initialize the + const Tcl_UniChar *unicode, /* The unicode string used to initialize the * new object. */ int numChars) /* Number of characters in the unicode * string. */ @@ -471,9 +481,10 @@ TclNewUnicodeObj( return objPtr; } +#if TCL_UTF_MAX > 3 Tcl_Obj * Tcl_NewUnicodeObj( - const unsigned char *unicode, /* The unicode string used to initialize the + const unsigned short *unicode, /* The unicode string used to initialize the * new object. */ int numChars) /* Number of characters in the unicode * string. */ @@ -486,6 +497,7 @@ Tcl_NewUnicodeObj( /* TODO JN */ return objPtr; } +#endif /* *---------------------------------------------------------------------- @@ -740,7 +752,7 @@ Tcl_GetUnicode( *---------------------------------------------------------------------- */ -int * +Tcl_UniChar * TclGetUnicodeFromObj_( Tcl_Obj *objPtr, /* The object to find the unicode string * for. */ @@ -764,6 +776,7 @@ TclGetUnicodeFromObj_( return stringPtr->unicode; } +#if TCL_UTF_MAX > 3 unsigned short * Tcl_GetUnicodeFromObj( Tcl_Obj *objPtr, /* The object to find the unicode string @@ -778,6 +791,7 @@ Tcl_GetUnicodeFromObj( /* TODO JN */ return NULL; } +#endif unsigned short * TclGetUnicodeFromObj( @@ -1400,7 +1414,7 @@ Tcl_AppendToObj( void TclAppendUnicodeToObj( Tcl_Obj *objPtr, /* Points to the object to append to. */ - const int *unicode, /* The unicode string to append to the + const Tcl_UniChar *unicode, /* The unicode string to append to the * object. */ int length) /* Number of chars in "unicode". */ { @@ -1430,6 +1444,7 @@ TclAppendUnicodeToObj( } } +#if TCL_UTF_MAX > 3 void Tcl_AppendUnicodeToObj( Tcl_Obj *objPtr, /* Points to the object to append to. */ @@ -1443,6 +1458,7 @@ Tcl_AppendUnicodeToObj( /* TODO JN */ } +#endif /* *---------------------------------------------------------------------- diff --git a/generic/tclTestObj.c b/generic/tclTestObj.c index 9814cfe..9884a9a 100644 --- a/generic/tclTestObj.c +++ b/generic/tclTestObj.c @@ -1073,8 +1073,9 @@ TestobjCmd( Tcl_SetObjResult(interp, Tcl_NewStringObj("none", -1)); } else { typeName = objv[2]->typePtr->name; + if (!strcmp(typeName, "utf32string")) typeName = "string"; #ifndef TCL_WIDE_INT_IS_LONG - if (!strcmp(typeName, "wideInt")) typeName = "int"; + else if (!strcmp(typeName, "wideInt")) typeName = "int"; #endif Tcl_SetObjResult(interp, Tcl_NewStringObj(typeName, -1)); } diff --git a/generic/tclUtf.c b/generic/tclUtf.c index 68a0e32..02f4358 100644 --- a/generic/tclUtf.c +++ b/generic/tclUtf.c @@ -1850,8 +1850,8 @@ Tcl_UniCharLen( int TclUniCharNcmp( - const int *ucs, /* Unicode string to compare to uct. */ - const int *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. */ { #if defined(WORDS_BIGENDIAN) && (TCL_UTF_MAX > 3) @@ -1875,6 +1875,7 @@ TclUniCharNcmp( #endif /* WORDS_BIGENDIAN */ } +#if TCL_UTF_MAX > 3 int Tcl_UniCharNcmp( const unsigned short *ucs, /* Unicode string to compare to uct. */ @@ -1907,6 +1908,7 @@ Tcl_UniCharNcmp( return 0; #endif /* WORDS_BIGENDIAN */ } +#endif /* *---------------------------------------------------------------------- * @@ -1926,23 +1928,17 @@ Tcl_UniCharNcmp( */ int -Tcl_UniCharNcasecmp( - const unsigned short *ucs, /* Unicode string to compare to uct. */ - const unsigned short *uct, /* Unicode string ucs is compared to. */ +TclUniCharNcasecmp( + 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. */ { for ( ; numChars != 0; numChars--, ucs++, uct++) { if (*ucs != *uct) { - unsigned short lcs = Tcl_UniCharToLower(*ucs); - unsigned short lct = Tcl_UniCharToLower(*uct); + int lcs = Tcl_UniCharToLower(*ucs); + int lct = Tcl_UniCharToLower(*uct); if (lcs != lct) { - /* special case for handling upper surrogates */ - if (((lcs & 0xFC00) == 0xD800) && ((lct & 0xFC00) != 0xD800)) { - return 1; - } else if (((lct & 0xFC00) == 0xD800)) { - return -1; - } return (lcs - lct); } } @@ -1950,24 +1946,32 @@ Tcl_UniCharNcasecmp( return 0; } +#if TCL_UTF_MAX > 3 int -TclUniCharNcasecmp( - const int *ucs, /* Unicode string to compare to uct. */ - const int *uct, /* Unicode string ucs is compared to. */ +Tcl_UniCharNcasecmp( + 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. */ { for ( ; numChars != 0; numChars--, ucs++, uct++) { if (*ucs != *uct) { - int lcs = Tcl_UniCharToLower(*ucs); - int lct = Tcl_UniCharToLower(*uct); + unsigned short lcs = Tcl_UniCharToLower(*ucs); + unsigned short lct = Tcl_UniCharToLower(*uct); if (lcs != lct) { + /* special case for handling upper surrogates */ + if (((lcs & 0xFC00) == 0xD800) && ((lct & 0xFC00) != 0xD800)) { + return 1; + } else if (((lct & 0xFC00) == 0xD800)) { + return -1; + } return (lcs - lct); } } } return 0; } +#endif /* @@ -2333,8 +2337,8 @@ Tcl_UniCharIsWordChar( int TclUniCharCaseMatch( - const int *uniStr, /* Unicode String. */ - const int *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 */ @@ -2498,6 +2502,7 @@ TclUniCharCaseMatch( } } +#if TCL_UTF_MAX > 3 int Tcl_UniCharCaseMatch( const unsigned short *uniStr, /* Unicode String. */ @@ -2664,6 +2669,7 @@ Tcl_UniCharCaseMatch( uniPattern++; } } +#endif /* diff --git a/tests/stringObj.test b/tests/stringObj.test index a2bdf95..abe02b2 100644 --- a/tests/stringObj.test +++ b/tests/stringObj.test @@ -190,12 +190,12 @@ test stringObj-7.3 {SetStringFromAny called with non-string obj} testobj { set x 2345 list [incr x] [testobj objtype $x] [string index $x end] \ [testobj objtype $x] -} {2346 int 6 utf32string} +} {2346 int 6 string} test stringObj-7.4 {SetStringFromAny called with string obj} testobj { set x "abcdef" list [string length $x] [testobj objtype $x] \ [string length $x] [testobj objtype $x] -} {6 utf32string 6 utf32string} +} {6 string 6 string} test stringObj-8.1 {DupStringInternalRep procedure} testobj { testobj freeallvars @@ -213,28 +213,28 @@ test stringObj-8.2 {DupUnicodeInternalRep, mixed width chars} testobj { set y $x list [testobj objtype $x] [testobj objtype $y] [append x "\xAE\xBF\xEF"] \ [set y] [testobj objtype $x] [testobj objtype $y] -} "utf32string utf32string abc\xEF\xBF\xAEghi\xAE\xBF\xEF abc\xEF\xBF\xAEghi utf32string utf32string" +} "string string abc\xEF\xBF\xAEghi\xAE\xBF\xEF abc\xEF\xBF\xAEghi string string" test stringObj-8.3 {DupUnicodeInternalRep, mixed width chars} testobj { set x abc\xEF\xBF\xAEghi set y $x string length $x list [testobj objtype $x] [testobj objtype $y] [append x "\xAE\xBF\xEF"] \ [set y] [testobj objtype $x] [testobj objtype $y] -} "utf32string utf32string abc\xEF\xBF\xAEghi\xAE\xBF\xEF abc\xEF\xBF\xAEghi utf32string utf32string" +} "string string abc\xEF\xBF\xAEghi\xAE\xBF\xEF abc\xEF\xBF\xAEghi string string" test stringObj-8.4 {DupUnicodeInternalRep, all byte-size chars} testobj { set x abcdefghi string length $x set y $x list [testobj objtype $x] [testobj objtype $y] [append x jkl] \ [set y] [testobj objtype $x] [testobj objtype $y] -} {utf32string utf32string abcdefghijkl abcdefghi utf32string utf32string} +} {string string abcdefghijkl abcdefghi string string} test stringObj-8.5 {DupUnicodeInternalRep, all byte-size chars} testobj { set x abcdefghi set y $x string length $x list [testobj objtype $x] [testobj objtype $y] [append x jkl] \ [set y] [testobj objtype $x] [testobj objtype $y] -} {utf32string utf32string abcdefghijkl abcdefghi utf32string utf32string} +} {string string abcdefghijkl abcdefghi string string} test stringObj-9.1 {TclAppendObjToObj, mixed src & dest} {testobj testdstring} { set x abc\xEF\xBF\xAEghi @@ -244,15 +244,15 @@ test stringObj-9.1 {TclAppendObjToObj, mixed src & dest} {testobj testdstring} { string length $x list [testobj objtype $x] [testobj objtype $y] [append x $y] \ [set y] [testobj objtype $x] [testobj objtype $y] -} "utf32string none abc\xEF\xBF\xAEghi\xAE\xBF\xEF \xAE\xBF\xEF utf32string none" +} "string none abc\xEF\xBF\xAEghi\xAE\xBF\xEF \xAE\xBF\xEF string none" test stringObj-9.2 {TclAppendObjToObj, mixed src & dest} testobj { set x abc\xEF\xBF\xAEghi string length $x list [testobj objtype $x] [append x $x] [testobj objtype $x] \ [append x $x] [testobj objtype $x] -} "utf32string abc\xEF\xBF\xAEghiabc\xEF\xBF\xAEghi utf32string\ +} "string abc\xEF\xBF\xAEghiabc\xEF\xBF\xAEghi string\ abc\xEF\xBF\xAEghiabc\xEF\xBF\xAEghiabc\xEF\xBF\xAEghiabc\xEF\xBF\xAEghi\ -utf32string" +string" test stringObj-9.3 {TclAppendObjToObj, mixed src & 1-byte dest} {testobj testdstring} { set x abcdefghi testdstring free @@ -261,7 +261,7 @@ test stringObj-9.3 {TclAppendObjToObj, mixed src & 1-byte dest} {testobj testdst string length $x list [testobj objtype $x] [testobj objtype $y] [append x $y] \ [set y] [testobj objtype $x] [testobj objtype $y] -} "utf32string none abcdefghi\xAE\xBF\xEF \xAE\xBF\xEF utf32string none" +} "string none abcdefghi\xAE\xBF\xEF \xAE\xBF\xEF string none" test stringObj-9.4 {TclAppendObjToObj, 1-byte src & dest} {testobj testdstring} { set x abcdefghi testdstring free @@ -270,14 +270,14 @@ test stringObj-9.4 {TclAppendObjToObj, 1-byte src & dest} {testobj testdstring} string length $x list [testobj objtype $x] [testobj objtype $y] [append x $y] \ [set y] [testobj objtype $x] [testobj objtype $y] -} {utf32string none abcdefghijkl jkl utf32string none} +} {string none abcdefghijkl jkl string none} test stringObj-9.5 {TclAppendObjToObj, 1-byte src & dest} testobj { set x abcdefghi string length $x list [testobj objtype $x] [append x $x] [testobj objtype $x] \ [append x $x] [testobj objtype $x] -} {utf32string abcdefghiabcdefghi utf32string abcdefghiabcdefghiabcdefghiabcdefghi\ -utf32string} +} {string abcdefghiabcdefghi string abcdefghiabcdefghiabcdefghiabcdefghi\ +string} test stringObj-9.6 {TclAppendObjToObj, 1-byte src & mixed dest} {testobj testdstring} { set x abc\xEF\xBF\xAEghi testdstring free @@ -286,33 +286,33 @@ test stringObj-9.6 {TclAppendObjToObj, 1-byte src & mixed dest} {testobj testdst string length $x list [testobj objtype $x] [testobj objtype $y] [append x $y] \ [set y] [testobj objtype $x] [testobj objtype $y] -} "utf32string none abc\xEF\xBF\xAEghijkl jkl utf32string none" +} "string none abc\xEF\xBF\xAEghijkl jkl string none" test stringObj-9.7 {TclAppendObjToObj, integer src & dest} testobj { set x [expr {4 * 5}] set y [expr {4 + 5}] list [testobj objtype $x] [testobj objtype $y] [append x $y] \ [testobj objtype $x] [append x $y] [testobj objtype $x] \ [testobj objtype $y] -} {int int 209 utf32string 2099 utf32string int} +} {int int 209 string 2099 string int} test stringObj-9.8 {TclAppendObjToObj, integer src & dest} testobj { set x [expr {4 * 5}] list [testobj objtype $x] [append x $x] [testobj objtype $x] \ [append x $x] [testobj objtype $x] -} {int 2020 utf32string 20202020 utf32string} +} {int 2020 string 20202020 string} test stringObj-9.9 {TclAppendObjToObj, integer src & 1-byte dest} testobj { set x abcdefghi set y [expr {4 + 5}] string length $x list [testobj objtype $x] [testobj objtype $y] [append x $y] \ [set y] [testobj objtype $x] [testobj objtype $y] -} {utf32string int abcdefghi9 9 utf32string int} +} {string int abcdefghi9 9 string int} test stringObj-9.10 {TclAppendObjToObj, integer src & mixed dest} testobj { set x abc\xEF\xBF\xAEghi set y [expr {4 + 5}] string length $x list [testobj objtype $x] [testobj objtype $y] [append x $y] \ [set y] [testobj objtype $x] [testobj objtype $y] -} "utf32string int abc\xEF\xBF\xAEghi9 9 utf32string int" +} "string int abc\xEF\xBF\xAEghi9 9 string int" test stringObj-9.11 {TclAppendObjToObj, mixed src & 1-byte dest index check} testobj { # bug 2678, in <=8.2.0, the second obj (the one to append) in # Tcl_AppendObjToObj was not correctly checked to see if it was all one @@ -336,20 +336,20 @@ test stringObj-10.1 {Tcl_GetRange with all byte-size chars} {testobj testdstring set x [testdstring get] list [testobj objtype $x] [set y [string range $x 1 end-1]] \ [testobj objtype $x] [testobj objtype $y] -} [list none bcde utf32string utf32string] +} [list none bcde string string] test stringObj-10.2 {Tcl_GetRange with some mixed width chars} {testobj testdstring} { testdstring free testdstring append "abcïïdef" -1 set x [testdstring get] list [testobj objtype $x] [set y [string range $x 1 end-1]] \ [testobj objtype $x] [testobj objtype $y] -} [list none "bcïïde" utf32string utf32string] +} [list none "bcïïde" string string] test stringObj-10.3 {Tcl_GetRange with some mixed width chars} testobj { set x "abcïïdef" string length $x list [testobj objtype $x] [set y [string range $x 1 end-1]] \ [testobj objtype $x] [testobj objtype $y] -} [list utf32string "bcïïde" utf32string utf32string] +} [list string "bcïïde" string string] test stringObj-10.4 {Tcl_GetRange with some mixed width chars} testobj { set a "ïa¿b®cï¿d®" set result [list] @@ -368,7 +368,7 @@ test stringObj-11.1 {UpdateStringOfString} testobj { set x 2345 list [string index $x end] [testobj objtype $x] [incr x] \ [testobj objtype $x] -} {5 utf32string 2346 int} +} {5 string 2346 int} test stringObj-12.1 {Tcl_GetUniChar with byte-size chars} testobj { set x "abcdefghi" diff --git a/win/makefile.vc b/win/makefile.vc index 1ef64f2..6ff6118 100644 --- a/win/makefile.vc +++ b/win/makefile.vc @@ -52,7 +52,7 @@ # turn on the 64-bit compiler, if your SDK has it. # # Basic macros and options usable on the commandline (see rules.vc for more info): -# OPTS=msvcrt,noembed,nothreads,pdbs,profile,static,symbols,thrdalloc,time64bit,unchecked,utfmax,none +# OPTS=msvcrt,noembed,nothreads,pdbs,profile,static,symbols,thrdalloc,time64bit,unchecked,utf16,none # Sets special options for the core. The default is for none. # Any combination of the above may be used (comma separated). # 'none' will over-ride everything to nothing. @@ -80,7 +80,7 @@ # unchecked = Allows a symbols build to not use the debug # enabled runtime (msvcrt.dll not msvcrtd.dll # or libcmt.lib not libcmtd.lib). -# utfmax = Forces a build using UTF-32 representation internally. +# utf16 = Forces a build using UTF-16 representation internally. # # STATS=compdbg,memdbg,none # Sets optional memory and bytecode compiler debugging code added diff --git a/win/rules.vc b/win/rules.vc index 372d70a..713e7f9 100644 --- a/win/rules.vc +++ b/win/rules.vc @@ -884,9 +884,9 @@ USE_THREAD_ALLOC= 0 _USE_64BIT_TIME_T = 1 !endif -!if [nmakehlp -f $(OPTS) "utfmax"] -!message *** Force allowing 4-byte UTF-8 sequences internally -TCL_UTF_MAX = 4 +!if [nmakehlp -f $(OPTS) "utf16"] +!message *** Force UTF-16 internally +TCL_UTF_MAX = 3 !endif !endif -- cgit v0.12 From e1f11871dd6bf0d90bef16897153fd0c00c9d136 Mon Sep 17 00:00:00 2001 From: oehhar Date: Mon, 14 Mar 2022 16:10:27 +0000 Subject: TIP607 encoding failindex: options -failindex and -nocomplain may not both be specified --- generic/tclCmdAH.c | 67 +++++++++++++++++++++++------------------------------- 1 file changed, 29 insertions(+), 38 deletions(-) diff --git a/generic/tclCmdAH.c b/generic/tclCmdAH.c index 96bac4e..6c15630 100644 --- a/generic/tclCmdAH.c +++ b/generic/tclCmdAH.c @@ -557,7 +557,6 @@ EncodingConvertfromObjCmd( #endif size_t result; Tcl_Obj *failVarObj = NULL; - int i, encodingSeen = 0; /* * Decode parameters: * Possible combinations: @@ -567,52 +566,44 @@ EncodingConvertfromObjCmd( * 4) -nocomplain encoding data -> objc = 4 (8.7) * 5) -failindex val data -> objc = 4 * 6) -failindex val encoding data -> objc = 5 - * 7a) -nocomplain -failindex val data -> objc = 5 - * 7b) -failindex val -nocomplain data -> objc = 5 - * 8a) -nocomplain -failindex val encoding data -> objc = 6 - * 8b) -failindex val -nocomplain encoding data -> objc = 6 */ - if (objc > 1 && objc < 7) { - int noComplaintSeen = 0; - int encodingSeen = 0; + if (objc == 2) { + encoding = Tcl_GetEncoding(interp, NULL); + data = objv[1]; + } else if ((unsigned)(objc - 2) < 4) { + int objcUnprocessed = objc; data = objv[objc - 1]; - for(i = 1; i < objc-1 ; i++ ) { - bytesPtr = Tcl_GetString(objv[i]); - if (bytesPtr[0] == '-' && bytesPtr[1] == 'n' - && !strncmp(bytesPtr, "-nocomplain", strlen(bytesPtr))) { - if (noComplaintSeen) { - goto encConvFromError; - } - flags = TCL_ENCODING_NOCOMPLAIN; - noComplaintSeen = 1; - } else if (bytesPtr[0] == '-' && bytesPtr[1] == 'f' - && !strncmp(bytesPtr, "-failindex", strlen(bytesPtr))) { - /* at least two additional arguments needed */ - if (objc < i + 3) { - goto encConvFromError; - } - if (failVarObj != NULL) { - goto encConvFromError; - } - i++; - failVarObj = objv[i]; - flags = TCL_ENCODING_NOCOMPLAIN; - } else if (i == objc - 2) { - if (Tcl_GetEncodingFromObj(interp, objv[i], &encoding) != TCL_OK) { - return TCL_ERROR; - } - encodingSeen = 1; - } else { + bytesPtr = Tcl_GetString(objv[1]); + if (bytesPtr[0] == '-' && bytesPtr[1] == 'n' + && !strncmp(bytesPtr, "-nocomplain", strlen(bytesPtr))) { + flags = TCL_ENCODING_NOCOMPLAIN; + objcUnprocessed--; + } else if (bytesPtr[0] == '-' && bytesPtr[1] == 'f' + && !strncmp(bytesPtr, "-failindex", strlen(bytesPtr))) { + /* at least two additional arguments needed */ + if (objc < 4) { goto encConvFromError; } + failVarObj = objv[2]; + flags = TCL_ENCODING_NOCOMPLAIN; + objcUnprocessed -= 2; } - if (!encodingSeen) { - encoding = Tcl_GetEncoding(interp, NULL); + switch (objcUnprocessed) { + case 2: + if (Tcl_GetEncodingFromObj(interp, objv[objc - 2], &encoding) != TCL_OK) { + return TCL_ERROR; + } + break; + case 1: + encoding = Tcl_GetEncoding(interp, NULL); + break; + default: + goto encConvFromError; } } else { encConvFromError: - Tcl_WrongNumArgs(interp, 1, objv, "?-nocomplain? ?encoding? data"); + Tcl_WrongNumArgs(interp, 1, objv, "?-nocomplain|-failindex var? ?encoding? data"); return TCL_ERROR; } -- cgit v0.12 From 938fc2c7a0aef1a5d7655f1e0227d57b6d518f1d Mon Sep 17 00:00:00 2001 From: oehhar Date: Mon, 14 Mar 2022 17:39:22 +0000 Subject: TIP607 encoding failindex: some tests and implementation (not working) --- generic/tclCmdAH.c | 37 ++++++++++++++++++++++++------------- tests/encoding.test | 28 +++++++++++++++++++++++++++- 2 files changed, 51 insertions(+), 14 deletions(-) diff --git a/generic/tclCmdAH.c b/generic/tclCmdAH.c index 6c15630..5b95e51 100644 --- a/generic/tclCmdAH.c +++ b/generic/tclCmdAH.c @@ -555,7 +555,7 @@ EncodingConvertfromObjCmd( #else int flags = TCL_ENCODING_NOCOMPLAIN; #endif - size_t result; + size_t result, errorPosition = 0; Tcl_Obj *failVarObj = NULL; /* * Decode parameters: @@ -571,7 +571,7 @@ EncodingConvertfromObjCmd( if (objc == 2) { encoding = Tcl_GetEncoding(interp, NULL); data = objv[1]; - } else if ((unsigned)(objc - 2) < 4) { + } else if (objc > 2 && objc < 6) { int objcUnprocessed = objc; data = objv[objc - 1]; bytesPtr = Tcl_GetString(objv[1]); @@ -586,16 +586,16 @@ EncodingConvertfromObjCmd( goto encConvFromError; } failVarObj = objv[2]; - flags = TCL_ENCODING_NOCOMPLAIN; + flags = TCL_ENCODING_STOPONERROR; objcUnprocessed -= 2; } switch (objcUnprocessed) { - case 2: + case 3: if (Tcl_GetEncodingFromObj(interp, objv[objc - 2], &encoding) != TCL_OK) { return TCL_ERROR; } break; - case 1: + case 2: encoding = Tcl_GetEncoding(interp, NULL); break; default: @@ -622,14 +622,25 @@ EncodingConvertfromObjCmd( result = Tcl_ExternalToUtfDStringEx(encoding, bytesPtr, length, flags, &ds); if ((flags & TCL_ENCODING_STOPONERROR) && (result != (size_t)-1)) { - char buf[TCL_INTEGER_SPACE]; - sprintf(buf, "%" TCL_Z_MODIFIER "u", result); - Tcl_SetObjResult(interp, Tcl_ObjPrintf("unexpected byte sequence starting at index %" - TCL_Z_MODIFIER "u: '\\x%X'", result, UCHAR(bytesPtr[result]))); - Tcl_SetErrorCode(interp, "TCL", "ENCODING", "ILLEGALSEQUENCE", - buf, NULL); - Tcl_DStringFree(&ds); - return TCL_ERROR; + if (failVarObj != NULL) { + /* I hope, wide int will cover size_t data type */ + if (Tcl_ObjSetVar2(interp, failVarObj, NULL, Tcl_NewWideIntObj(result), TCL_LEAVE_ERR_MSG) == NULL) { + return TCL_ERROR; + } + } else { + char buf[TCL_INTEGER_SPACE]; + sprintf(buf, "%" TCL_Z_MODIFIER "u", result); + Tcl_SetObjResult(interp, Tcl_ObjPrintf("unexpected byte sequence starting at index %" + TCL_Z_MODIFIER "u: '\\x%X'", result, UCHAR(bytesPtr[result]))); + Tcl_SetErrorCode(interp, "TCL", "ENCODING", "ILLEGALSEQUENCE", + buf, NULL); + Tcl_DStringFree(&ds); + return TCL_ERROR; + } + } else if (failVarObj != NULL) { + if (Tcl_ObjSetVar2(interp, failVarObj, NULL, Tcl_NewIntObj(-1), TCL_LEAVE_ERR_MSG) == NULL) { + return TCL_ERROR; + } } /* diff --git a/tests/encoding.test b/tests/encoding.test index bf82493..7020077 100644 --- a/tests/encoding.test +++ b/tests/encoding.test @@ -669,10 +669,36 @@ test encoding-24.21 {Parse with -nocomplain but without providing encoding} { } 1 test encoding-24.22 {Syntax error, two encodings} -body { encoding convertfrom iso8859-1 utf-8 "ZX\uD800" -} -returnCodes 1 -result {wrong # args: should be "::tcl::encoding::convertfrom ?-nocomplain? ?encoding? data"} +} -returnCodes 1 -result {wrong # args: should be "::tcl::encoding::convertfrom ?-nocomplain|-failindex var? ?encoding? data"} test encoding-24.23 {Syntax error, two encodings} -body { encoding convertto iso8859-1 utf-8 "ZX\uD800" } -returnCodes 1 -result {wrong # args: should be "::tcl::encoding::convertto ?-nocomplain? ?encoding? data"} +test encoding-24.24 {Syntax error, no parameter} -body { + encoding convertfrom +} -returnCodes 1 -result {wrong # args: should be "encoding convertfrom ?-nocomplain|-failindex var? ?encoding? data"} +test encoding-24.25 {Syntax error, -nocomplain and -failindex, no encoding} -body { + encoding convertfrom -nocomplain -failindex 2 ABC +} -returnCodes 1 -result {wrong # args: should be "encoding convertfrom ?-nocomplain|-failindex var? ?encoding? data"} +test encoding-24.26 {Syntax error, -failindex and -nocomplain, no encoding} -body { + encoding convertfrom -failindex 2 -nocomplain ABC +} -returnCodes 1 -result {unknown encoding "-nocomplain"} +test encoding-24.27 {Syntax error, -nocomplain and -failindex, encoding} -body { + encoding convertfrom -nocomplain -failindex 2 utf-8 ABC +} -returnCodes 1 -result {wrong # args: should be "encoding convertfrom ?-nocomplain|-failindex var? ?encoding? data"} +test encoding-24.28 {Syntax error, -failindex and -nocomplain, encoding} -body { + encoding convertfrom -failindex 2 -nocomplain utf-8 ABC +} -returnCodes 1 -result {wrong # args: should be "encoding convertfrom ?-nocomplain|-failindex var? ?encoding? data"} +test encoding-24.29 {Syntax error, -failindex with no var, no encoding} -body { + encoding convertfrom -failindex ABC +} -returnCodes 1 -result {wrong # args: should be "::tcl::encoding::convertfrom ?-nocomplain|-failindex var? ?encoding? data"} +test encoding-24.30 {convertrom -failindex with correct data} -body { + encoding convertfrom -failindex test ABC + set test +} -returnCodes 0 -result -1 +test encoding-24.31 {convertrom -failindex with incomplete utf8} -body { + set res [encoding convertfrom -failindex test A\xc3] + lappend res $test +} -returnCodes 0 -result {A 1} file delete [file join [temporaryDirectory] iso2022.txt] -- cgit v0.12 From 2fc2f3a009206556a3f311f7905d3923e058d881 Mon Sep 17 00:00:00 2001 From: oehhar Date: Mon, 14 Mar 2022 18:15:03 +0000 Subject: Add "const" to TclObjLookupVar parameter 6 and 7 to avoid compiler failure on MS-VC 2015. Hope this is ok... --- generic/tclIntDecls.h | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/generic/tclIntDecls.h b/generic/tclIntDecls.h index 48cec3d..8430fae 100644 --- a/generic/tclIntDecls.h +++ b/generic/tclIntDecls.h @@ -484,8 +484,8 @@ EXTERN int TclPtrMakeUpvar(Tcl_Interp *interp, Var *otherP1Ptr, /* 230 */ EXTERN Var * TclObjLookupVar(Tcl_Interp *interp, Tcl_Obj *part1Ptr, const char *part2, - int flags, const char *msg, int createPart1, - int createPart2, Var **arrayPtrPtr); + int flags, const char *msg, const int createPart1, + const int createPart2, Var **arrayPtrPtr); /* 231 */ EXTERN int TclGetNamespaceFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr, Tcl_Namespace **nsPtrPtr); -- cgit v0.12 From ceda5f91cc98f11b93b81de0ad16f487af3aaef7 Mon Sep 17 00:00:00 2001 From: oehhar Date: Mon, 14 Mar 2022 18:24:01 +0000 Subject: Add "const" to some other parameters to avoid compiler failure on MS-VC 2015. Hope this is ok. --- generic/tclIntDecls.h | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/generic/tclIntDecls.h b/generic/tclIntDecls.h index 8430fae..0fa7b82 100644 --- a/generic/tclIntDecls.h +++ b/generic/tclIntDecls.h @@ -551,17 +551,17 @@ EXTERN int TclRegisterLiteral(void *envPtr, const char *bytes, /* 252 */ EXTERN Tcl_Obj * TclPtrGetVar(Tcl_Interp *interp, Tcl_Var varPtr, Tcl_Var arrayPtr, Tcl_Obj *part1Ptr, - Tcl_Obj *part2Ptr, int flags); + Tcl_Obj *part2Ptr, const int flags); /* 253 */ EXTERN Tcl_Obj * TclPtrSetVar(Tcl_Interp *interp, Tcl_Var varPtr, Tcl_Var arrayPtr, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, Tcl_Obj *newValuePtr, - int flags); + const int flags); /* 254 */ EXTERN Tcl_Obj * TclPtrIncrObjVar(Tcl_Interp *interp, Tcl_Var varPtr, Tcl_Var arrayPtr, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, Tcl_Obj *incrPtr, - int flags); + const int flags); /* 255 */ EXTERN int TclPtrObjMakeUpvar(Tcl_Interp *interp, Tcl_Var otherPtr, Tcl_Obj *myNamePtr, @@ -569,7 +569,7 @@ EXTERN int TclPtrObjMakeUpvar(Tcl_Interp *interp, /* 256 */ EXTERN int TclPtrUnsetVar(Tcl_Interp *interp, Tcl_Var varPtr, Tcl_Var arrayPtr, Tcl_Obj *part1Ptr, - Tcl_Obj *part2Ptr, int flags); + Tcl_Obj *part2Ptr, const int flags); /* 257 */ EXTERN void TclStaticLibrary(Tcl_Interp *interp, const char *prefix, -- cgit v0.12 From 9e3724ae417191dfc027b285d015f7ca332c9204 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 14 Mar 2022 20:59:44 +0000 Subject: Eliminate useless "const int" usage, where "const" has no meaning. VC-2015 has problem when the signatures don't match --- generic/rege_dfa.c | 2 +- generic/regexec.c | 2 +- generic/tclInt.decls | 10 +++++----- generic/tclInt.h | 16 ++++++++-------- generic/tclIntDecls.h | 23 +++++++++++------------ generic/tclOOCall.c | 4 ++-- generic/tclVar.c | 40 ++++++++++++++++++++-------------------- 7 files changed, 48 insertions(+), 49 deletions(-) diff --git a/generic/rege_dfa.c b/generic/rege_dfa.c index f38c8c9..eddfea2 100644 --- a/generic/rege_dfa.c +++ b/generic/rege_dfa.c @@ -419,7 +419,7 @@ freeDFA( static unsigned hash( unsigned *const uv, - const int n) + int n) { int i; unsigned h; diff --git a/generic/regexec.c b/generic/regexec.c index c085ac6..510fb1d 100644 --- a/generic/regexec.c +++ b/generic/regexec.c @@ -145,7 +145,7 @@ static chr *shortest(struct vars *const, struct dfa *const, chr *const, chr *con static chr *lastCold(struct vars *const, struct dfa *const); static struct dfa *newDFA(struct vars *const, struct cnfa *const, struct colormap *const, struct smalldfa *); static void freeDFA(struct dfa *const); -static unsigned hash(unsigned *const, const int); +static unsigned hash(unsigned *const, int); static struct sset *initialize(struct vars *const, struct dfa *const, chr *const); static struct sset *miss(struct vars *const, struct dfa *const, struct sset *const, const pcolor, chr *const, chr *const); static int checkLAConstraint(struct vars *const, struct cnfa *const, chr *const, const pcolor); diff --git a/generic/tclInt.decls b/generic/tclInt.decls index 0b3ea9e..8cefc34 100644 --- a/generic/tclInt.decls +++ b/generic/tclInt.decls @@ -904,7 +904,7 @@ declare 229 { declare 230 { Var *TclObjLookupVar(Tcl_Interp *interp, Tcl_Obj *part1Ptr, const char *part2, int flags, const char *msg, - const int createPart1, const int createPart2, Var **arrayPtrPtr) + int createPart1, int createPart2, Var **arrayPtrPtr) } declare 231 { int TclGetNamespaceFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr, @@ -1005,17 +1005,17 @@ declare 251 { declare 252 { Tcl_Obj *TclPtrGetVar(Tcl_Interp *interp, Tcl_Var varPtr, Tcl_Var arrayPtr, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, - const int flags) + int flags) } declare 253 { Tcl_Obj *TclPtrSetVar(Tcl_Interp *interp, Tcl_Var varPtr, Tcl_Var arrayPtr, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, - Tcl_Obj *newValuePtr, const int flags) + Tcl_Obj *newValuePtr, int flags) } declare 254 { Tcl_Obj *TclPtrIncrObjVar(Tcl_Interp *interp, Tcl_Var varPtr, Tcl_Var arrayPtr, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, - Tcl_Obj *incrPtr, const int flags) + Tcl_Obj *incrPtr, int flags) } declare 255 { int TclPtrObjMakeUpvar(Tcl_Interp *interp, Tcl_Var otherPtr, @@ -1023,7 +1023,7 @@ declare 255 { } declare 256 { int TclPtrUnsetVar(Tcl_Interp *interp, Tcl_Var varPtr, Tcl_Var arrayPtr, - Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, const int flags) + Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, int flags) } declare 257 { void TclStaticLibrary(Tcl_Interp *interp, const char *prefix, diff --git a/generic/tclInt.h b/generic/tclInt.h index 2873ad3..3f2d1ad 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -4126,30 +4126,30 @@ MODULE_SCOPE Tcl_Obj * TclStringReverse(Tcl_Obj *objPtr, int flags); MODULE_SCOPE Var * TclObjLookupVarEx(Tcl_Interp * interp, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, int flags, - const char *msg, const int createPart1, - const int createPart2, Var **arrayPtrPtr); + const char *msg, int createPart1, + int createPart2, Var **arrayPtrPtr); MODULE_SCOPE Var * TclLookupArrayElement(Tcl_Interp *interp, Tcl_Obj *arrayNamePtr, Tcl_Obj *elNamePtr, - const int flags, const char *msg, - const int createPart1, const int createPart2, + int flags, const char *msg, + int createPart1, int createPart2, Var *arrayPtr, int index); MODULE_SCOPE Tcl_Obj * TclPtrGetVarIdx(Tcl_Interp *interp, Var *varPtr, Var *arrayPtr, Tcl_Obj *part1Ptr, - Tcl_Obj *part2Ptr, const int flags, int index); + Tcl_Obj *part2Ptr, int flags, int index); MODULE_SCOPE Tcl_Obj * TclPtrSetVarIdx(Tcl_Interp *interp, Var *varPtr, Var *arrayPtr, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, Tcl_Obj *newValuePtr, - const int flags, int index); + int flags, int index); MODULE_SCOPE Tcl_Obj * TclPtrIncrObjVarIdx(Tcl_Interp *interp, Var *varPtr, Var *arrayPtr, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, Tcl_Obj *incrPtr, - const int flags, int index); + int flags, int index); MODULE_SCOPE int TclPtrObjMakeUpvarIdx(Tcl_Interp *interp, Var *otherPtr, Tcl_Obj *myNamePtr, int myFlags, int index); MODULE_SCOPE int TclPtrUnsetVarIdx(Tcl_Interp *interp, Var *varPtr, Var *arrayPtr, Tcl_Obj *part1Ptr, - Tcl_Obj *part2Ptr, const int flags, + Tcl_Obj *part2Ptr, int flags, int index); MODULE_SCOPE void TclInvalidateNsPath(Namespace *nsPtr); MODULE_SCOPE void TclFindArrayPtrElements(Var *arrayPtr, diff --git a/generic/tclIntDecls.h b/generic/tclIntDecls.h index 75f4a68..f4e657b 100644 --- a/generic/tclIntDecls.h +++ b/generic/tclIntDecls.h @@ -562,9 +562,8 @@ EXTERN int TclPtrMakeUpvar(Tcl_Interp *interp, Var *otherP1Ptr, /* 230 */ EXTERN Var * TclObjLookupVar(Tcl_Interp *interp, Tcl_Obj *part1Ptr, const char *part2, - int flags, const char *msg, - const int createPart1, const int createPart2, - Var **arrayPtrPtr); + int flags, const char *msg, int createPart1, + int createPart2, Var **arrayPtrPtr); /* 231 */ EXTERN int TclGetNamespaceFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr, Tcl_Namespace **nsPtrPtr); @@ -631,17 +630,17 @@ EXTERN int TclRegisterLiteral(void *envPtr, const char *bytes, /* 252 */ EXTERN Tcl_Obj * TclPtrGetVar(Tcl_Interp *interp, Tcl_Var varPtr, Tcl_Var arrayPtr, Tcl_Obj *part1Ptr, - Tcl_Obj *part2Ptr, const int flags); + Tcl_Obj *part2Ptr, int flags); /* 253 */ EXTERN Tcl_Obj * TclPtrSetVar(Tcl_Interp *interp, Tcl_Var varPtr, Tcl_Var arrayPtr, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, Tcl_Obj *newValuePtr, - const int flags); + int flags); /* 254 */ EXTERN Tcl_Obj * TclPtrIncrObjVar(Tcl_Interp *interp, Tcl_Var varPtr, Tcl_Var arrayPtr, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, Tcl_Obj *incrPtr, - const int flags); + int flags); /* 255 */ EXTERN int TclPtrObjMakeUpvar(Tcl_Interp *interp, Tcl_Var otherPtr, Tcl_Obj *myNamePtr, @@ -649,7 +648,7 @@ EXTERN int TclPtrObjMakeUpvar(Tcl_Interp *interp, /* 256 */ EXTERN int TclPtrUnsetVar(Tcl_Interp *interp, Tcl_Var varPtr, Tcl_Var arrayPtr, Tcl_Obj *part1Ptr, - Tcl_Obj *part2Ptr, const int flags); + Tcl_Obj *part2Ptr, int flags); /* 257 */ EXTERN void TclStaticLibrary(Tcl_Interp *interp, const char *prefix, @@ -895,7 +894,7 @@ typedef struct TclIntStubs { void (*tclSetNsPath) (Namespace *nsPtr, int pathLength, Tcl_Namespace *pathAry[]); /* 227 */ void (*reserved228)(void); int (*tclPtrMakeUpvar) (Tcl_Interp *interp, Var *otherP1Ptr, const char *myName, int myFlags, int index); /* 229 */ - Var * (*tclObjLookupVar) (Tcl_Interp *interp, Tcl_Obj *part1Ptr, const char *part2, int flags, const char *msg, const int createPart1, const int createPart2, Var **arrayPtrPtr); /* 230 */ + Var * (*tclObjLookupVar) (Tcl_Interp *interp, Tcl_Obj *part1Ptr, const char *part2, int flags, const char *msg, int createPart1, int createPart2, Var **arrayPtrPtr); /* 230 */ int (*tclGetNamespaceFromObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, Tcl_Namespace **nsPtrPtr); /* 231 */ int (*tclEvalObjEx) (Tcl_Interp *interp, Tcl_Obj *objPtr, int flags, const CmdFrame *invoker, int word); /* 232 */ void (*tclGetSrcInfoForPc) (CmdFrame *contextPtr); /* 233 */ @@ -917,11 +916,11 @@ typedef struct TclIntStubs { char * (*tclDoubleDigits) (double dv, int ndigits, int flags, int *decpt, int *signum, char **endPtr); /* 249 */ void (*tclSetChildCancelFlags) (Tcl_Interp *interp, int flags, int force); /* 250 */ int (*tclRegisterLiteral) (void *envPtr, const char *bytes, int length, int flags); /* 251 */ - Tcl_Obj * (*tclPtrGetVar) (Tcl_Interp *interp, Tcl_Var varPtr, Tcl_Var arrayPtr, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, const int flags); /* 252 */ - Tcl_Obj * (*tclPtrSetVar) (Tcl_Interp *interp, Tcl_Var varPtr, Tcl_Var arrayPtr, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, Tcl_Obj *newValuePtr, const int flags); /* 253 */ - Tcl_Obj * (*tclPtrIncrObjVar) (Tcl_Interp *interp, Tcl_Var varPtr, Tcl_Var arrayPtr, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, Tcl_Obj *incrPtr, const int flags); /* 254 */ + Tcl_Obj * (*tclPtrGetVar) (Tcl_Interp *interp, Tcl_Var varPtr, Tcl_Var arrayPtr, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, int flags); /* 252 */ + Tcl_Obj * (*tclPtrSetVar) (Tcl_Interp *interp, Tcl_Var varPtr, Tcl_Var arrayPtr, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, Tcl_Obj *newValuePtr, int flags); /* 253 */ + Tcl_Obj * (*tclPtrIncrObjVar) (Tcl_Interp *interp, Tcl_Var varPtr, Tcl_Var arrayPtr, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, Tcl_Obj *incrPtr, int flags); /* 254 */ int (*tclPtrObjMakeUpvar) (Tcl_Interp *interp, Tcl_Var otherPtr, Tcl_Obj *myNamePtr, int myFlags); /* 255 */ - int (*tclPtrUnsetVar) (Tcl_Interp *interp, Tcl_Var varPtr, Tcl_Var arrayPtr, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, const int flags); /* 256 */ + int (*tclPtrUnsetVar) (Tcl_Interp *interp, Tcl_Var varPtr, Tcl_Var arrayPtr, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, int flags); /* 256 */ void (*tclStaticLibrary) (Tcl_Interp *interp, const char *prefix, Tcl_LibraryInitProc *initProc, Tcl_LibraryInitProc *safeInitProc); /* 257 */ Tcl_Obj * (*tclpCreateTemporaryDirectory) (Tcl_Obj *dirObj, Tcl_Obj *basenameObj); /* 258 */ void (*tclUnusedStubEntry) (void); /* 259 */ diff --git a/generic/tclOOCall.c b/generic/tclOOCall.c index 71db6c1..d265c1a 100644 --- a/generic/tclOOCall.c +++ b/generic/tclOOCall.c @@ -91,7 +91,7 @@ typedef struct { static void AddClassFiltersToCallContext(Object *const oPtr, Class *clsPtr, struct ChainBuilder *const cbPtr, Tcl_HashTable *const doneFilters, int flags); -static void AddClassMethodNames(Class *clsPtr, const int flags, +static void AddClassMethodNames(Class *clsPtr, int flags, Tcl_HashTable *const namesPtr, Tcl_HashTable *const examinedClassesPtr); static inline void AddDefinitionNamespaceToChain(Class *const definerCls, @@ -671,7 +671,7 @@ CmpStr( static void AddClassMethodNames( Class *clsPtr, /* Class to get method names from. */ - const int flags, /* Whether we are interested in just the + int flags, /* Whether we are interested in just the * public method names. */ Tcl_HashTable *const namesPtr, /* Reference to the hash table to put the diff --git a/generic/tclVar.c b/generic/tclVar.c index 5a59fde..6d948dd 100644 --- a/generic/tclVar.c +++ b/generic/tclVar.c @@ -200,7 +200,7 @@ static Tcl_Var ObjFindNamespaceVar(Tcl_Interp *interp, int flags); static int ObjMakeUpvar(Tcl_Interp *interp, CallFrame *framePtr, Tcl_Obj *otherP1Ptr, - const char *otherP2, const int otherFlags, + const char *otherP2, int otherFlags, Tcl_Obj *myNamePtr, int myFlags, int index); static ArraySearch * ParseSearchId(Tcl_Interp *interp, const Var *varPtr, Tcl_Obj *varNamePtr, Tcl_Obj *handleObj); @@ -224,7 +224,7 @@ static void SetArrayDefault(Var *arrayPtr, Tcl_Obj *defaultObj); */ MODULE_SCOPE Var * TclLookupSimpleVar(Tcl_Interp *interp, - Tcl_Obj *varNamePtr, int flags, const int create, + Tcl_Obj *varNamePtr, int flags, int create, const char **errMsgPtr, int *indexPtr); static Tcl_DupInternalRepProc DupLocalVarName; @@ -541,10 +541,10 @@ TclObjLookupVar( const char *msg, /* Verb to use in error messages, e.g. "read" * or "set". Only needed if TCL_LEAVE_ERR_MSG * is set in flags. */ - const int createPart1, /* If 1, create hash table entry for part 1 of + int createPart1, /* If 1, create hash table entry for part 1 of * name, if it doesn't already exist. If 0, * return error if it doesn't exist. */ - const int createPart2, /* If 1, create hash table entry for part 2 of + int createPart2, /* If 1, create hash table entry for part 2 of * name, if it doesn't already exist. If 0, * return error if it doesn't exist. */ Var **arrayPtrPtr) /* If the name refers to an element of an @@ -591,10 +591,10 @@ TclObjLookupVarEx( const char *msg, /* Verb to use in error messages, e.g. "read" * or "set". Only needed if TCL_LEAVE_ERR_MSG * is set in flags. */ - const int createPart1, /* If 1, create hash table entry for part 1 of + int createPart1, /* If 1, create hash table entry for part 1 of * name, if it doesn't already exist. If 0, * return error if it doesn't exist. */ - const int createPart2, /* If 1, create hash table entry for part 2 of + int createPart2, /* If 1, create hash table entry for part 2 of * name, if it doesn't already exist. If 0, * return error if it doesn't exist. */ Var **arrayPtrPtr) /* If the name refers to an element of an @@ -827,7 +827,7 @@ TclLookupSimpleVar( int flags, /* Only TCL_GLOBAL_ONLY, TCL_NAMESPACE_ONLY, * TCL_AVOID_RESOLVERS and TCL_LEAVE_ERR_MSG * bits matter. */ - const int create, /* If 1, create hash table entry for varname, + int create, /* If 1, create hash table entry for varname, * if it doesn't already exist. If 0, return * error if it doesn't exist. */ const char **errMsgPtr, @@ -1062,15 +1062,15 @@ TclLookupArrayElement( Tcl_Obj *arrayNamePtr, /* This is the name of the array, or NULL if * index>= 0. */ Tcl_Obj *elNamePtr, /* Name of element within array. */ - const int flags, /* Only TCL_LEAVE_ERR_MSG bit matters. */ + int flags, /* Only TCL_LEAVE_ERR_MSG bit matters. */ const char *msg, /* Verb to use in error messages, e.g. "read" * or "set". Only needed if TCL_LEAVE_ERR_MSG * is set in flags. */ - const int createArray, /* If 1, transform arrayName to be an array if + int createArray, /* If 1, transform arrayName to be an array if * it isn't one yet and the transformation is * possible. If 0, return error if it isn't * already an array. */ - const int createElem, /* If 1, create hash table entry for the + int createElem, /* If 1, create hash table entry for the * element, if it doesn't already exist. If 0, * return error if it doesn't exist. */ Var *arrayPtr, /* Pointer to the array's Var structure. */ @@ -1383,7 +1383,7 @@ TclPtrGetVar( * the name of a variable. */ Tcl_Obj *part2Ptr, /* If non-NULL, gives the name of an element * in the array part1. */ - const int flags) /* OR-ed combination of TCL_GLOBAL_ONLY, and + int flags) /* OR-ed combination of TCL_GLOBAL_ONLY, and * TCL_LEAVE_ERR_MSG bits. */ { if (varPtr == NULL) { @@ -1429,7 +1429,7 @@ TclPtrGetVarIdx( * the name of a variable. */ Tcl_Obj *part2Ptr, /* If non-NULL, gives the name of an element * in the array part1. */ - const int flags, /* OR-ed combination of TCL_GLOBAL_ONLY, and + int flags, /* OR-ed combination of TCL_GLOBAL_ONLY, and * TCL_LEAVE_ERR_MSG bits. */ int index) /* Index into the local variable table of the * variable, or -1. Only used when part1Ptr is @@ -1822,7 +1822,7 @@ TclPtrSetVar( Tcl_Obj *part2Ptr, /* If non-NULL, gives the name of an element * in the array part1. */ Tcl_Obj *newValuePtr, /* New value for variable. */ - const int flags) /* OR-ed combination of TCL_GLOBAL_ONLY, and + int flags) /* OR-ed combination of TCL_GLOBAL_ONLY, and * TCL_LEAVE_ERR_MSG bits. */ { if (varPtr == NULL) { @@ -2001,7 +2001,7 @@ TclPtrSetVarIdx( Tcl_Obj *part2Ptr, /* If non-NULL, gives the name of an element * in the array part1. */ Tcl_Obj *newValuePtr, /* New value for variable. */ - const int flags, /* OR-ed combination of TCL_GLOBAL_ONLY, and + int flags, /* OR-ed combination of TCL_GLOBAL_ONLY, and * TCL_LEAVE_ERR_MSG bits. */ int index) /* Index of local var where part1 is to be * found. */ @@ -2247,7 +2247,7 @@ TclPtrIncrObjVar( * part1Ptr. */ Tcl_Obj *incrPtr, /* Increment value. */ /* TODO: Which of these flag values really make sense? */ - const int flags) /* Various flags that tell how to incr value: + int flags) /* Various flags that tell how to incr value: * any of TCL_GLOBAL_ONLY, TCL_NAMESPACE_ONLY, * TCL_APPEND_VALUE, TCL_LIST_ELEMENT, * TCL_LEAVE_ERR_MSG. */ @@ -2303,7 +2303,7 @@ TclPtrIncrObjVarIdx( * part1Ptr. */ Tcl_Obj *incrPtr, /* Increment value. */ /* TODO: Which of these flag values really make sense? */ - const int flags, /* Various flags that tell how to incr value: + int flags, /* Various flags that tell how to incr value: * any of TCL_GLOBAL_ONLY, TCL_NAMESPACE_ONLY, * TCL_APPEND_VALUE, TCL_LIST_ELEMENT, * TCL_LEAVE_ERR_MSG. */ @@ -2532,7 +2532,7 @@ TclPtrUnsetVar( * the name of a variable. */ Tcl_Obj *part2Ptr, /* If non-NULL, gives the name of an element * in the array part1. */ - const int flags) /* OR-ed combination of any of + int flags) /* OR-ed combination of any of * TCL_GLOBAL_ONLY, TCL_NAMESPACE_ONLY, * TCL_LEAVE_ERR_MSG. */ { @@ -2579,7 +2579,7 @@ TclPtrUnsetVarIdx( * the name of a variable. */ Tcl_Obj *part2Ptr, /* If non-NULL, gives the name of an element * in the array part1. */ - const int flags, /* OR-ed combination of any of + int flags, /* OR-ed combination of any of * TCL_GLOBAL_ONLY, TCL_NAMESPACE_ONLY, * TCL_LEAVE_ERR_MSG. */ int index) /* Index into the local variable table of the @@ -4373,7 +4373,7 @@ ArrayUnsetCmd( Tcl_Obj *varNameObj, *patternObj, *nameObj; Tcl_HashSearch search; const char *pattern; - const int unsetFlags = 0; /* Should this be TCL_LEAVE_ERR_MSG? */ + int unsetFlags = 0; /* Should this be TCL_LEAVE_ERR_MSG? */ int isArray; switch (objc) { @@ -4552,7 +4552,7 @@ ObjMakeUpvar( * NULL means use global :: context. */ Tcl_Obj *otherP1Ptr, const char *otherP2, /* Two-part name of variable in framePtr. */ - const int otherFlags, /* 0, TCL_GLOBAL_ONLY or TCL_NAMESPACE_ONLY: + int otherFlags, /* 0, TCL_GLOBAL_ONLY or TCL_NAMESPACE_ONLY: * indicates scope of "other" variable. */ Tcl_Obj *myNamePtr, /* Name of variable which will refer to * otherP1/otherP2. Must be a scalar. */ -- cgit v0.12 From 1975c98a5c09989a767f8288beec0e67abf408a3 Mon Sep 17 00:00:00 2001 From: oehhar Date: Tue, 15 Mar 2022 07:09:40 +0000 Subject: TIP607 encoding failindex: test correction --- tests/encoding.test | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/tests/encoding.test b/tests/encoding.test index 7a1e4e7..4284254 100644 --- a/tests/encoding.test +++ b/tests/encoding.test @@ -696,9 +696,10 @@ test encoding-24.30 {convertrom -failindex with correct data} -body { set test } -returnCodes 0 -result -1 test encoding-24.31 {convertrom -failindex with incomplete utf8} -body { - set res [encoding convertfrom -failindex test A\xc3] - lappend res $test -} -returnCodes 0 -result {A 1} + set x [encoding convertfrom -failindex i A\xc3] + binary scan $x H* y + list $y $i +} -returnCodes 0 -result {41 1} file delete [file join [temporaryDirectory] iso2022.txt] -- cgit v0.12 From e7f2a43ec4ace15bc0e3baf0cf965132eee20632 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 15 Mar 2022 07:52:56 +0000 Subject: Even though Tcl_UniChar == int (in this "#if TCL_UTF_MAX>3 block), use the correct signature for Tcl_GetUnicode/Tcl_GetUnicodeFromObj/Tcl_NewUnicodeObj here --- generic/tclStubInit.c | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c index 1aec652..221ff67 100644 --- a/generic/tclStubInit.c +++ b/generic/tclStubInit.c @@ -86,9 +86,9 @@ static void uniCodePanic(void) { 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 *))(void *)uniCodePanic -# define Tcl_GetUnicodeFromObj (int *(*)(Tcl_Obj *, Tcl_UniChar *))(void *)uniCodePanic -# define Tcl_NewUnicodeObj (Tcl_Obj *(*)(const int *, Tcl_UniChar))(void *)uniCodePanic +# define Tcl_GetUnicode (Tcl_UniChar *(*)(Tcl_Obj *))(void *)uniCodePanic +# define Tcl_GetUnicodeFromObj (Tcl_UniChar *(*)(Tcl_Obj *, int *))(void *)uniCodePanic +# define Tcl_NewUnicodeObj (Tcl_Obj *(*)(const int *, int))(void *)uniCodePanic # define Tcl_SetUnicodeObj (void(*)(Tcl_Obj *, const Tcl_UniChar *, int))(void *)uniCodePanic # define Tcl_AppendUnicodeToObj (void(*)(Tcl_Obj *, const Tcl_UniChar *, int))(void *)uniCodePanic # define Tcl_UniCharNcasecmp (int(*)(const Tcl_UniChar *, const Tcl_UniChar *, unsigned long))(void *)uniCodePanic -- cgit v0.12 From 60b2db50fcc19a83a5c737e5cadfcbd8f7f3810b Mon Sep 17 00:00:00 2001 From: oehhar Date: Tue, 15 Mar 2022 10:15:30 +0000 Subject: win/makefile.vc: required correction for noembed,symbols to allow debugging with MS-VS2015. Otherwise, symbols are not detected within DLL. --- win/makefile.vc | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/win/makefile.vc b/win/makefile.vc index 2687e1c..d15f844 100644 --- a/win/makefile.vc +++ b/win/makefile.vc @@ -584,6 +584,7 @@ $(OUT_DIR)\tommath.lib: $(TOMMATHDIR)\win64\tommath.lib $(COPY) $(TOMMATHDIR)\win64\tommath.lib $(OUT_DIR)\tommath.lib !endif +!if $(TCL_EMBED_SCRIPTS) $(TCLSCRIPTZIP): $(TCLDDELIB) $(TCLREGLIB) @echo Building Tcl library zip file @if exist "$(LIBTCLVFS)" $(RMDIR) "$(LIBTCLVFS)" @@ -603,7 +604,7 @@ $(TCLSCRIPTZIP): $(TCLDDELIB) $(TCLREGLIB) @echo file delete -force {$@} > "$(OUT_DIR)\zipper.tcl" @echo zipfs mkzip {$@} {$(LIBTCLVFS)} {$(LIBTCLVFS)} >> "$(OUT_DIR)\zipper.tcl" @cd "$(OUT_DIR)" && $(TCLSH_NATIVE) zipper.tcl - +!endif pkgs: @for /d %d in ($(PKGSDIR)\*) do \ -- cgit v0.12 From ea69616a5dd24c1d6c78e20ee260956e766342ea Mon Sep 17 00:00:00 2001 From: oehhar Date: Tue, 15 Mar 2022 10:28:48 +0000 Subject: TIP607 encoding failindex: correct test which works now. --- tests/encoding.test | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/tests/encoding.test b/tests/encoding.test index 4284254..f4343c4 100644 --- a/tests/encoding.test +++ b/tests/encoding.test @@ -696,7 +696,7 @@ test encoding-24.30 {convertrom -failindex with correct data} -body { set test } -returnCodes 0 -result -1 test encoding-24.31 {convertrom -failindex with incomplete utf8} -body { - set x [encoding convertfrom -failindex i A\xc3] + set x [encoding convertfrom -failindex i utf-8 A\xc3] binary scan $x H* y list $y $i } -returnCodes 0 -result {41 1} -- cgit v0.12 From fb7684bbbf09e0c6e6328056be102e5069ab600f Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 15 Mar 2022 16:00:23 +0000 Subject: Make framePtr->level size_t --- generic/tcl.h | 2 +- generic/tclCmdIL.c | 4 ++-- generic/tclExecute.c | 4 ++-- generic/tclInt.h | 2 +- generic/tclNamesp.c | 4 ++-- generic/tclProc.c | 2 +- 6 files changed, 9 insertions(+), 9 deletions(-) diff --git a/generic/tcl.h b/generic/tcl.h index e522a78..a4dec97 100644 --- a/generic/tcl.h +++ b/generic/tcl.h @@ -722,7 +722,7 @@ typedef struct Tcl_CallFrame { void *dummy3; void *dummy4; void *dummy5; - int dummy6; + size_t dummy6; void *dummy7; void *dummy8; size_t dummy9; diff --git a/generic/tclCmdIL.c b/generic/tclCmdIL.c index 07e42ef..004cdb2 100644 --- a/generic/tclCmdIL.c +++ b/generic/tclCmdIL.c @@ -1564,7 +1564,7 @@ InfoLevelCmd( Interp *iPtr = (Interp *) interp; if (objc == 1) { /* Just "info level" */ - Tcl_SetObjResult(interp, Tcl_NewWideIntObj(iPtr->varFramePtr->level)); + Tcl_SetObjResult(interp, Tcl_NewWideIntObj((int)iPtr->varFramePtr->level)); return TCL_OK; } @@ -1583,7 +1583,7 @@ InfoLevelCmd( } for (framePtr=iPtr->varFramePtr ; framePtr!=rootFramePtr; framePtr=framePtr->callerVarPtr) { - if (framePtr->level == level) { + if ((int)framePtr->level == level) { break; } } diff --git a/generic/tclExecute.c b/generic/tclExecute.c index adbfd2d..0483bec 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -4265,7 +4265,7 @@ TEBCresume( } break; case INST_INFO_LEVEL_NUM: - TclNewIntObj(objResultPtr, iPtr->varFramePtr->level); + TclNewIntObj(objResultPtr, (int)iPtr->varFramePtr->level); TRACE_WITH_OBJ(("=> "), objResultPtr); NEXT_INST_F(1, 0, 1); break; @@ -4282,7 +4282,7 @@ TEBCresume( if (level <= 0) { level += framePtr->level; } - for (; (framePtr->level!=level) && (framePtr!=rootFramePtr) ; + for (; ((int)framePtr->level!=level) && (framePtr!=rootFramePtr) ; framePtr = framePtr->callerVarPtr) { /* Empty loop body */ } diff --git a/generic/tclInt.h b/generic/tclInt.h index baf3d81..54d9ef9 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -1124,7 +1124,7 @@ typedef struct CallFrame { * callerPtr unless an "uplevel" command or * something equivalent was active in the * caller). */ - int level; /* Level of this procedure, for "uplevel" + size_t level; /* Level of this procedure, for "uplevel" * purposes (i.e. corresponds to nesting of * callerVarPtr's, not callerPtr's). 1 for * outermost procedure, 0 for top-level. */ diff --git a/generic/tclNamesp.c b/generic/tclNamesp.c index e1e298f..7bd5907 100644 --- a/generic/tclNamesp.c +++ b/generic/tclNamesp.c @@ -326,7 +326,7 @@ Tcl_PushCallFrame( framePtr->callerPtr = iPtr->framePtr; framePtr->callerVarPtr = iPtr->varFramePtr; if (iPtr->varFramePtr != NULL) { - framePtr->level = (iPtr->varFramePtr->level + 1); + framePtr->level = iPtr->varFramePtr->level + 1U; } else { framePtr->level = 0; } @@ -5048,7 +5048,7 @@ TclLogCommandInfo( Tcl_ListObjAppendElement(NULL, iPtr->errorStack, iPtr->upLiteral); Tcl_ListObjAppendElement(NULL, iPtr->errorStack, Tcl_NewWideIntObj( - iPtr->framePtr->level - iPtr->varFramePtr->level)); + (int)(iPtr->framePtr->level - iPtr->varFramePtr->level))); } else if (iPtr->framePtr != iPtr->rootFramePtr) { /* * normal case, [lappend errorstack CALL [info level 0]] diff --git a/generic/tclProc.c b/generic/tclProc.c index 75f4eb2..37821d2 100644 --- a/generic/tclProc.c +++ b/generic/tclProc.c @@ -829,7 +829,7 @@ TclObjGetFrame( CallFrame *framePtr; for (framePtr = iPtr->varFramePtr; framePtr != NULL; framePtr = framePtr->callerVarPtr) { - if (framePtr->level == level) { + if ((int)framePtr->level == level) { *framePtrPtr = framePtr; return result; } -- cgit v0.12 From 0c2352075bef2a01b49df765bb2c2b00a3d865d3 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 15 Mar 2022 16:15:29 +0000 Subject: Now - really - allow TCL_UTF_MAX=3 compiling with nmake build --- win/rules.vc | 9 ++++----- 1 file changed, 4 insertions(+), 5 deletions(-) diff --git a/win/rules.vc b/win/rules.vc index 713e7f9..6d9bbf8 100644 --- a/win/rules.vc +++ b/win/rules.vc @@ -816,8 +816,7 @@ DOTSEPARATED=$(DOTSEPARATED:b=.) # configuration (ignored for Tcl itself) # _USE_64BIT_TIME_T - forces a build using 64-bit time_t for 32-bit build # (CRT library should support this, not needed for Tcl 9.x) -# TCL_UTF_MAX=4 - forces a build allowing 4-byte UTF-8 sequences internally. -# (Not needed for Tcl 9.x) +# TCL_UTF_MAX=3 - forces a build using UTF-16 internally (not recommended). # Further, LINKERFLAGS are modified based on above. # Default values for all the above @@ -1423,13 +1422,13 @@ OPTDEFINES = $(OPTDEFINES) /DNO_STRTOI64=1 !if "$(_USE_64BIT_TIME_T)" == "1" OPTDEFINES = $(OPTDEFINES) /D_USE_64BIT_TIME_T=1 !endif -!if "$(TCL_UTF_MAX)" == "4" -OPTDEFINES = $(OPTDEFINES) /DTCL_UTF_MAX=4 -!endif # _ATL_XP_TARGETING - Newer SDK's need this to build for XP COMPILERFLAGS = /D_ATL_XP_TARGETING !endif +!if "$(TCL_UTF_MAX)" == "3" +OPTDEFINES = $(OPTDEFINES) /DTCL_UTF_MAX=3 +!endif # Like the TEA system only set this non empty for non-Tk extensions # Note: some extensions use PACKAGE_NAME and others use PACKAGE_TCLNAME -- cgit v0.12 From 4dd5be298811da7ad60f1cd93d3ff09e4baf34d0 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 15 Mar 2022 16:17:42 +0000 Subject: update rules.vc --- win/rules.vc | 9 ++++----- 1 file changed, 4 insertions(+), 5 deletions(-) diff --git a/win/rules.vc b/win/rules.vc index 713e7f9..6d9bbf8 100644 --- a/win/rules.vc +++ b/win/rules.vc @@ -816,8 +816,7 @@ DOTSEPARATED=$(DOTSEPARATED:b=.) # configuration (ignored for Tcl itself) # _USE_64BIT_TIME_T - forces a build using 64-bit time_t for 32-bit build # (CRT library should support this, not needed for Tcl 9.x) -# TCL_UTF_MAX=4 - forces a build allowing 4-byte UTF-8 sequences internally. -# (Not needed for Tcl 9.x) +# TCL_UTF_MAX=3 - forces a build using UTF-16 internally (not recommended). # Further, LINKERFLAGS are modified based on above. # Default values for all the above @@ -1423,13 +1422,13 @@ OPTDEFINES = $(OPTDEFINES) /DNO_STRTOI64=1 !if "$(_USE_64BIT_TIME_T)" == "1" OPTDEFINES = $(OPTDEFINES) /D_USE_64BIT_TIME_T=1 !endif -!if "$(TCL_UTF_MAX)" == "4" -OPTDEFINES = $(OPTDEFINES) /DTCL_UTF_MAX=4 -!endif # _ATL_XP_TARGETING - Newer SDK's need this to build for XP COMPILERFLAGS = /D_ATL_XP_TARGETING !endif +!if "$(TCL_UTF_MAX)" == "3" +OPTDEFINES = $(OPTDEFINES) /DTCL_UTF_MAX=3 +!endif # Like the TEA system only set this non empty for non-Tk extensions # Note: some extensions use PACKAGE_NAME and others use PACKAGE_TCLNAME -- cgit v0.12 From 7be46e0132c6c882964c0b6ba05d9bb4ca1aa636 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 15 Mar 2022 17:12:31 +0000 Subject: Fix [639208cc7b]: main makefile.vc OPTS=static compile error in libtommath\bn_mp_set_i64.c: An unary minus operator was assigned to a signless type. The result is still signless. --- win/rules.vc | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/win/rules.vc b/win/rules.vc index 372d70a..a571899 100644 --- a/win/rules.vc +++ b/win/rules.vc @@ -1471,8 +1471,8 @@ cdebug = $(cdebug) -Zi !endif # $(DEBUG) -# cwarn includes default warning levels. -cwarn = $(WARNINGS) +# cwarn includes default warning levels, also C4146 is useless. +cwarn = $(WARNINGS) -wd4146 !if "$(MACHINE)" == "AMD64" || "$(MACHINE)" == "ARM64" # Disable pointer<->int warnings related to cast between different sizes -- cgit v0.12 From 48a30dd04e32f374258f8f6eacc40c48a1227ee7 Mon Sep 17 00:00:00 2001 From: oehhar Date: Wed, 16 Mar 2022 18:20:29 +0000 Subject: TIP607 encoding failindex: revert ckeckin [add9ed8887] : just wait for symbol load in VS2015 and it will work. Sorry, Ashok ! --- win/makefile.vc | 5 ++--- 1 file changed, 2 insertions(+), 3 deletions(-) diff --git a/win/makefile.vc b/win/makefile.vc index d15f844..abbf840 100644 --- a/win/makefile.vc +++ b/win/makefile.vc @@ -52,7 +52,7 @@ # turn on the 64-bit compiler, if your SDK has it. # # Basic macros and options usable on the commandline (see rules.vc for more info): -# OPTS=nomsvcrt,noembed,nothreads,pdbs,profile,static,symbols,thrdalloc,unchecked,none +# OPTS=nomsvcrt,noembed,nothreads,pdbs,profile,static,symbols,thrdalloc,unchecked,utf16,none # Sets special options for the core. The default is for none. # Any combination of the above may be used (comma separated). # 'none' will over-ride everything to nothing. @@ -584,7 +584,6 @@ $(OUT_DIR)\tommath.lib: $(TOMMATHDIR)\win64\tommath.lib $(COPY) $(TOMMATHDIR)\win64\tommath.lib $(OUT_DIR)\tommath.lib !endif -!if $(TCL_EMBED_SCRIPTS) $(TCLSCRIPTZIP): $(TCLDDELIB) $(TCLREGLIB) @echo Building Tcl library zip file @if exist "$(LIBTCLVFS)" $(RMDIR) "$(LIBTCLVFS)" @@ -604,7 +603,7 @@ $(TCLSCRIPTZIP): $(TCLDDELIB) $(TCLREGLIB) @echo file delete -force {$@} > "$(OUT_DIR)\zipper.tcl" @echo zipfs mkzip {$@} {$(LIBTCLVFS)} {$(LIBTCLVFS)} >> "$(OUT_DIR)\zipper.tcl" @cd "$(OUT_DIR)" && $(TCLSH_NATIVE) zipper.tcl -!endif + pkgs: @for /d %d in ($(PKGSDIR)\*) do \ -- cgit v0.12 From 459642686539ca9da0448167dbbf7fef7435f864 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 16 Mar 2022 22:21:39 +0000 Subject: Handle Tcl_GetCharLength --- generic/tclCmdMZ.c | 22 ++++++++--------- generic/tclCompCmdsSZ.c | 2 +- generic/tclExecute.c | 10 ++++---- generic/tclIO.c | 2 +- generic/tclInt.h | 2 ++ generic/tclProc.c | 2 +- generic/tclStringObj.c | 64 ++++++++++++++++++++++++++++++++++++++++++------- 7 files changed, 76 insertions(+), 28 deletions(-) diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c index db4002a..c2b4eb3 100644 --- a/generic/tclCmdMZ.c +++ b/generic/tclCmdMZ.c @@ -256,7 +256,7 @@ Tcl_RegexpObjCmd( */ objPtr = objv[1]; - stringLength = Tcl_GetCharLength(objPtr); + stringLength = TclGetCharLength(objPtr); if (startIndex) { TclGetIntForIndexM(interp, startIndex, stringLength, &offset); @@ -581,7 +581,7 @@ Tcl_RegsubObjCmd( objv += idx; if (startIndex) { - int stringLength = Tcl_GetCharLength(objv[1]); + int stringLength = TclGetCharLength(objv[1]); TclGetIntForIndexM(interp, startIndex, stringLength, &offset); Tcl_DecrRefCount(startIndex); @@ -1316,7 +1316,7 @@ StringFirstCmd( } if (objc == 4) { - int size = Tcl_GetCharLength(objv[2]); + int size = TclGetCharLength(objv[2]); if (TCL_OK != TclGetIntForIndexM(interp, objv[3], size - 1, &start)) { return TCL_ERROR; @@ -1360,7 +1360,7 @@ StringLastCmd( } if (objc == 4) { - int size = Tcl_GetCharLength(objv[2]); + int size = TclGetCharLength(objv[2]); if (TCL_OK != TclGetIntForIndexM(interp, objv[3], size - 1, &last)) { return TCL_ERROR; @@ -1406,7 +1406,7 @@ StringIndexCmd( * Get the char length to calculate what 'end' means. */ - length = Tcl_GetCharLength(objv[1]); + length = TclGetCharLength(objv[1]); if (TclGetIntForIndexM(interp, objv[2], length-1, &index) != TCL_OK) { return TCL_ERROR; } @@ -1474,7 +1474,7 @@ StringInsertCmd( return TCL_ERROR; } - length = Tcl_GetCharLength(objv[1]); + length = TclGetCharLength(objv[1]); if (TclGetIntForIndexM(interp, objv[2], length, &index) != TCL_OK) { return TCL_ERROR; } @@ -1669,7 +1669,7 @@ StringIsCmd( p++; } TclNewStringObj(tmpStr, string1, p-string1); - failat = Tcl_GetCharLength(tmpStr); + failat = TclGetCharLength(tmpStr); TclDecrRefCount(tmpStr); break; } @@ -1849,7 +1849,7 @@ StringIsCmd( p++; } TclNewStringObj(tmpStr, string1, p-string1); - failat = Tcl_GetCharLength(tmpStr); + failat = TclGetCharLength(tmpStr); TclDecrRefCount(tmpStr); break; } @@ -2293,7 +2293,7 @@ StringRangeCmd( * 'end' refers to the last character, not one past it. */ - length = Tcl_GetCharLength(objv[1]) - 1; + length = TclGetCharLength(objv[1]) - 1; if (TclGetIntForIndexM(interp, objv[2], length, &first) != TCL_OK || TclGetIntForIndexM(interp, objv[3], length, &last) != TCL_OK) { @@ -2394,7 +2394,7 @@ StringRplcCmd( return TCL_ERROR; } - length = Tcl_GetCharLength(objv[1]); + length = TclGetCharLength(objv[1]); end = length - 1; if (TclGetIntForIndexM(interp, objv[2], end, &first) != TCL_OK || @@ -2880,7 +2880,7 @@ StringLenCmd( return TCL_ERROR; } - Tcl_SetObjResult(interp, Tcl_NewWideIntObj(Tcl_GetCharLength(objv[1]))); + Tcl_SetObjResult(interp, Tcl_NewWideIntObj(TclGetCharLength(objv[1]))); return TCL_OK; } diff --git a/generic/tclCompCmdsSZ.c b/generic/tclCompCmdsSZ.c index aa2d13e..62909eb 100644 --- a/generic/tclCompCmdsSZ.c +++ b/generic/tclCompCmdsSZ.c @@ -890,7 +890,7 @@ TclCompileStringLenCmd( */ char buf[TCL_INTEGER_SPACE]; - int len = Tcl_GetCharLength(objPtr); + int len = TclGetCharLength(objPtr); len = sprintf(buf, "%d", len); PushLiteral(envPtr, buf, len); diff --git a/generic/tclExecute.c b/generic/tclExecute.c index 67df5f4..f09f75c 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -5244,7 +5244,7 @@ TEBCresume( case INST_STR_LEN: valuePtr = OBJ_AT_TOS; - length = Tcl_GetCharLength(valuePtr); + length = TclGetCharLength(valuePtr); TclNewIntObj(objResultPtr, length); TRACE(("\"%.20s\" => %d\n", O2S(valuePtr), length)); NEXT_INST_F(1, 1, 1); @@ -5310,7 +5310,7 @@ TEBCresume( * Get char length to calulate what 'end' means. */ - length = Tcl_GetCharLength(valuePtr); + length = TclGetCharLength(valuePtr); DECACHE_STACK_INFO(); if (TclGetIntForIndexM(interp, value2Ptr, length-1, &index)!=TCL_OK) { CACHE_STACK_INFO(); @@ -5353,7 +5353,7 @@ TEBCresume( case INST_STR_RANGE: TRACE(("\"%.20s\" %.20s %.20s =>", O2S(OBJ_AT_DEPTH(2)), O2S(OBJ_UNDER_TOS), O2S(OBJ_AT_TOS))); - length = Tcl_GetCharLength(OBJ_AT_DEPTH(2)) - 1; + length = TclGetCharLength(OBJ_AT_DEPTH(2)) - 1; DECACHE_STACK_INFO(); if (TclGetIntForIndexM(interp, OBJ_UNDER_TOS, length, @@ -5382,7 +5382,7 @@ TEBCresume( valuePtr = OBJ_AT_TOS; fromIdx = TclGetInt4AtPtr(pc+1); toIdx = TclGetInt4AtPtr(pc+5); - length = Tcl_GetCharLength(valuePtr); + length = TclGetCharLength(valuePtr); TRACE(("\"%.20s\" %d %d => ", O2S(valuePtr), fromIdx, toIdx)); /* Every range of an empty value is an empty value */ @@ -5428,7 +5428,7 @@ TEBCresume( case INST_STR_REPLACE: value3Ptr = POP_OBJECT(); valuePtr = OBJ_AT_DEPTH(2); - endIdx = Tcl_GetCharLength(valuePtr) - 1; + endIdx = TclGetCharLength(valuePtr) - 1; TRACE(("\"%.20s\" %s %s \"%.20s\" => ", O2S(valuePtr), O2S(OBJ_UNDER_TOS), O2S(OBJ_AT_TOS), O2S(value3Ptr))); DECACHE_STACK_INFO(); diff --git a/generic/tclIO.c b/generic/tclIO.c index 9d88948..f41e481 100644 --- a/generic/tclIO.c +++ b/generic/tclIO.c @@ -3556,7 +3556,7 @@ Tcl_Close( result = flushcode; } if ((result != 0) && (result != TCL_ERROR) && (interp != NULL) - && 0 == Tcl_GetCharLength(Tcl_GetObjResult(interp))) { + && 0 == TclGetCharLength(Tcl_GetObjResult(interp))) { Tcl_SetErrno(result); Tcl_SetObjResult(interp, Tcl_NewStringObj(Tcl_PosixError(interp), -1)); diff --git a/generic/tclInt.h b/generic/tclInt.h index 75f8858..2d828e8 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -3322,6 +3322,7 @@ MODULE_SCOPE int TclZipfs_Init(Tcl_Interp *interp); #if TCL_UTF_MAX > 3 MODULE_SCOPE int *TclGetUnicodeFromObj_(Tcl_Obj *, int *); MODULE_SCOPE Tcl_Obj *TclNewUnicodeObj(const int *, int); + MODULE_SCOPE int TclGetCharLength(Tcl_Obj *); MODULE_SCOPE void TclAppendUnicodeToObj(Tcl_Obj *, const int *, int); MODULE_SCOPE int TclUniCharNcasecmp(const int *, const int *, unsigned long); MODULE_SCOPE int TclUniCharCaseMatch(const int *, const int *, int); @@ -3329,6 +3330,7 @@ MODULE_SCOPE int TclZipfs_Init(Tcl_Interp *interp); #else # define TclGetUnicodeFromObj_ Tcl_GetUnicodeFromObj # define TclNewUnicodeObj Tcl_NewUnicodeObj +# define TclGetCharLength Tcl_GetCharLength # define TclAppendUnicodeToObj Tcl_AppendUnicodeToObj # define TclUniCharNcasecmp Tcl_UniCharNcasecmp # define TclUniCharCaseMatch Tcl_UniCharCaseMatch diff --git a/generic/tclProc.c b/generic/tclProc.c index 45d1afd..75687f0 100644 --- a/generic/tclProc.c +++ b/generic/tclProc.c @@ -529,7 +529,7 @@ TclCreateProc( "FORMALARGUMENTFORMAT", NULL); goto procError; } - if ((fieldCount == 0) || (Tcl_GetCharLength(fieldValues[0]) == 0)) { + if ((fieldCount == 0) || (TclGetCharLength(fieldValues[0]) == 0)) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "argument with no name", -1)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC", diff --git a/generic/tclStringObj.c b/generic/tclStringObj.c index 1c24716..2dc79eb 100644 --- a/generic/tclStringObj.c +++ b/generic/tclStringObj.c @@ -590,7 +590,7 @@ Tcl_NewUnicodeObj( */ int -Tcl_GetCharLength( +TclGetCharLength( Tcl_Obj *objPtr) /* The String object to get the num chars * of. */ { @@ -643,6 +643,52 @@ Tcl_GetCharLength( return numChars; } +#if TCL_UTF_MAX > 3 +int +Tcl_GetCharLength( + Tcl_Obj *objPtr) /* The String object to get the num chars + * of. */ +{ + String *stringPtr; + int numChars; + + /* + * Quick, no-shimmer return for short string reps. + */ + + if ((objPtr->bytes) && (objPtr->length < 2)) { + /* 0 bytes -> 0 chars; 1 byte -> 1 char */ + return objPtr->length; + } + + /* + * Optimize the case where we're really dealing with a bytearray object; + * we don't need to convert to a string to perform the get-length operation. + * + * Starting in Tcl 8.7, we check for a "pure" bytearray, because the + * machinery behind that test is using a proper bytearray ObjType. We + * could also compute length of an improper bytearray without shimmering + * but there's no value in that. We *want* to shimmer an improper bytearray + * because improper bytearrays have worthless internal reps. + */ + + if (TclIsPureByteArray(objPtr)) { + int length; + + (void) Tcl_GetByteArrayFromObj(objPtr, &length); + return length; + } + + /* + * OK, need to work with the object as a string. + */ + + SetUTF16StringFromAny(NULL, objPtr); + stringPtr = GET_STRING(objPtr); + return stringPtr->numChars; +} +#endif + /* *---------------------------------------------------------------------- * @@ -2336,7 +2382,7 @@ Tcl_AppendFormatToObj( goto errorMsg; case 's': if (gotPrecision) { - numChars = Tcl_GetCharLength(segment); + numChars = TclGetCharLength(segment); if (precision < numChars) { if (precision < 1) { TclNewObj(segment); @@ -2521,7 +2567,7 @@ Tcl_AppendFormatToObj( gotZero = 0; } if (gotZero) { - length += Tcl_GetCharLength(segment); + length += TclGetCharLength(segment); if (length < width) { segmentLimit -= width - length; } @@ -2652,7 +2698,7 @@ Tcl_AppendFormatToObj( gotZero = 0; } if (gotZero) { - length += Tcl_GetCharLength(segment); + length += TclGetCharLength(segment); if (length < width) { segmentLimit -= width - length; } @@ -2763,7 +2809,7 @@ Tcl_AppendFormatToObj( } if (width>0 && numChars<0) { - numChars = Tcl_GetCharLength(segment); + numChars = TclGetCharLength(segment); } if (!gotMinus && width>0) { if (numChars < width) { @@ -3720,8 +3766,8 @@ TclStringCmp( s2 = (char *) TclGetUnicodeFromObj_(value2Ptr, &s2len); memCmpFn = (memCmpFn_t)(void *)TclUniCharNcasecmp; } else { - s1len = Tcl_GetCharLength(value1Ptr); - s2len = Tcl_GetCharLength(value2Ptr); + s1len = TclGetCharLength(value1Ptr); + s2len = TclGetCharLength(value2Ptr); if ((s1len == value1Ptr->length) && (value1Ptr->bytes != NULL) && (s2len == value2Ptr->length) @@ -3866,7 +3912,7 @@ TclStringFirst( Tcl_Obj *haystack, int start) { - int lh, ln = Tcl_GetCharLength(needle); + int lh, ln = TclGetCharLength(needle); Tcl_Obj *result; int value = -1; Tcl_UniChar *checkStr, *endStr, *uh, *un; @@ -3973,7 +4019,7 @@ TclStringLast( Tcl_Obj *haystack, int last) { - int lh, ln = Tcl_GetCharLength(needle); + int lh, ln = TclGetCharLength(needle); Tcl_Obj *result; int value = -1; Tcl_UniChar *checkStr, *uh, *un; -- cgit v0.12 From 17098d70c767e79c2deb65981af371cb209cd159 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 16 Mar 2022 23:08:28 +0000 Subject: Handle Tcl_UtfAtIndex --- generic/tclBinary.c | 4 ++-- generic/tclCmdMZ.c | 12 ++++++------ generic/tclEncoding.c | 2 +- generic/tclIO.c | 2 +- generic/tclInt.h | 6 ++++-- generic/tclRegexp.c | 4 ++-- generic/tclUtf.c | 38 +++++++++++++++++++++++++++++++++----- 7 files changed, 49 insertions(+), 19 deletions(-) diff --git a/generic/tclBinary.c b/generic/tclBinary.c index 4717b05..bc17232 100644 --- a/generic/tclBinary.c +++ b/generic/tclBinary.c @@ -434,7 +434,7 @@ TclGetBytesFromObj( irPtr = TclFetchInternalRep(objPtr, &tclByteArrayType); baPtr = GET_BYTEARRAY(irPtr); - nonbyte = Tcl_UtfAtIndex(Tcl_GetString(objPtr), baPtr->bad); + nonbyte = TclUtfAtIndex(Tcl_GetString(objPtr), baPtr->bad); TclUtfToUCS4(nonbyte, &ucs4); Tcl_SetObjResult(interp, Tcl_ObjPrintf( @@ -473,7 +473,7 @@ Tcl_GetBytesFromObj( irPtr = TclFetchInternalRep(objPtr, &tclByteArrayType); baPtr = GET_BYTEARRAY(irPtr); - nonbyte = Tcl_UtfAtIndex(Tcl_GetString(objPtr), baPtr->bad); + nonbyte = TclUtfAtIndex(Tcl_GetString(objPtr), baPtr->bad); TclUtfToUCS4(nonbyte, &ucs4); Tcl_SetObjResult(interp, Tcl_ObjPrintf( diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c index c2b4eb3..bd5745b 100644 --- a/generic/tclCmdMZ.c +++ b/generic/tclCmdMZ.c @@ -2954,8 +2954,8 @@ StringLowerCmd( } string1 = TclGetStringFromObj(objv[1], &length1); - start = Tcl_UtfAtIndex(string1, first); - end = Tcl_UtfAtIndex(start, last - first + 1); + start = TclUtfAtIndex(string1, first); + end = TclUtfAtIndex(start, last - first + 1); resultPtr = Tcl_NewStringObj(string1, end - string1); string2 = TclGetString(resultPtr) + (start - string1); @@ -3039,8 +3039,8 @@ StringUpperCmd( } string1 = TclGetStringFromObj(objv[1], &length1); - start = Tcl_UtfAtIndex(string1, first); - end = Tcl_UtfAtIndex(start, last - first + 1); + start = TclUtfAtIndex(string1, first); + end = TclUtfAtIndex(start, last - first + 1); resultPtr = Tcl_NewStringObj(string1, end - string1); string2 = TclGetString(resultPtr) + (start - string1); @@ -3124,8 +3124,8 @@ StringTitleCmd( } string1 = TclGetStringFromObj(objv[1], &length1); - start = Tcl_UtfAtIndex(string1, first); - end = Tcl_UtfAtIndex(start, last - first + 1); + start = TclUtfAtIndex(string1, first); + end = TclUtfAtIndex(start, last - first + 1); resultPtr = Tcl_NewStringObj(string1, end - string1); string2 = TclGetString(resultPtr) + (start - string1); diff --git a/generic/tclEncoding.c b/generic/tclEncoding.c index 4630a02..6890d3a 100644 --- a/generic/tclEncoding.c +++ b/generic/tclEncoding.c @@ -1294,7 +1294,7 @@ Tcl_ExternalToUtf( if (*dstCharsPtr <= maxChars) { break; } - dstLen = Tcl_UtfAtIndex(dst, maxChars) - dst + (TCL_UTF_MAX - 1); + dstLen = TclUtfAtIndex(dst, maxChars) - dst + (TCL_UTF_MAX - 1); *statePtr = savedState; } while (1); if (!noTerminate) { diff --git a/generic/tclIO.c b/generic/tclIO.c index f41e481..59aa50f 100644 --- a/generic/tclIO.c +++ b/generic/tclIO.c @@ -6379,7 +6379,7 @@ ReadChars( * bytes demanded by the Tcl_ExternalToUtf() call! */ - dstLimit = Tcl_UtfAtIndex(dst, charsToRead) - dst + (TCL_UTF_MAX - 1); + dstLimit = TclUtfAtIndex(dst, charsToRead) - dst + (TCL_UTF_MAX - 1); statePtr->flags = savedFlags; statePtr->inputEncodingFlags = savedIEFlags; statePtr->inputEncodingState = savedState; diff --git a/generic/tclInt.h b/generic/tclInt.h index 2d828e8..0705c1d 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -3327,6 +3327,7 @@ MODULE_SCOPE int TclZipfs_Init(Tcl_Interp *interp); MODULE_SCOPE int TclUniCharNcasecmp(const int *, const int *, unsigned long); MODULE_SCOPE int TclUniCharCaseMatch(const int *, const int *, int); MODULE_SCOPE int TclUniCharNcmp(const int *, const int *, unsigned long); + MODULE_SCOPE const char *TclUtfAtIndex(const char *, int); #else # define TclGetUnicodeFromObj_ Tcl_GetUnicodeFromObj # define TclNewUnicodeObj Tcl_NewUnicodeObj @@ -3335,6 +3336,7 @@ MODULE_SCOPE int TclZipfs_Init(Tcl_Interp *interp); # define TclUniCharNcasecmp Tcl_UniCharNcasecmp # define TclUniCharCaseMatch Tcl_UniCharCaseMatch # define TclUniCharNcmp Tcl_UniCharNcmp +# define TclUtfAtIndex Tcl_UtfAtIndex #endif @@ -4741,8 +4743,8 @@ MODULE_SCOPE const TclFileAttrProcs tclpFileAttrProcs[]; : Tcl_UtfToUniChar(str, chPtr)) #else #define TclUtfToUniChar(str, chPtr) \ - ((((unsigned char) *(str)) < 0x80) ? \ - ((*(chPtr) = (unsigned char) *(str)), 1) \ + (((UCHAR(*(str))) < 0x80) ? \ + ((*(chPtr) = UCHAR(*(str))), 1) \ : Tcl_UtfToChar16(str, chPtr)) #endif diff --git a/generic/tclRegexp.c b/generic/tclRegexp.c index bb8a6ad..ff7c72c 100644 --- a/generic/tclRegexp.c +++ b/generic/tclRegexp.c @@ -271,8 +271,8 @@ Tcl_RegExpRange( } else { string = regexpPtr->string; } - *startPtr = Tcl_UtfAtIndex(string, regexpPtr->matches[index].rm_so); - *endPtr = Tcl_UtfAtIndex(string, regexpPtr->matches[index].rm_eo); + *startPtr = TclUtfAtIndex(string, regexpPtr->matches[index].rm_so); + *endPtr = TclUtfAtIndex(string, regexpPtr->matches[index].rm_eo); } } diff --git a/generic/tclUtf.c b/generic/tclUtf.c index 02f4358..c47ee97 100644 --- a/generic/tclUtf.c +++ b/generic/tclUtf.c @@ -1166,27 +1166,55 @@ Tcl_UniCharAtIndex( *--------------------------------------------------------------------------- */ +#if TCL_UTF_MAX < 4 +# undef Tcl_UtfToUniChar +# define Tcl_UtfToUniChar Tcl_UtfToChar16 +#endif + const char * -Tcl_UtfAtIndex( +TclUtfAtIndex( const char *src, /* The UTF-8 string. */ int index) /* The position of the desired character. */ { - Tcl_UniChar ch = 0; + Tcl_UniChar ch = 0; int len = 0; while (index-- > 0) { - len = TclUtfToUniChar(src, &ch); + len = (Tcl_UtfToUniChar)(src, &ch); src += len; } #if TCL_UTF_MAX < 4 if ((ch >= 0xD800) && (len < 3)) { /* Index points at character following high Surrogate */ - src += TclUtfToUniChar(src, &ch); + src += (Tcl_UtfToUniChar)(src, &ch); } #endif return src; } +#if TCL_UTF_MAX > 3 +const char * +Tcl_UtfAtIndex( + const char *src, /* The UTF-8 string. */ + int index) /* The position of the desired character. */ +{ + unsigned short ch = 0; + int len = 0; + + while (index-- > 0) { + len = Tcl_UtfToChar16(src, &ch); + src += len; + } + if ((ch >= 0xD800) && (len < 3)) { + /* Index points at character following high Surrogate */ + src += Tcl_UtfToChar16(src, &ch); + } + return src; +} + + +#endif + /* *--------------------------------------------------------------------------- * @@ -2896,7 +2924,7 @@ TclUtfToUCS4( int *ucs4Ptr) /* Filled with the UCS4 codepoint represented * by the UTF-8 string. */ { - /* Make use of the #undef Tcl_UtfToUniChar above, which already handles UCS4. */ +# undef Tcl_UtfToUniChar return Tcl_UtfToUniChar(src, ucs4Ptr); } -- cgit v0.12 From 7fec7395455d2d9a6922571ed615fa5b356c4a17 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 17 Mar 2022 12:00:48 +0000 Subject: Fix 2 testcases which are not testing what they should be testing (since "-encoding ascii" cannot handle the euro-sign \u20ac, it's silently replaced by '?') --- tests/main.test | 2 +- tests/source.test | 4 ++-- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/tests/main.test b/tests/main.test index c4bb48d..758a7d0 100644 --- a/tests/main.test +++ b/tests/main.test @@ -155,7 +155,7 @@ namespace eval ::tcl::test::main { puts -nonewline $f {puts [string equal \u20ac } puts $f "\u20ac]" close $f - catch {set f [open "|[list [interpreter] -encoding ascii script]" r]} + catch {set f [open "|[list [interpreter] -encoding iso8859-1 script]" r]} } -body { read $f } -cleanup { diff --git a/tests/source.test b/tests/source.test index 0235bd1..f2a2858 100644 --- a/tests/source.test +++ b/tests/source.test @@ -284,11 +284,11 @@ test source-7.6 {source -encoding: mismatch encoding error} -setup { puts $f "proc \u20ac {} {return foo}" close $f } -body { - source -encoding ascii $sourcefile + source -encoding iso8859-1 $sourcefile \u20ac } -cleanup { removeFile source.file -} -returnCodes error -match glob -result {invalid command name*} +} -returnCodes error -result "invalid command name \"\u20ac\"" test source-8.1 {source and coroutine/yield} -setup { set sourcefile [makeFile {} source.file] -- cgit v0.12 From 190439cf96a3f4399b008c47251c4f9956c61878 Mon Sep 17 00:00:00 2001 From: oehhar Date: Thu, 17 Mar 2022 13:23:30 +0000 Subject: TIP607 encoding failindex: correct error message, test bytecompiled version --- generic/tclCmdAH.c | 2 +- tests/encoding.test | 51 ++++++++++++++++++++++++++++++++++++++++++--------- 2 files changed, 43 insertions(+), 10 deletions(-) diff --git a/generic/tclCmdAH.c b/generic/tclCmdAH.c index b152369..9772c56 100644 --- a/generic/tclCmdAH.c +++ b/generic/tclCmdAH.c @@ -467,7 +467,7 @@ EncodingConvertfromObjCmd( } } else { encConvFromError: - Tcl_WrongNumArgs(interp, 1, objv, "?-nocomplain|-failindex var? ?encoding? data"); + Tcl_WrongNumArgs(interp, 1, objv, "?-nocomplain? ?-failindex var? ?encoding? data"); return TCL_ERROR; } diff --git a/tests/encoding.test b/tests/encoding.test index f4343c4..9bd0e6b 100644 --- a/tests/encoding.test +++ b/tests/encoding.test @@ -669,37 +669,70 @@ test encoding-24.21 {Parse with -nocomplain but without providing encoding} { } 1 test encoding-24.22 {Syntax error, two encodings} -body { encoding convertfrom iso8859-1 utf-8 "ZX\uD800" -} -returnCodes 1 -result {wrong # args: should be "::tcl::encoding::convertfrom ?-nocomplain|-failindex var? ?encoding? data"} +} -returnCodes 1 -result {wrong # args: should be "::tcl::encoding::convertfrom ?-nocomplain? ?-failindex var? ?encoding? data"} test encoding-24.23 {Syntax error, two encodings} -body { encoding convertto iso8859-1 utf-8 "ZX\uD800" } -returnCodes 1 -result {wrong # args: should be "::tcl::encoding::convertto ?-nocomplain? ?encoding? data"} test encoding-24.24 {Syntax error, no parameter} -body { encoding convertfrom -} -returnCodes 1 -result {wrong # args: should be "encoding convertfrom ?-nocomplain|-failindex var? ?encoding? data"} +} -returnCodes 1 -result {wrong # args: should be "encoding convertfrom ?-nocomplain? ?-failindex var? ?encoding? data"} test encoding-24.25 {Syntax error, -nocomplain and -failindex, no encoding} -body { encoding convertfrom -nocomplain -failindex 2 ABC -} -returnCodes 1 -result {wrong # args: should be "encoding convertfrom ?-nocomplain|-failindex var? ?encoding? data"} +} -returnCodes 1 -result {wrong # args: should be "encoding convertfrom ?-nocomplain? ?-failindex var? ?encoding? data"} test encoding-24.26 {Syntax error, -failindex and -nocomplain, no encoding} -body { encoding convertfrom -failindex 2 -nocomplain ABC } -returnCodes 1 -result {unknown encoding "-nocomplain"} test encoding-24.27 {Syntax error, -nocomplain and -failindex, encoding} -body { encoding convertfrom -nocomplain -failindex 2 utf-8 ABC -} -returnCodes 1 -result {wrong # args: should be "encoding convertfrom ?-nocomplain|-failindex var? ?encoding? data"} +} -returnCodes 1 -result {wrong # args: should be "encoding convertfrom ?-nocomplain? ?-failindex var? ?encoding? data"} test encoding-24.28 {Syntax error, -failindex and -nocomplain, encoding} -body { encoding convertfrom -failindex 2 -nocomplain utf-8 ABC -} -returnCodes 1 -result {wrong # args: should be "encoding convertfrom ?-nocomplain|-failindex var? ?encoding? data"} -test encoding-24.29 {Syntax error, -failindex with no var, no encoding} -body { +} -returnCodes 1 -result {wrong # args: should be "encoding convertfrom ?-nocomplain? ?-failindex var? ?encoding? data"} +test encoding-24.29.1 {Syntax error, -failindex with no var, no encoding} -body { encoding convertfrom -failindex ABC -} -returnCodes 1 -result {wrong # args: should be "::tcl::encoding::convertfrom ?-nocomplain|-failindex var? ?encoding? data"} -test encoding-24.30 {convertrom -failindex with correct data} -body { +} -returnCodes 1 -result {wrong # args: should be "::tcl::encoding::convertfrom ?-nocomplain? ?-failindex var? ?encoding? data"} +test encoding-24.29.2 {Syntax error, -failindex with no var, no encoding (byte compiled)} -setup { + proc encoding_test {} { + encoding convertfrom -failindex ABC + } +} -body { + # Compile and execute + encoding_test +} -returnCodes 1 -result {wrong # args: should be "::tcl::encoding::convertfrom ?-nocomplain? ?-failindex var? ?encoding? data"} -cleanup { + rename encoding_test "" +} +test encoding-24.30.1 {convertrom -failindex with correct data} -body { encoding convertfrom -failindex test ABC set test } -returnCodes 0 -result -1 -test encoding-24.31 {convertrom -failindex with incomplete utf8} -body { +test encoding-24.30.2 {convertrom -failindex with correct data (byt compiled)} -setup { + proc encoding_test {} { + encoding convertfrom -failindex test ABC + set test + } +} -body { + # Compile and execute + encoding_test +} -returnCodes 0 -result -1 -cleanup { + rename encoding_test "" +} +test encoding-24.31.1 {convertrom -failindex with incomplete utf8} -body { set x [encoding convertfrom -failindex i utf-8 A\xc3] binary scan $x H* y list $y $i } -returnCodes 0 -result {41 1} +test encoding-24.31.2 {convertrom -failindex with incomplete utf8 (byte compiled)} -setup { + proc encoding_test {} { + set x [encoding convertfrom -failindex i utf-8 A\xc3] + binary scan $x H* y + list $y $i + } +} -body { + # Compile and execute + encoding_test +} -returnCodes 0 -result {41 1} -cleanup { + rename encoding_test "" +} file delete [file join [temporaryDirectory] iso2022.txt] -- cgit v0.12 From 10367534a7313529151f25caee18fcab436b621f Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 17 Mar 2022 15:05:50 +0000 Subject: More progress --- generic/tclAssembly.c | 4 ++-- generic/tclCompCmdsGR.c | 2 +- generic/tclCompile.c | 28 ++++++++++++++-------------- generic/tclCompile.h | 14 +++++++------- generic/tclDisassemble.c | 10 +++++----- generic/tclExecute.c | 20 ++++++++++---------- generic/tclOptimize.c | 8 ++++---- 7 files changed, 43 insertions(+), 43 deletions(-) diff --git a/generic/tclAssembly.c b/generic/tclAssembly.c index b8a4606..c53fd0b 100644 --- a/generic/tclAssembly.c +++ b/generic/tclAssembly.c @@ -4011,7 +4011,7 @@ UnstackExpiredCatches( --catchDepth; if (catches[catchDepth] != NULL) { range = envPtr->exceptArrayPtr + catchIndices[catchDepth]; - range->numCodeBytes = bbPtr->startOffset - range->codeOffset; + range->numCodeBytes = bbPtr->startOffset - (int)range->codeOffset; catches[catchDepth] = NULL; catchIndices[catchDepth] = -1; } @@ -4030,7 +4030,7 @@ UnstackExpiredCatches( if (catches[catchDepth] != NULL) { if (catches[catchDepth] != block || catchState >= BBCS_CAUGHT) { range = envPtr->exceptArrayPtr + catchIndices[catchDepth]; - range->numCodeBytes = bbPtr->startOffset - range->codeOffset; + range->numCodeBytes = bbPtr->startOffset - (int)range->codeOffset; catches[catchDepth] = NULL; catchIndices[catchDepth] = -1; } diff --git a/generic/tclCompCmdsGR.c b/generic/tclCompCmdsGR.c index 6486b21..92dec77 100644 --- a/generic/tclCompCmdsGR.c +++ b/generic/tclCompCmdsGR.c @@ -2510,7 +2510,7 @@ TclCompileReturnCmd( ExceptionRange range = envPtr->exceptArrayPtr[index]; if ((range.type == CATCH_EXCEPTION_RANGE) - && (range.catchOffset == -1)) { + && (range.catchOffset == TCL_INDEX_NONE)) { enclosingCatch = 1; break; } diff --git a/generic/tclCompile.c b/generic/tclCompile.c index e86a363..a0004dc 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -3409,11 +3409,11 @@ TclCreateExceptRange( rangePtr = &envPtr->exceptArrayPtr[index]; rangePtr->type = type; rangePtr->nestingLevel = envPtr->exceptDepth; - rangePtr->codeOffset = -1; - rangePtr->numCodeBytes = -1; - rangePtr->breakOffset = -1; - rangePtr->continueOffset = -1; - rangePtr->catchOffset = -1; + rangePtr->codeOffset = TCL_INDEX_NONE; + rangePtr->numCodeBytes = TCL_INDEX_NONE; + rangePtr->breakOffset = TCL_INDEX_NONE; + rangePtr->continueOffset = TCL_INDEX_NONE; + rangePtr->catchOffset = TCL_INDEX_NONE; auxPtr = &envPtr->exceptAuxArrayPtr[index]; auxPtr->supportsContinue = 1; auxPtr->stackDepth = envPtr->currStackDepth; @@ -3454,9 +3454,9 @@ TclGetInnermostExceptionRange( while (i > 0) { rangePtr--; i--; - if (CurrentOffset(envPtr) >= rangePtr->codeOffset && - (rangePtr->numCodeBytes == -1 || CurrentOffset(envPtr) < - rangePtr->codeOffset+rangePtr->numCodeBytes) && + if (CurrentOffset(envPtr) >= (int)rangePtr->codeOffset && + (rangePtr->numCodeBytes == TCL_INDEX_NONE || CurrentOffset(envPtr) < + (int)rangePtr->codeOffset+(int)rangePtr->numCodeBytes) && (returnCode != TCL_CONTINUE || envPtr->exceptAuxArrayPtr[i].supportsContinue)) { @@ -3603,10 +3603,10 @@ StartExpanding( * Ignore loops unless they're still being built. */ - if (rangePtr->codeOffset > CurrentOffset(envPtr)) { + if ((int)rangePtr->codeOffset > CurrentOffset(envPtr)) { continue; } - if (rangePtr->numCodeBytes != -1) { + if (rangePtr->numCodeBytes != TCL_INDEX_NONE) { continue; } @@ -3661,12 +3661,12 @@ TclFinalizeLoopExceptionRange( for (i=0 ; inumBreakTargets ; i++) { site = envPtr->codeStart + auxPtr->breakTargets[i]; - offset = rangePtr->breakOffset - auxPtr->breakTargets[i]; + offset = (int)rangePtr->breakOffset - auxPtr->breakTargets[i]; TclUpdateInstInt4AtPc(INST_JUMP4, offset, site); } for (i=0 ; inumContinueTargets ; i++) { site = envPtr->codeStart + auxPtr->continueTargets[i]; - if (rangePtr->continueOffset == -1) { + if (rangePtr->continueOffset == TCL_INDEX_NONE) { int j; /* @@ -3679,7 +3679,7 @@ TclFinalizeLoopExceptionRange( *++site = INST_NOP; } } else { - offset = rangePtr->continueOffset - auxPtr->continueTargets[i]; + offset = (int)rangePtr->continueOffset - auxPtr->continueTargets[i]; TclUpdateInstInt4AtPc(INST_JUMP4, offset, site); } } @@ -4044,7 +4044,7 @@ TclFixupForwardJump( switch (rangePtr->type) { case LOOP_EXCEPTION_RANGE: rangePtr->breakOffset += 3; - if (rangePtr->continueOffset != -1) { + if (rangePtr->continueOffset != TCL_INDEX_NONE) { rangePtr->continueOffset += 3; } break; diff --git a/generic/tclCompile.h b/generic/tclCompile.h index b0491be..439122b 100644 --- a/generic/tclCompile.h +++ b/generic/tclCompile.h @@ -92,17 +92,17 @@ typedef struct { int nestingLevel; /* Static depth of the exception range. Used * to find the most deeply-nested range * surrounding a PC at runtime. */ - int codeOffset; /* Offset of the first instruction byte of the + size_t codeOffset; /* Offset of the first instruction byte of the * code range. */ - int numCodeBytes; /* Number of bytes in the code range. */ - int breakOffset; /* If LOOP_EXCEPTION_RANGE, the target PC + size_t numCodeBytes; /* Number of bytes in the code range. */ + size_t breakOffset; /* If LOOP_EXCEPTION_RANGE, the target PC * offset for a break command in the range. */ - int continueOffset; /* If LOOP_EXCEPTION_RANGE and not -1, the + size_t continueOffset; /* If LOOP_EXCEPTION_RANGE and not -1, the * target PC offset for a continue command in * the code range. Otherwise, ignore this * range when processing a continue * command. */ - int catchOffset; /* If a CATCH_EXCEPTION_RANGE, the target PC + size_t catchOffset; /* If a CATCH_EXCEPTION_RANGE, the target PC * offset for any "exception" in range. */ } ExceptionRange; @@ -1585,11 +1585,11 @@ MODULE_SCOPE int TclPushProcCallFrame(void *clientData, (((envPtr)->exceptDepth++), \ ((envPtr)->maxExceptDepth = \ TclMax((envPtr)->exceptDepth, (envPtr)->maxExceptDepth)), \ - ((envPtr)->exceptArrayPtr[(index)].codeOffset = CurrentOffset(envPtr))) + ((envPtr)->exceptArrayPtr[(index)].codeOffset= CurrentOffset(envPtr))) #define ExceptionRangeEnds(envPtr, index) \ (((envPtr)->exceptDepth--), \ ((envPtr)->exceptArrayPtr[(index)].numCodeBytes = \ - CurrentOffset(envPtr) - (envPtr)->exceptArrayPtr[(index)].codeOffset)) + CurrentOffset(envPtr) - (int)(envPtr)->exceptArrayPtr[(index)].codeOffset)) #define ExceptionRangeTarget(envPtr, index, targetType) \ ((envPtr)->exceptArrayPtr[(index)].targetType = CurrentOffset(envPtr)) diff --git a/generic/tclDisassemble.c b/generic/tclDisassemble.c index 1cef2d2..ff12770 100644 --- a/generic/tclDisassemble.c +++ b/generic/tclDisassemble.c @@ -358,18 +358,18 @@ DisassembleByteCodeObj( ExceptionRange *rangePtr = &codePtr->exceptArrayPtr[i]; Tcl_AppendPrintfToObj(bufferObj, - " %d: level %d, %s, pc %d-%d, ", + " %d: level %d, %s, pc %" TCL_Z_MODIFIER "u-%" TCL_Z_MODIFIER "u, ", i, rangePtr->nestingLevel, (rangePtr->type==LOOP_EXCEPTION_RANGE ? "loop" : "catch"), rangePtr->codeOffset, (rangePtr->codeOffset + rangePtr->numCodeBytes - 1)); switch (rangePtr->type) { case LOOP_EXCEPTION_RANGE: - Tcl_AppendPrintfToObj(bufferObj, "continue %d, break %d\n", + Tcl_AppendPrintfToObj(bufferObj, "continue %" TCL_Z_MODIFIER "u, break %" TCL_Z_MODIFIER "u\n", rangePtr->continueOffset, rangePtr->breakOffset); break; case CATCH_EXCEPTION_RANGE: - Tcl_AppendPrintfToObj(bufferObj, "catch %d\n", + Tcl_AppendPrintfToObj(bufferObj, "catch %" TCL_Z_MODIFIER "u\n", rangePtr->catchOffset); break; default: @@ -1144,14 +1144,14 @@ DisassembleByteCodeAsDicts( switch (rangePtr->type) { case LOOP_EXCEPTION_RANGE: Tcl_ListObjAppendElement(NULL, exn, Tcl_ObjPrintf( - "type %s level %d from %d to %d break %d continue %d", + "type %s level %d from %" TCL_Z_MODIFIER "u to %" TCL_Z_MODIFIER "u break %" TCL_Z_MODIFIER "u continue %" TCL_Z_MODIFIER "u", "loop", rangePtr->nestingLevel, rangePtr->codeOffset, rangePtr->codeOffset + rangePtr->numCodeBytes - 1, rangePtr->breakOffset, rangePtr->continueOffset)); break; case CATCH_EXCEPTION_RANGE: Tcl_ListObjAppendElement(NULL, exn, Tcl_ObjPrintf( - "type %s level %d from %d to %d catch %d", + "type %s level %d from %" TCL_Z_MODIFIER "u to %" TCL_Z_MODIFIER "u catch %" TCL_Z_MODIFIER "u", "catch", rangePtr->nestingLevel, rangePtr->codeOffset, rangePtr->codeOffset + rangePtr->numCodeBytes - 1, rangePtr->catchOffset)); diff --git a/generic/tclExecute.c b/generic/tclExecute.c index 0483bec..9fbf803 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -7228,20 +7228,20 @@ TEBCresume( } if (result == TCL_BREAK) { result = TCL_OK; - pc = (codePtr->codeStart + rangePtr->breakOffset); - TRACE_APPEND(("%s, range at %d, new pc %d\n", + pc = (codePtr->codeStart + (int)rangePtr->breakOffset); + TRACE_APPEND(("%s, range at %" TCL_Z_MODIFIER "u, new pc %" TCL_Z_MODIFIER "u\n", StringForResultCode(result), rangePtr->codeOffset, rangePtr->breakOffset)); NEXT_INST_F(0, 0, 0); } - if (rangePtr->continueOffset == -1) { + if (rangePtr->continueOffset == TCL_INDEX_NONE) { TRACE_APPEND(("%s, loop w/o continue, checking for catch\n", StringForResultCode(result))); goto checkForCatch; } result = TCL_OK; - pc = (codePtr->codeStart + rangePtr->continueOffset); - TRACE_APPEND(("%s, range at %d, new pc %d\n", + pc = (codePtr->codeStart + (int)rangePtr->continueOffset); + TRACE_APPEND(("%s, range at %" TCL_Z_MODIFIER "u, new pc %" TCL_Z_MODIFIER "u\n", StringForResultCode(result), rangePtr->codeOffset, rangePtr->continueOffset)); NEXT_INST_F(0, 0, 0); @@ -7413,13 +7413,13 @@ TEBCresume( } #ifdef TCL_COMPILE_DEBUG if (traceInstructions) { - fprintf(stdout, " ... found catch at %d, catchTop=%d, " + fprintf(stdout, " ... found catch at %" TCL_Z_MODIFIER "u, catchTop=%d, " "unwound to %ld, new pc %" TCL_Z_MODIFIER "u\n", rangePtr->codeOffset, (int) (catchTop - initCatchTop - 1), - (long)*catchTop, (size_t) rangePtr->catchOffset); + (long)*catchTop, rangePtr->catchOffset); } #endif - pc = (codePtr->codeStart + rangePtr->catchOffset); + pc = (codePtr->codeStart + (int)rangePtr->catchOffset); NEXT_INST_F(0, 0, 0); /* Restart the execution loop at pc. */ /* @@ -9120,7 +9120,7 @@ GetExceptRangeForPc( * for the enclosing ExceptionRange. */ { ExceptionRange *rangeArrayPtr; - int numRanges = codePtr->numExceptRanges; + size_t numRanges = codePtr->numExceptRanges; ExceptionRange *rangePtr; size_t pcOffset = pc - codePtr->codeStart; size_t start; @@ -9147,7 +9147,7 @@ GetExceptRangeForPc( if (searchMode == TCL_BREAK) { return rangePtr; } - if (searchMode == TCL_CONTINUE && rangePtr->continueOffset != -1){ + if (searchMode == TCL_CONTINUE && rangePtr->continueOffset != TCL_INDEX_NONE){ return rangePtr; } } diff --git a/generic/tclOptimize.c b/generic/tclOptimize.c index 094638e..2fcc8e1 100644 --- a/generic/tclOptimize.c +++ b/generic/tclOptimize.c @@ -129,13 +129,13 @@ LocateTargetAddresses( ExceptionRange *rangePtr = &envPtr->exceptArrayPtr[i]; if (rangePtr->type == CATCH_EXCEPTION_RANGE) { - targetInstPtr = envPtr->codeStart + rangePtr->catchOffset; + targetInstPtr = envPtr->codeStart + (int)rangePtr->catchOffset; DefineTargetAddress(tablePtr, targetInstPtr); } else { - targetInstPtr = envPtr->codeStart + rangePtr->breakOffset; + targetInstPtr = envPtr->codeStart + (int)rangePtr->breakOffset; DefineTargetAddress(tablePtr, targetInstPtr); - if (rangePtr->continueOffset >= 0) { - targetInstPtr = envPtr->codeStart + rangePtr->continueOffset; + if (rangePtr->continueOffset != TCL_INDEX_NONE) { + targetInstPtr = envPtr->codeStart + (int)rangePtr->continueOffset; DefineTargetAddress(tablePtr, targetInstPtr); } } -- cgit v0.12 From 88a6952fc5f5a2a14afa15b21d6a7492a23ba2ea Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 17 Mar 2022 15:38:18 +0000 Subject: More --- generic/tclDisassemble.c | 4 ++-- generic/tclExecute.c | 2 +- generic/tclInt.h | 4 ++-- generic/tclProc.c | 6 +++--- 4 files changed, 8 insertions(+), 8 deletions(-) diff --git a/generic/tclDisassemble.c b/generic/tclDisassemble.c index ff12770..f0dd908 100644 --- a/generic/tclDisassemble.c +++ b/generic/tclDisassemble.c @@ -321,7 +321,7 @@ DisassembleByteCodeObj( int numCompiledLocals = procPtr->numCompiledLocals; Tcl_AppendPrintfToObj(bufferObj, - " Proc %p, refCt %" TCL_Z_MODIFIER "u, args %d, compiled locals %d\n", + " Proc %p, refCt %" TCL_Z_MODIFIER "u, args %" TCL_Z_MODIFIER "u, compiled locals %d\n", procPtr, procPtr->refCount, procPtr->numArgs, numCompiledLocals); if (numCompiledLocals > 0) { @@ -542,7 +542,7 @@ FormatInstruction( unsigned char *codeStart = codePtr->codeStart; unsigned pcOffset = pc - codeStart; int opnd = 0, i, j, numBytes = 1; - int localCt = procPtr ? procPtr->numCompiledLocals : 0; + int localCt = procPtr ? (int)procPtr->numCompiledLocals : 0; CompiledLocal *localPtr = procPtr ? procPtr->firstLocalPtr : NULL; char suffixBuffer[128]; /* Additional info to print after main opcode * and immediates. */ diff --git a/generic/tclExecute.c b/generic/tclExecute.c index 9fbf803..2db63da 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -8703,7 +8703,7 @@ PrintByteCodeInfo( #endif /* TCL_COMPILE_STATS */ if (procPtr != NULL) { fprintf(stdout, - " Proc 0x%p, refCt %" TCL_Z_MODIFIER "u, args %d, compiled locals %d\n", + " Proc 0x%p, refCt %" TCL_Z_MODIFIER "u, args %" TCL_Z_MODIFIER "u, compiled locals %" TCL_Z_MODIFIER "u\n", procPtr, procPtr->refCount, procPtr->numArgs, procPtr->numCompiledLocals); } diff --git a/generic/tclInt.h b/generic/tclInt.h index 54d9ef9..29e5009 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -983,8 +983,8 @@ typedef struct Proc { * procedure. */ Tcl_Obj *bodyPtr; /* Points to the ByteCode object for * procedure's body command. */ - int numArgs; /* Number of formal parameters. */ - int numCompiledLocals; /* Count of local variables recognized by the + size_t numArgs; /* Number of formal parameters. */ + size_t numCompiledLocals; /* Count of local variables recognized by the * compiler including arguments and * temporaries. */ CompiledLocal *firstLocalPtr; diff --git a/generic/tclProc.c b/generic/tclProc.c index 37821d2..7940cb1 100644 --- a/generic/tclProc.c +++ b/generic/tclProc.c @@ -490,10 +490,10 @@ TclCreateProc( } if (precompiled) { - if (numArgs > (size_t)procPtr->numArgs) { + if (numArgs > procPtr->numArgs) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "procedure \"%s\": arg list contains %" TCL_Z_MODIFIER "u entries, " - "precompiled header expects %d", procName, numArgs, + "precompiled header expects %" TCL_Z_MODIFIER "u", procName, numArgs, procPtr->numArgs)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC", "BYTECODELIES", NULL); @@ -1946,7 +1946,7 @@ TclProcCompileProc( iPtr->compiledProcPtr = procPtr; - if (procPtr->numCompiledLocals > procPtr->numArgs) { + if ((int)procPtr->numCompiledLocals > (int)procPtr->numArgs) { CompiledLocal *clPtr = procPtr->firstLocalPtr; CompiledLocal *lastPtr = NULL; int i, numArgs = procPtr->numArgs; -- cgit v0.12 From 3fb8ab60ef408acf79ad86e0ceef78d7e90650ea Mon Sep 17 00:00:00 2001 From: oehhar Date: Thu, 17 Mar 2022 16:30:59 +0000 Subject: TIP607 encoding failindex: also implement encoding convertto, move tests to cmdAH.test, as the other user interface tests (expect one) is also there. --- generic/tclCmdAH.c | 89 ++++++++++++++++++++++++++------------- tests/cmdAH.test | 119 +++++++++++++++++++++++++++++++++++++++++++++++++++- tests/encoding.test | 31 +------------- 3 files changed, 180 insertions(+), 59 deletions(-) diff --git a/generic/tclCmdAH.c b/generic/tclCmdAH.c index 95ca18a..70767ae 100644 --- a/generic/tclCmdAH.c +++ b/generic/tclCmdAH.c @@ -426,8 +426,8 @@ EncodingConvertfromObjCmd( * Possible combinations: * 1) data -> objc = 2 * 2) encoding data -> objc = 3 - * 3) -nocomplain data -> objc = 3 (8.7) - * 4) -nocomplain encoding data -> objc = 4 (8.7) + * 3) -nocomplain data -> objc = 3 + * 4) -nocomplain encoding data -> objc = 4 * 5) -failindex val data -> objc = 4 * 6) -failindex val encoding data -> objc = 5 */ @@ -467,7 +467,7 @@ EncodingConvertfromObjCmd( } } else { encConvFromError: - Tcl_WrongNumArgs(interp, 1, objv, "?-nocomplain|-failindex var? ?encoding? data"); + Tcl_WrongNumArgs(interp, 1, objv, "?-nocomplain? ?-failindex var? ?encoding? data"); return TCL_ERROR; } @@ -544,42 +544,64 @@ EncodingConverttoObjCmd( Tcl_Encoding encoding; /* Encoding to use */ size_t length; /* Length of the string being converted */ const char *stringPtr; /* Pointer to the first byte of the string */ - size_t result; + size_t result, errorPosition = 0; + Tcl_Obj *failVarObj = NULL; #if TCL_MAJOR_VERSION > 8 || defined(TCL_NO_DEPRECATED) int flags = TCL_ENCODING_STOPONERROR; #else int flags = TCL_ENCODING_NOCOMPLAIN; #endif + /* + * Decode parameters: + * Possible combinations: + * 1) data -> objc = 2 + * 2) encoding data -> objc = 3 + * 3) -nocomplain data -> objc = 3 + * 4) -nocomplain encoding data -> objc = 4 + * 5) -failindex val data -> objc = 4 + * 6) -failindex val encoding data -> objc = 5 + */ + if (objc == 2) { encoding = Tcl_GetEncoding(interp, NULL); data = objv[1]; - } else if ((unsigned)(objc - 2) < 3) { + } else if (objc > 2 && objc < 6) { + int objcUnprocessed = objc; data = objv[objc - 1]; stringPtr = Tcl_GetString(objv[1]); if (stringPtr[0] == '-' && stringPtr[1] == 'n' && !strncmp(stringPtr, "-nocomplain", strlen(stringPtr))) { flags = TCL_ENCODING_NOCOMPLAIN; - } else if (objc < 4) { - if (Tcl_GetEncodingFromObj(interp, objv[objc - 2], &encoding) != TCL_OK) { - return TCL_ERROR; + objcUnprocessed--; + } else if (stringPtr[0] == '-' && stringPtr[1] == 'f' + && !strncmp(stringPtr, "-failindex", strlen(stringPtr))) { + /* at least two additional arguments needed */ + if (objc < 4) { + goto encConvToError; } - goto encConvToOK; - } else { - goto encConvToError; + failVarObj = objv[2]; + flags = TCL_ENCODING_STOPONERROR; + objcUnprocessed -= 2; } - if (objc < 4) { - encoding = Tcl_GetEncoding(interp, NULL); - } else if (Tcl_GetEncodingFromObj(interp, objv[objc - 2], &encoding) != TCL_OK) { - return TCL_ERROR; + switch (objcUnprocessed) { + case 3: + if (Tcl_GetEncodingFromObj(interp, objv[objc - 2], &encoding) != TCL_OK) { + return TCL_ERROR; + } + break; + case 2: + encoding = Tcl_GetEncoding(interp, NULL); + break; + default: + goto encConvToError; } } else { encConvToError: - Tcl_WrongNumArgs(interp, 1, objv, "?-nocomplain? ?encoding? data"); + Tcl_WrongNumArgs(interp, 1, objv, "?-nocomplain? ?-failindex var? ?encoding? data"); return TCL_ERROR; } -encConvToOK: /* * Convert the string to a byte array in 'ds' */ @@ -588,17 +610,28 @@ encConvToOK: result = Tcl_UtfToExternalDStringEx(encoding, stringPtr, length, flags, &ds); if ((flags & TCL_ENCODING_STOPONERROR) && (result != (size_t)-1)) { - size_t pos = Tcl_NumUtfChars(stringPtr, result); - int ucs4; - char buf[TCL_INTEGER_SPACE]; - TclUtfToUCS4(&stringPtr[result], &ucs4); - sprintf(buf, "%" TCL_Z_MODIFIER "u", result); - Tcl_SetObjResult(interp, Tcl_ObjPrintf("unexpected character at index %" - TCL_Z_MODIFIER "u: 'U+%06X'", pos, ucs4)); - Tcl_SetErrorCode(interp, "TCL", "ENCODING", "ILLEGALSEQUENCE", - buf, NULL); - Tcl_DStringFree(&ds); - return TCL_ERROR; + if (failVarObj != NULL) { + /* I hope, wide int will cover size_t data type */ + if (Tcl_ObjSetVar2(interp, failVarObj, NULL, Tcl_NewWideIntObj(result), TCL_LEAVE_ERR_MSG) == NULL) { + return TCL_ERROR; + } + } else { + size_t pos = Tcl_NumUtfChars(stringPtr, result); + int ucs4; + char buf[TCL_INTEGER_SPACE]; + TclUtfToUCS4(&stringPtr[result], &ucs4); + sprintf(buf, "%" TCL_Z_MODIFIER "u", result); + Tcl_SetObjResult(interp, Tcl_ObjPrintf("unexpected character at index %" + TCL_Z_MODIFIER "u: 'U+%06X'", pos, ucs4)); + Tcl_SetErrorCode(interp, "TCL", "ENCODING", "ILLEGALSEQUENCE", + buf, NULL); + Tcl_DStringFree(&ds); + return TCL_ERROR; + } + } else if (failVarObj != NULL) { + if (Tcl_ObjSetVar2(interp, failVarObj, NULL, Tcl_NewIntObj(-1), TCL_LEAVE_ERR_MSG) == NULL) { + return TCL_ERROR; + } } Tcl_SetObjResult(interp, Tcl_NewByteArrayObj((unsigned char*) Tcl_DStringValue(&ds), diff --git a/tests/cmdAH.test b/tests/cmdAH.test index d7be68b..facf67d 100644 --- a/tests/cmdAH.test +++ b/tests/cmdAH.test @@ -172,7 +172,7 @@ test cmdAH-4.2 {Tcl_EncodingObjCmd} -returnCodes error -body { } -result {unknown or ambiguous subcommand "foo": must be convertfrom, convertto, dirs, names, or system} test cmdAH-4.3 {Tcl_EncodingObjCmd} -returnCodes error -body { encoding convertto -} -result {wrong # args: should be "encoding convertto ?-nocomplain? ?encoding? data"} +} -result {wrong # args: should be "encoding convertto ?-nocomplain? ?-failindex var? ?encoding? data"} test cmdAH-4.4 {Tcl_EncodingObjCmd} -returnCodes error -body { encoding convertto foo bar } -result {unknown encoding "foo"} @@ -194,7 +194,7 @@ test cmdAH-4.6 {Tcl_EncodingObjCmd} -setup { } -result 8C test cmdAH-4.7 {Tcl_EncodingObjCmd} -returnCodes error -body { encoding convertfrom -} -result {wrong # args: should be "encoding convertfrom ?-nocomplain|-failindex var? ?encoding? data"} +} -result {wrong # args: should be "encoding convertfrom ?-nocomplain? ?-failindex var? ?encoding? data"} test cmdAH-4.8 {Tcl_EncodingObjCmd} -returnCodes error -body { encoding convertfrom foo bar } -result {unknown encoding "foo"} @@ -229,6 +229,121 @@ test cmdAH-4.13 {Tcl_EncodingObjCmd} -setup { encoding system $system } -result iso8859-1 +test encoding-4.14.1 {Syntax error, -nocomplain and -failindex, no encoding} -body { + encoding convertfrom -nocomplain -failindex 2 ABC +} -returnCodes 1 -result {wrong # args: should be "encoding convertfrom ?-nocomplain? ?-failindex var? ?encoding? data"} +test encoding-4.14.2 {Syntax error, -nocomplain and -failindex, no encoding} -body { + encoding convertto -nocomplain -failindex 2 ABC +} -returnCodes 1 -result {wrong # args: should be "encoding convertto ?-nocomplain? ?-failindex var? ?encoding? data"} +test encoding-4.15.1 {Syntax error, -failindex and -nocomplain, no encoding} -body { + encoding convertfrom -failindex 2 -nocomplain ABC +} -returnCodes 1 -result {unknown encoding "-nocomplain"} +test encoding-4.15.2 {Syntax error, -failindex and -nocomplain, no encoding} -body { + encoding convertto -failindex 2 -nocomplain ABC +} -returnCodes 1 -result {unknown encoding "-nocomplain"} +test encoding-4.16.1 {Syntax error, -nocomplain and -failindex, encoding} -body { + encoding convertfrom -nocomplain -failindex 2 utf-8 ABC +} -returnCodes 1 -result {wrong # args: should be "encoding convertfrom ?-nocomplain? ?-failindex var? ?encoding? data"} +test encoding-4.16.2 {Syntax error, -nocomplain and -failindex, encoding} -body { + encoding convertto -nocomplain -failindex 2 utf-8 ABC +} -returnCodes 1 -result {wrong # args: should be "encoding convertto ?-nocomplain? ?-failindex var? ?encoding? data"} +test encoding-4.17.1 {Syntax error, -failindex and -nocomplain, encoding} -body { + encoding convertfrom -failindex 2 -nocomplain utf-8 ABC +} -returnCodes 1 -result {wrong # args: should be "encoding convertfrom ?-nocomplain? ?-failindex var? ?encoding? data"} +test encoding-4.17.2 {Syntax error, -failindex and -nocomplain, encoding} -body { + encoding convertto -failindex 2 -nocomplain utf-8 ABC +} -returnCodes 1 -result {wrong # args: should be "encoding convertto ?-nocomplain? ?-failindex var? ?encoding? data"} +test encoding-4.18.1 {Syntax error, -failindex with no var, no encoding} -body { + encoding convertfrom -failindex ABC +} -returnCodes 1 -result {wrong # args: should be "::tcl::encoding::convertfrom ?-nocomplain? ?-failindex var? ?encoding? data"} +test encoding-4.18.2 {Syntax error, -failindex with no var, no encoding (byte compiled)} -setup { + proc encoding_test {} { + encoding convertfrom -failindex ABC + } +} -body { + # Compile and execute + encoding_test +} -returnCodes 1 -result {wrong # args: should be "::tcl::encoding::convertfrom ?-nocomplain? ?-failindex var? ?encoding? data"} -cleanup { + rename encoding_test "" +} +test encoding-4.18.3 {Syntax error, -failindex with no var, no encoding} -body { + encoding convertto -failindex ABC +} -returnCodes 1 -result {wrong # args: should be "::tcl::encoding::convertto ?-nocomplain? ?-failindex var? ?encoding? data"} +test encoding-4.18.4 {Syntax error, -failindex with no var, no encoding (byte compiled)} -setup { + proc encoding_test {} { + encoding convertto -failindex ABC + } +} -body { + # Compile and execute + encoding_test +} -returnCodes 1 -result {wrong # args: should be "::tcl::encoding::convertto ?-nocomplain? ?-failindex var? ?encoding? data"} -cleanup { + rename encoding_test "" +} +test encoding-4.19.1 {convertrom -failindex with correct data} -body { + encoding convertfrom -failindex test ABC + set test +} -returnCodes 0 -result -1 +test encoding-4.19.2 {convertrom -failindex with correct data (byt compiled)} -setup { + proc encoding_test {} { + encoding convertfrom -failindex test ABC + set test + } +} -body { + # Compile and execute + encoding_test +} -returnCodes 0 -result -1 -cleanup { + rename encoding_test "" +} +test encoding-4.19.3 {convertrom -failindex with correct data} -body { + encoding convertto -failindex test ABC + set test +} -returnCodes 0 -result -1 +test encoding-4.19.4 {convertrom -failindex with correct data (byt compiled)} -setup { + proc encoding_test {} { + encoding convertto -failindex test ABC + set test + } +} -body { + # Compile and execute + encoding_test +} -returnCodes 0 -result -1 -cleanup { + rename encoding_test "" +} +test encoding-4.20.1 {convertrom -failindex with incomplete utf8} -body { + set x [encoding convertfrom -failindex i utf-8 A\xc3] + binary scan $x H* y + list $y $i +} -returnCodes 0 -result {41 1} +test encoding-4.20.2 {convertrom -failindex with incomplete utf8 (byte compiled)} -setup { + proc encoding_test {} { + set x [encoding convertfrom -failindex i utf-8 A\xc3] + binary scan $x H* y + list $y $i + } +} -body { + # Compile and execute + encoding_test +} -returnCodes 0 -result {41 1} -cleanup { + rename encoding_test "" +} +test encoding-4.21.1 {convertto -failindex with wrong character} -body { + set x [encoding convertto -failindex i iso8859-1 A\u0141] + binary scan $x H* y + list $y $i +} -returnCodes 0 -result {41 1} +test encoding-4.20.2 {convertto -failindex with wrong character (byte compiled)} -setup { + proc encoding_test {} { + set x [encoding convertto -failindex i iso8859-1 A\u0141] + binary scan $x H* y + list $y $i + } +} -body { + # Compile and execute + encoding_test +} -returnCodes 0 -result {41 1} -cleanup { + rename encoding_test "" +} + test cmdAH-5.1 {Tcl_FileObjCmd} -returnCodes error -body { file } -result {wrong # args: should be "file subcommand ?arg ...?"} diff --git a/tests/encoding.test b/tests/encoding.test index 061bc11..5c06b38 100644 --- a/tests/encoding.test +++ b/tests/encoding.test @@ -667,37 +667,10 @@ test encoding-24.21 {Parse with -nocomplain but without providing encoding} { } 1 test encoding-24.22 {Syntax error, two encodings} -body { encoding convertfrom iso8859-1 utf-8 "ZX\uD800" -} -returnCodes 1 -result {wrong # args: should be "::tcl::encoding::convertfrom ?-nocomplain|-failindex var? ?encoding? data"} +} -returnCodes 1 -result {wrong # args: should be "::tcl::encoding::convertfrom ?-nocomplain? ?-failindex var? ?encoding? data"} test encoding-24.23 {Syntax error, two encodings} -body { encoding convertto iso8859-1 utf-8 "ZX\uD800" -} -returnCodes 1 -result {wrong # args: should be "::tcl::encoding::convertto ?-nocomplain? ?encoding? data"} -test encoding-24.24 {Syntax error, no parameter} -body { - encoding convertfrom -} -returnCodes 1 -result {wrong # args: should be "encoding convertfrom ?-nocomplain|-failindex var? ?encoding? data"} -test encoding-24.25 {Syntax error, -nocomplain and -failindex, no encoding} -body { - encoding convertfrom -nocomplain -failindex 2 ABC -} -returnCodes 1 -result {wrong # args: should be "encoding convertfrom ?-nocomplain|-failindex var? ?encoding? data"} -test encoding-24.26 {Syntax error, -failindex and -nocomplain, no encoding} -body { - encoding convertfrom -failindex 2 -nocomplain ABC -} -returnCodes 1 -result {unknown encoding "-nocomplain"} -test encoding-24.27 {Syntax error, -nocomplain and -failindex, encoding} -body { - encoding convertfrom -nocomplain -failindex 2 utf-8 ABC -} -returnCodes 1 -result {wrong # args: should be "encoding convertfrom ?-nocomplain|-failindex var? ?encoding? data"} -test encoding-24.28 {Syntax error, -failindex and -nocomplain, encoding} -body { - encoding convertfrom -failindex 2 -nocomplain utf-8 ABC -} -returnCodes 1 -result {wrong # args: should be "encoding convertfrom ?-nocomplain|-failindex var? ?encoding? data"} -test encoding-24.29 {Syntax error, -failindex with no var, no encoding} -body { - encoding convertfrom -failindex ABC -} -returnCodes 1 -result {wrong # args: should be "::tcl::encoding::convertfrom ?-nocomplain|-failindex var? ?encoding? data"} -test encoding-24.30 {convertrom -failindex with correct data} -body { - encoding convertfrom -failindex test ABC - set test -} -returnCodes 0 -result -1 -test encoding-24.31 {convertrom -failindex with incomplete utf8} -body { - set x [encoding convertfrom -failindex i utf-8 A\xc3] - binary scan $x H* y - list $y $i -} -returnCodes 0 -result {41 1} +} -returnCodes 1 -result {wrong # args: should be "::tcl::encoding::convertto ?-nocomplain? ?-failindex var? ?encoding? data"} file delete [file join [temporaryDirectory] iso2022.txt] -- cgit v0.12 From 21c68a2e1d7a0c5a9b78091d5dffd972a01dede8 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 17 Mar 2022 16:47:03 +0000 Subject: Use TCL_ENCODING_NOCOMPLAIN flag in stead of TCL_ENCODING_STOPONERROR when possible, since TCL_ENCODING_STOPONERROR becomes meaningless in 9.0 --- generic/tclCmdAH.c | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/generic/tclCmdAH.c b/generic/tclCmdAH.c index 60a2c42..c87bc46 100644 --- a/generic/tclCmdAH.c +++ b/generic/tclCmdAH.c @@ -600,7 +600,7 @@ encConvFromOK: } result = Tcl_ExternalToUtfDStringEx(encoding, bytesPtr, length, flags, &ds); - if ((flags & TCL_ENCODING_STOPONERROR) && (result != (size_t)-1)) { + if (!(flags & TCL_ENCODING_NOCOMPLAIN) && (result != (size_t)-1)) { char buf[TCL_INTEGER_SPACE]; sprintf(buf, "%" TCL_Z_MODIFIER "u", result); Tcl_SetObjResult(interp, Tcl_ObjPrintf("unexpected byte sequence starting at index %" @@ -696,7 +696,7 @@ encConvToOK: stringPtr = TclGetStringFromObj(data, &length); result = Tcl_UtfToExternalDStringEx(encoding, stringPtr, length, flags, &ds); - if ((flags & TCL_ENCODING_STOPONERROR) && (result != (size_t)-1)) { + if (!(flags & TCL_ENCODING_NOCOMPLAIN) && (result != (size_t)-1)) { size_t pos = Tcl_NumUtfChars(stringPtr, result); int ucs4; char buf[TCL_INTEGER_SPACE]; -- cgit v0.12 From 75da283be2e7a3fa1a63b4b55ecac6d5c6d64bf4 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 17 Mar 2022 17:02:52 +0000 Subject: Update documentation --- doc/Encoding.3 | 16 ++++++++-------- 1 file changed, 8 insertions(+), 8 deletions(-) diff --git a/doc/Encoding.3 b/doc/Encoding.3 index 663cd3f..d95ca89 100644 --- a/doc/Encoding.3 +++ b/doc/Encoding.3 @@ -99,13 +99,13 @@ converted. \fBTCL_ENCODING_END\fR signifies that the source buffer is the last block in a (potentially multi-block) input stream, telling the conversion routine to perform any finalization that needs to occur after the last byte is converted and then to reset to an initial state. -\fBTCL_ENCODING_STOPONERROR\fR signifies that the conversion routine should -return immediately upon reading a source character that does not exist in -the target encoding; otherwise a default fallback character will -automatically be substituted. The flag \fBTCL_ENCODING_NOCOMPLAIN\fR has -no effect, it is reserved for Tcl 9.0. The flag \fBTCL_ENCODING_MODIFIED\fR makes -\fBTcl_UtfToExternalDStringEx\fR and \fBTcl_UtfToExternal\fR produce the -byte sequence \exC0\ex80 in stead of \ex00, for the utf-8/cesu-8 encoders. +\fBTCL_ENCODING_NOCOMPLAIN\fR signifies that the conversion routine should +not return immediately upon reading a source character that does not exist in +the target encoding, but it will substitute a default fallback character for +all of such characters. The flag \fBTCL_ENCODING_STOPONERROR\fR has no effect, +it only has meaning in Tcl 8.x. The flag \fBTCL_ENCODING_MODIFIED\fR makes +\fBTcl_UtfToExternalDStringEx\fR and \fBTcl_UtfToExternal\fR produce the byte +sequence \exC0\ex80 in stead of \ex00, for the utf-8/cesu-8 encoders. .AP Tcl_EncodingState *statePtr in/out Used when converting a (generally long or indefinite length) byte stream in a piece-by-piece fashion. The conversion routine stores its current @@ -236,7 +236,7 @@ if the input stream has been damaged or if the input encoding method was misidentified. .IP \fBTCL_CONVERT_UNKNOWN\fR 29 The source buffer contained a character that could not be represented in -the target encoding and \fBTCL_ENCODING_STOPONERROR\fR was specified. +the target encoding and \fBTCL_ENCODING_NOCOMPLAIN\fR was not specified. .RE .LP \fBTcl_UtfToExternalDString\fR converts a source buffer \fIsrc\fR from UTF-8 -- cgit v0.12 From ce98d31d01017d2ce8876a1df05eb0d0cf98c0c9 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 17 Mar 2022 17:52:46 +0000 Subject: Eliminate "deprecated" constraint: doens't exist in 9.0 any more. Also remove unused variable --- generic/tclCmdAH.c | 2 +- tests/http.test | 2 +- tests/main.test | 2 +- tests/safe.test | 4 ++-- tests/source.test | 2 +- 5 files changed, 6 insertions(+), 6 deletions(-) diff --git a/generic/tclCmdAH.c b/generic/tclCmdAH.c index 49c7d05..597bb3b 100644 --- a/generic/tclCmdAH.c +++ b/generic/tclCmdAH.c @@ -539,7 +539,7 @@ EncodingConverttoObjCmd( Tcl_Encoding encoding; /* Encoding to use */ size_t length; /* Length of the string being converted */ const char *stringPtr; /* Pointer to the first byte of the string */ - size_t result, errorPosition = 0; + size_t result; Tcl_Obj *failVarObj = NULL; int flags = 0; diff --git a/tests/http.test b/tests/http.test index e09992d..3b2963e 100644 --- a/tests/http.test +++ b/tests/http.test @@ -661,7 +661,7 @@ test http-7.3 {http::formatQuery} -setup { } -cleanup { http::config -urlencoding $enc } -result "can't read \"formMap(∈)\": no such element in array" -test http-7.4 {http::formatQuery} -constraints deprecated -setup { +test http-7.4 {http::formatQuery} -setup { set enc [http::config -urlencoding] } -body { http::config -urlencoding "iso8859-1" diff --git a/tests/main.test b/tests/main.test index 47b2f1a..4aadd79 100644 --- a/tests/main.test +++ b/tests/main.test @@ -143,7 +143,7 @@ namespace eval ::tcl::test::main { test Tcl_Main-1.8 { Tcl_Main: startup script - -encoding option - mismatched encodings } -constraints { - stdio deprecated + stdio } -setup { set script [makeFile {} script] file delete $script diff --git a/tests/safe.test b/tests/safe.test index d93cb6b..76aeb41 100644 --- a/tests/safe.test +++ b/tests/safe.test @@ -1269,7 +1269,7 @@ test safe-11.7 {testing safe encoding} -setup { interp eval $i encoding convertfrom } -returnCodes error -cleanup { safe::interpDelete $i -} -result {wrong # args: should be "encoding convertfrom ?-nocomplain|-failindex var? ?encoding? data"} +} -result {wrong # args: should be "encoding convertfrom ?-nocomplain? ?-failindex var? ?encoding? data"} test safe-11.7.1 {testing safe encoding} -setup { set i [safe::interpCreate] } -body { @@ -1278,7 +1278,7 @@ test safe-11.7.1 {testing safe encoding} -setup { } -returnCodes ok -match glob -cleanup { unset -nocomplain m o safe::interpDelete $i -} -result {wrong # args: should be "encoding convertfrom ?-nocomplain|-failindex var? ?encoding? data" +} -result {wrong # args: should be "encoding convertfrom ?-nocomplain? ?-failindex var? ?encoding? data" while executing "encoding convertfrom" invoked from within diff --git a/tests/source.test b/tests/source.test index 0a9a49f..98aaee2 100644 --- a/tests/source.test +++ b/tests/source.test @@ -275,7 +275,7 @@ test source-7.5 {source -encoding: correct operation} -setup { removeFile source.file rename € {} } -result foo -test source-7.6 {source -encoding: mismatch encoding error} -constraints deprecated -setup { +test source-7.6 {source -encoding: mismatch encoding error} -setup { set sourcefile [makeFile {} source.file] file delete $sourcefile set f [open $sourcefile w] -- cgit v0.12 From ff13acf40513006ce3d0e56049498e5b11cf95bd Mon Sep 17 00:00:00 2001 From: oehhar Date: Thu, 17 Mar 2022 19:48:40 +0000 Subject: TIP607 encoding failindex: user documentation --- doc/encoding.n | 75 +++++++++++++++++++++++++++++++++++++++++++++------------- 1 file changed, 59 insertions(+), 16 deletions(-) diff --git a/doc/encoding.n b/doc/encoding.n index e78a8e7..2277f9d 100644 --- a/doc/encoding.n +++ b/doc/encoding.n @@ -14,16 +14,10 @@ encoding \- Manipulate encodings .BE .SH INTRODUCTION .PP -Strings in Tcl are logically a sequence of 16-bit Unicode characters. +Strings in Tcl are logically a sequence of Unicode characters. These strings are represented in memory as a sequence of bytes that -may be in one of several encodings: modified UTF\-8 (which uses 1 to 3 -bytes per character), 16-bit -.QW Unicode -(which uses 2 bytes per character, with an endianness that is -dependent on the host architecture), and binary (which uses a single -byte per character but only handles a restricted range of characters). -Tcl does not guarantee to always use the same encoding for the same -string. +may be in one of several encodings: modified UTF\-8 (which uses 1 to 4 +bytes per character), or a custom encoding start as 8 bit binary data. .PP Different operating system interfaces or applications may generate strings in other encodings such as Shift\-JIS. The \fBencoding\fR @@ -34,16 +28,30 @@ formats. Performs one of several encoding related operations, depending on \fIoption\fR. The legal \fIoption\fRs are: .TP -\fBencoding convertfrom\fR ?\fIencoding\fR? \fIdata\fR +\fBencoding convertfrom\fR ?\fB-nocomplain\fR? ?\fB-failindex var\fR? +?\fIencoding\fR? \fIdata\fR . -Convert \fIdata\fR to Unicode from the specified \fIencoding\fR. The -characters in \fIdata\fR are treated as binary data where the lower -8-bits of each character is taken as a single byte. The resulting -sequence of bytes is treated as a string in the specified -\fIencoding\fR. If \fIencoding\fR is not specified, the current +Convert \fIdata\fR to a Unicode string from the specified \fIencoding\fR. The +characters in \fIdata\fR are 8 bit binary data. The resulting +sequence of bytes is a string created by applying the given \fIencoding\fR +to the data. If \fIencoding\fR is not specified, the current system encoding is used. +. +The call fails on convertion errors, like an incomplete utf-8 sequence. +The option \fB-failindex\fR is followed by a variable name. The variable +is set to \fI-1\fR if no conversion error occured. It is set to the +first error location in \fIdata\fR in case of a conversion error. All data +until this error location is transformed and retured. This option may not +be used together with \fB-nocomplain\fR. +. +The call does not fail on conversion errors, if the option +\fB-nocomplain\fR is given. In this case, any error locations are replaced +by \fB?\fR. Incomplete sequences are written verbatim to the output string. +The purpose of this switch is to gain compatibility to prior versions of TCL. +It is not recommended for any other usage. .TP -\fBencoding convertto\fR ?\fIencoding\fR? \fIstring\fR +\fBencoding convertto\fR ?\fB-nocomplain\fR? ?\fB-failindex var\fR? +?\fIencoding\fR? \fIstring\fR . Convert \fIstring\fR from Unicode to the specified \fIencoding\fR. The result is a sequence of bytes that represents the converted @@ -51,6 +59,21 @@ string. Each byte is stored in the lower 8-bits of a Unicode character (indeed, the resulting string is a binary string as far as Tcl is concerned, at least initially). If \fIencoding\fR is not specified, the current system encoding is used. +. +The call fails on convertion errors, like a Unicode character not representable +in the given \fIencoding\fR. +. +The option \fB-failindex\fR is followed by a variable name. The variable +is set to \fI-1\fR if no conversion error occured. It is set to the +first error location in \fIdata\fR in case of a conversion error. All data +until this error location is transformed and retured. This option may not +be used together with \fB-nocomplain\fR. +. +The call does not fail on conversion errors, if the option +\fB-nocomplain\fR is given. In this case, any error locations are replaced +by \fB?\fR. Incomplete sequences are written verbatim to the output string. +The purpose of this switch is to gain compatibility to prior versions of TCL. +It is not recommended for any other usage. .TP \fBencoding dirs\fR ?\fIdirectoryList\fR? . @@ -90,6 +113,26 @@ set s [\fBencoding convertfrom\fR euc-jp "\exA4\exCF"] The result is the unicode codepoint: .QW "\eu306F" , which is the Hiragana letter HA. +.PP +The following example detects the error location in an incomplete UTF-8 sequence: +.PP +.CS +% set s [\fBencoding convertfrom\fR -failindex i utf-8 "A\xc3"] +A +% set i +1 +.CE +.PP +The following example detects the error location while transforming to ISO8859-1 +(ISO-Latin 1): +.PP +.CS +% set s [\fBencoding convertto\fR -failindex i utf-8 "A\u0141"] +A +% set i +1 +.CE +.PP .SH "SEE ALSO" Tcl_GetEncoding(3) .SH KEYWORDS -- cgit v0.12 From 20cc8e0bc110e2370ccc8de16637734127d5fcba Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 18 Mar 2022 11:06:00 +0000 Subject: Add proper clean-up to 3 testcases. Failing this, causes test-failures on Windows --- tests/chanio.test | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/tests/chanio.test b/tests/chanio.test index 11a4e74..e668655 100644 --- a/tests/chanio.test +++ b/tests/chanio.test @@ -255,8 +255,8 @@ test chan-io-3.4 {WriteChars: loop over stage buffer} -body { chan configure $f -encoding jis0208 -buffersize 16 chan puts -nonewline $f "\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\" set x [list [contents $path(test1)]] +} -cleanup { chan close $f - lappend x [contents $path(test1)] } -errorCode {POSIX EILSEQ {illegal byte sequence}} -match glob -result {error writing "*": illegal byte sequence} test chan-io-3.5 {WriteChars: saved != 0} -body { # Bytes produced by UtfToExternal from end of last channel buffer had to @@ -266,8 +266,8 @@ test chan-io-3.5 {WriteChars: saved != 0} -body { chan configure $f -encoding jis0208 -buffersize 17 chan puts -nonewline $f "\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\" set x [list [contents $path(test1)]] +} -cleanup { chan close $f - lappend x [contents $path(test1)] } -errorCode {POSIX EILSEQ {illegal byte sequence}} -match glob -result {error writing "*": illegal byte sequence} test chan-io-3.6 {WriteChars: (stageRead + dstWrote == 0)} { # One incomplete UTF-8 character at end of staging buffer. Backup in src @@ -295,8 +295,8 @@ test chan-io-3.7 {WriteChars: (bufPtr->nextAdded > bufPtr->length)} -body { chan configure $f -encoding jis0208 -buffersize 17 chan puts -nonewline $f "\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\" set x [list [contents $path(test1)]] +} -cleanup { chan close $f - lappend x [contents $path(test1)] } -errorCode {POSIX EILSEQ {illegal byte sequence}} -match glob -result {error writing "*": illegal byte sequence} test chan-io-3.8 {WriteChars: reset sawLF after each buffer} { set f [open $path(test1) w] -- cgit v0.12 From d8c018f1a22a3dd5e68107869456c01488a13823 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 18 Mar 2022 13:04:39 +0000 Subject: Add proper cleanup to testcases --- tests/chanio.test | 30 ++++++++++++++++++++---------- tests/http.test | 1 + tests/io.test | 30 ++++++++++++++++++++---------- 3 files changed, 41 insertions(+), 20 deletions(-) diff --git a/tests/chanio.test b/tests/chanio.test index 578dc9f..38f3d90 100644 --- a/tests/chanio.test +++ b/tests/chanio.test @@ -249,7 +249,7 @@ test chan-io-3.3 {WriteChars: compatibility with WriteBytes: flush on line} -bod } -cleanup { chan close $f } -result "\r\n12" -test chan-io-3.4 {WriteChars: loop over stage buffer} deprecated { +test chan-io-3.4 {WriteChars: loop over stage buffer} -constraints deprecated -body { # stage buffer maps to more than can be queued at once. set f [open $path(test1) w] chan configure $f -encoding jis0208 -buffersize 16 @@ -257,8 +257,10 @@ test chan-io-3.4 {WriteChars: loop over stage buffer} deprecated { set x [list [contents $path(test1)]] chan close $f lappend x [contents $path(test1)] -} [list "!)!)!)!)!)!)!)!)" "!)!)!)!)!)!)!)!)!)!)!)!)!)!)!)"] -test chan-io-3.5 {WriteChars: saved != 0} deprecated { +} -cleanup { + catch {chan close $f} +} -result [list "!)!)!)!)!)!)!)!)" "!)!)!)!)!)!)!)!)!)!)!)!)!)!)!)"] +test chan-io-3.5 {WriteChars: saved != 0} -constraints deprecated -body { # Bytes produced by UtfToExternal from end of last channel buffer had to # be moved to beginning of next channel buffer to preserve requested # buffersize. @@ -268,8 +270,10 @@ test chan-io-3.5 {WriteChars: saved != 0} deprecated { set x [list [contents $path(test1)]] chan close $f lappend x [contents $path(test1)] -} [list "!)!)!)!)!)!)!)!)!" "!)!)!)!)!)!)!)!)!)!)!)!)!)!)!)"] -test chan-io-3.6 {WriteChars: (stageRead + dstWrote == 0)} { +} -cleanup { + catch {chan close $f} +} -result [list "!)!)!)!)!)!)!)!)!" "!)!)!)!)!)!)!)!)!)!)!)!)!)!)!)"] +test chan-io-3.6 {WriteChars: (stageRead + dstWrote == 0)} -body { # One incomplete UTF-8 character at end of staging buffer. Backup in src # to the beginning of that UTF-8 character and try again. # @@ -284,8 +288,10 @@ test chan-io-3.6 {WriteChars: (stageRead + dstWrote == 0)} { set x [list [contents $path(test1)]] chan close $f lappend x [contents $path(test1)] -} [list "12345678901234\x82\x60" "12345678901234\x82\x60\x82\x61"] -test chan-io-3.7 {WriteChars: (bufPtr->nextAdded > bufPtr->length)} deprecated { +} -cleanup { + catch {chan close $f} +} -result [list "12345678901234\x82\x60" "12345678901234\x82\x60\x82\x61"] +test chan-io-3.7 {WriteChars: (bufPtr->nextAdded > bufPtr->length)} -constraints deprecated -body { # When translating UTF-8 to external, the produced bytes went past end of # the channel buffer. This is done on purpose - we then truncate the bytes # at the end of the partial character to preserve the requested blocksize @@ -297,8 +303,10 @@ test chan-io-3.7 {WriteChars: (bufPtr->nextAdded > bufPtr->length)} deprecated { set x [list [contents $path(test1)]] chan close $f lappend x [contents $path(test1)] -} [list "!)!)!)!)!)!)!)!)!" "!)!)!)!)!)!)!)!)!)!)!)!)!)!)!)"] -test chan-io-3.8 {WriteChars: reset sawLF after each buffer} { +} -cleanup { + catch {chan close $f} +} -result [list "!)!)!)!)!)!)!)!)!" "!)!)!)!)!)!)!)!)!)!)!)!)!)!)!)"] +test chan-io-3.8 {WriteChars: reset sawLF after each buffer} -body { set f [open $path(test1) w] chan configure $f -encoding ascii -buffering line -translation lf \ -buffersize 16 @@ -306,7 +314,9 @@ test chan-io-3.8 {WriteChars: reset sawLF after each buffer} { set x [list [contents $path(test1)]] chan close $f lappend x [contents $path(test1)] -} [list "abcdefg\nhijklmno" "abcdefg\nhijklmnopqrstuvwxyz"] +} -cleanup { + catch {chan close $f} +} -result [list "abcdefg\nhijklmno" "abcdefg\nhijklmnopqrstuvwxyz"] test chan-io-4.1 {TranslateOutputEOL: lf} { # search for \n diff --git a/tests/http.test b/tests/http.test index 93998fe..a34b168 100644 --- a/tests/http.test +++ b/tests/http.test @@ -15,6 +15,7 @@ if {"::tcltest" ni [namespace children]} { package require tcltest 2.5 namespace import -force ::tcltest::* } +package require tcltests if {[catch {package require http 2} version]} { if {[info exists http2]} { diff --git a/tests/io.test b/tests/io.test index 821b11e..e22fa8a 100644 --- a/tests/io.test +++ b/tests/io.test @@ -268,7 +268,7 @@ test io-3.3 {WriteChars: compatibility with WriteBytes: flush on line} { close $f set x } "\r\n12" -test io-3.4 {WriteChars: loop over stage buffer} deprecated { +test io-3.4 {WriteChars: loop over stage buffer} -constraints deprecated -body { # stage buffer maps to more than can be queued at once. set f [open $path(test1) w] @@ -277,8 +277,10 @@ test io-3.4 {WriteChars: loop over stage buffer} deprecated { set x [list [contents $path(test1)]] close $f lappend x [contents $path(test1)] -} [list "!)!)!)!)!)!)!)!)" "!)!)!)!)!)!)!)!)!)!)!)!)!)!)!)"] -test io-3.5 {WriteChars: saved != 0} deprecated { +} -cleanup { + catch {close $f} +} -result [list "!)!)!)!)!)!)!)!)" "!)!)!)!)!)!)!)!)!)!)!)!)!)!)!)"] +test io-3.5 {WriteChars: saved != 0} -constraints deprecated -body { # Bytes produced by UtfToExternal from end of last channel buffer # had to be moved to beginning of next channel buffer to preserve # requested buffersize. @@ -289,7 +291,9 @@ test io-3.5 {WriteChars: saved != 0} deprecated { set x [list [contents $path(test1)]] close $f lappend x [contents $path(test1)] -} [list "!)!)!)!)!)!)!)!)!" "!)!)!)!)!)!)!)!)!)!)!)!)!)!)!)"] +} -cleanup { + catch {close $f} +} -result [list "!)!)!)!)!)!)!)!)!" "!)!)!)!)!)!)!)!)!)!)!)!)!)!)!)"] test io-3.6 {WriteChars: (stageRead + dstWrote == 0)} { # One incomplete UTF-8 character at end of staging buffer. Backup # in src to the beginning of that UTF-8 character and try again. @@ -307,7 +311,7 @@ test io-3.6 {WriteChars: (stageRead + dstWrote == 0)} { close $f lappend x [contents $path(test1)] } [list "12345678901234\x82\x60" "12345678901234\x82\x60\x82\x61"] -test io-3.7 {WriteChars: (bufPtr->nextAdded > bufPtr->length)} deprecated { +test io-3.7 {WriteChars: (bufPtr->nextAdded > bufPtr->length)} -constraints deprecated -body { # When translating UTF-8 to external, the produced bytes went past end # of the channel buffer. This is done purpose -- we then truncate the # bytes at the end of the partial character to preserve the requested @@ -320,7 +324,9 @@ test io-3.7 {WriteChars: (bufPtr->nextAdded > bufPtr->length)} deprecated { set x [list [contents $path(test1)]] close $f lappend x [contents $path(test1)] -} [list "!)!)!)!)!)!)!)!)!" "!)!)!)!)!)!)!)!)!)!)!)!)!)!)!)"] +} -cleanup { + catch {close $f} +} -result [list "!)!)!)!)!)!)!)!)!" "!)!)!)!)!)!)!)!)!)!)!)!)!)!)!)"] test io-3.8 {WriteChars: reset sawLF after each buffer} { set f [open $path(test1) w] fconfigure $f -encoding ascii -buffering line -translation lf \ @@ -1532,7 +1538,7 @@ test io-12.8 {ReadChars: multibyte chars split} { close $f scan [string index $in end] %c } 160 -test io-12.9 {ReadChars: multibyte chars split} deprecated { +test io-12.9 {ReadChars: multibyte chars split} -constraints deprecated -body { set f [open $path(test1) w] fconfigure $f -translation binary puts -nonewline $f [string repeat a 9]\xC2 @@ -1542,8 +1548,10 @@ test io-12.9 {ReadChars: multibyte chars split} deprecated { set in [read $f] close $f scan [string index $in end] %c -} 194 -test io-12.10 {ReadChars: multibyte chars split} deprecated { +} -cleanup { + catch {close $f} +} -result 194 +test io-12.10 {ReadChars: multibyte chars split} -constraints deprecated -body { set f [open $path(test1) w] fconfigure $f -translation binary puts -nonewline $f [string repeat a 9]\xC2 @@ -1553,7 +1561,9 @@ test io-12.10 {ReadChars: multibyte chars split} deprecated { set in [read $f] close $f scan [string index $in end] %c -} 194 +} -cleanup { + catch {close $f} +} -result 194 test io-13.1 {TranslateInputEOL: cr mode} {} { set f [open $path(test1) w] -- cgit v0.12 From 92e97aec374dfefc0a80edf3fcd4cde7c5cda86c Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 18 Mar 2022 13:05:50 +0000 Subject: Fix meaning of "testConstraint deprepcated" in encoding.test: Those testcases tested the behavior of -DTCL_NO_DEPRECATED --- tests/encoding.test | 16 ++++++++-------- 1 file changed, 8 insertions(+), 8 deletions(-) diff --git a/tests/encoding.test b/tests/encoding.test index bf82493..21e5df1 100644 --- a/tests/encoding.test +++ b/tests/encoding.test @@ -22,7 +22,7 @@ catch { package require -exact tcl::test [info patchlevel] } -testConstraint deprecated [expr {![info exists tcl_precision]}] +package require tcltests proc toutf {args} { variable x @@ -639,28 +639,28 @@ test encoding-24.11 {Parse valid or invalid utf-8} { } 1 test encoding-24.12 {Parse valid or invalid utf-8} -constraints deprecated -body { encoding convertfrom utf-8 "\xC0\x81" -} -returnCodes 1 -result {unexpected byte sequence starting at index 0: '\xC0'} +} -result \xC0\x81 test encoding-24.13 {Parse valid or invalid utf-8} -constraints deprecated -body { encoding convertfrom utf-8 "\xC1\xBF" -} -returnCodes 1 -result {unexpected byte sequence starting at index 0: '\xC1'} +} -result \xC1\xBF test encoding-24.14 {Parse valid or invalid utf-8} { string length [encoding convertfrom utf-8 "\xC2\x80"] } 1 test encoding-24.15 {Parse valid or invalid utf-8} -constraints deprecated -body { encoding convertfrom utf-8 "Z\xE0\x80" -} -returnCodes 1 -result {unexpected byte sequence starting at index 1: '\xE0'} -test encoding-24.16 {Parse valid or invalid utf-8} -constraints {testbytestring deprecated} -body { +} -result Z\xE0\x80 +test encoding-24.16 {Parse valid or invalid utf-8} -constraints testbytestring -body { encoding convertto utf-8 [testbytestring "Z\u4343\x80"] } -returnCodes 1 -result {expected byte sequence but character 1 was '䍃€' (U+004343)} -test encoding-24.17 {Parse valid or invalid utf-8} -constraints {testbytestring deprecated} -body { +test encoding-24.17 {Parse valid or invalid utf-8} -constraints testbytestring -body { encoding convertto utf-8 [testbytestring "Z\xE0\x80"] } -result "Z\xC3\xA0\xE2\x82\xAC" -test encoding-24.18 {Parse valid or invalid utf-8} -constraints {testbytestring deprecated} -body { +test encoding-24.18 {Parse valid or invalid utf-8} -constraints testbytestring -body { encoding convertto utf-8 [testbytestring "Z\xE0\x80xxxxxx"] } -result "Z\xC3\xA0\xE2\x82\xACxxxxxx" test encoding-24.19 {Parse valid or invalid utf-8} -constraints deprecated -body { encoding convertto utf-8 "ZX\uD800" -} -returnCodes 1 -match glob -result "unexpected character at index 2: 'U+00D800'" +} -result ZX\xED\xA0\x80 test encoding-24.20 {Parse with -nocomplain but without providing encoding} { string length [encoding convertfrom -nocomplain "\x20"] } 1 -- cgit v0.12 From 4ae2452d30d79d0dec8956c0cb67171651fb51e6 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 18 Mar 2022 15:39:44 +0000 Subject: See [4dbfa46caa]: Remove "constraint deprecated" from failing testcases which should pass --- tests/chanio.test | 6 +++--- tests/io.test | 10 +++++----- 2 files changed, 8 insertions(+), 8 deletions(-) diff --git a/tests/chanio.test b/tests/chanio.test index 38f3d90..8d922a2 100644 --- a/tests/chanio.test +++ b/tests/chanio.test @@ -249,7 +249,7 @@ test chan-io-3.3 {WriteChars: compatibility with WriteBytes: flush on line} -bod } -cleanup { chan close $f } -result "\r\n12" -test chan-io-3.4 {WriteChars: loop over stage buffer} -constraints deprecated -body { +test chan-io-3.4 {WriteChars: loop over stage buffer} -body { # stage buffer maps to more than can be queued at once. set f [open $path(test1) w] chan configure $f -encoding jis0208 -buffersize 16 @@ -260,7 +260,7 @@ test chan-io-3.4 {WriteChars: loop over stage buffer} -constraints deprecated -b } -cleanup { catch {chan close $f} } -result [list "!)!)!)!)!)!)!)!)" "!)!)!)!)!)!)!)!)!)!)!)!)!)!)!)"] -test chan-io-3.5 {WriteChars: saved != 0} -constraints deprecated -body { +test chan-io-3.5 {WriteChars: saved != 0} -body { # Bytes produced by UtfToExternal from end of last channel buffer had to # be moved to beginning of next channel buffer to preserve requested # buffersize. @@ -291,7 +291,7 @@ test chan-io-3.6 {WriteChars: (stageRead + dstWrote == 0)} -body { } -cleanup { catch {chan close $f} } -result [list "12345678901234\x82\x60" "12345678901234\x82\x60\x82\x61"] -test chan-io-3.7 {WriteChars: (bufPtr->nextAdded > bufPtr->length)} -constraints deprecated -body { +test chan-io-3.7 {WriteChars: (bufPtr->nextAdded > bufPtr->length)} -body { # When translating UTF-8 to external, the produced bytes went past end of # the channel buffer. This is done on purpose - we then truncate the bytes # at the end of the partial character to preserve the requested blocksize diff --git a/tests/io.test b/tests/io.test index e22fa8a..f07fa8d 100644 --- a/tests/io.test +++ b/tests/io.test @@ -268,7 +268,7 @@ test io-3.3 {WriteChars: compatibility with WriteBytes: flush on line} { close $f set x } "\r\n12" -test io-3.4 {WriteChars: loop over stage buffer} -constraints deprecated -body { +test io-3.4 {WriteChars: loop over stage buffer} -body { # stage buffer maps to more than can be queued at once. set f [open $path(test1) w] @@ -280,7 +280,7 @@ test io-3.4 {WriteChars: loop over stage buffer} -constraints deprecated -body { } -cleanup { catch {close $f} } -result [list "!)!)!)!)!)!)!)!)" "!)!)!)!)!)!)!)!)!)!)!)!)!)!)!)"] -test io-3.5 {WriteChars: saved != 0} -constraints deprecated -body { +test io-3.5 {WriteChars: saved != 0} -body { # Bytes produced by UtfToExternal from end of last channel buffer # had to be moved to beginning of next channel buffer to preserve # requested buffersize. @@ -311,7 +311,7 @@ test io-3.6 {WriteChars: (stageRead + dstWrote == 0)} { close $f lappend x [contents $path(test1)] } [list "12345678901234\x82\x60" "12345678901234\x82\x60\x82\x61"] -test io-3.7 {WriteChars: (bufPtr->nextAdded > bufPtr->length)} -constraints deprecated -body { +test io-3.7 {WriteChars: (bufPtr->nextAdded > bufPtr->length)} -body { # When translating UTF-8 to external, the produced bytes went past end # of the channel buffer. This is done purpose -- we then truncate the # bytes at the end of the partial character to preserve the requested @@ -1538,7 +1538,7 @@ test io-12.8 {ReadChars: multibyte chars split} { close $f scan [string index $in end] %c } 160 -test io-12.9 {ReadChars: multibyte chars split} -constraints deprecated -body { +test io-12.9 {ReadChars: multibyte chars split} -body { set f [open $path(test1) w] fconfigure $f -translation binary puts -nonewline $f [string repeat a 9]\xC2 @@ -1551,7 +1551,7 @@ test io-12.9 {ReadChars: multibyte chars split} -constraints deprecated -body { } -cleanup { catch {close $f} } -result 194 -test io-12.10 {ReadChars: multibyte chars split} -constraints deprecated -body { +test io-12.10 {ReadChars: multibyte chars split} -body { set f [open $path(test1) w] fconfigure $f -translation binary puts -nonewline $f [string repeat a 9]\xC2 -- cgit v0.12 From 213119c371559613a16fb7d3f59cb3260f548b22 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 18 Mar 2022 22:11:19 +0000 Subject: More progress --- generic/tclAssembly.c | 58 ++++++++++++++++++++++---------------------- generic/tclCompCmds.c | 34 +++++++++++++------------- generic/tclCompCmdsGR.c | 54 ++++++++++++++++++++--------------------- generic/tclCompCmdsSZ.c | 64 ++++++++++++++++++++++++------------------------- generic/tclCompile.c | 6 ++--- generic/tclEnsemble.c | 14 +++++------ generic/tclInt.h | 6 ++--- generic/tclObj.c | 2 +- generic/tclParse.c | 2 +- generic/tclProc.c | 6 ++--- 10 files changed, 123 insertions(+), 123 deletions(-) diff --git a/generic/tclAssembly.c b/generic/tclAssembly.c index c53fd0b..efe3d97 100644 --- a/generic/tclAssembly.c +++ b/generic/tclAssembly.c @@ -1304,7 +1304,7 @@ AssembleOneLine( switch (instType) { case ASSEM_PUSH: - if ((int)parsePtr->numWords != 2) { + if (parsePtr->numWords != 2) { Tcl_WrongNumArgs(interp, 1, &instNameObj, "value"); goto cleanup; } @@ -1317,7 +1317,7 @@ AssembleOneLine( break; case ASSEM_1BYTE: - if ((int)parsePtr->numWords != 1) { + if (parsePtr->numWords != 1) { Tcl_WrongNumArgs(interp, 1, &instNameObj, ""); goto cleanup; } @@ -1332,7 +1332,7 @@ AssembleOneLine( * are being resolved. */ - if ((int)parsePtr->numWords != 2) { + if (parsePtr->numWords != 2) { Tcl_WrongNumArgs(interp, 1, &instNameObj, "label"); goto cleanup; } @@ -1347,7 +1347,7 @@ AssembleOneLine( break; case ASSEM_BOOL: - if ((int)parsePtr->numWords != 2) { + if (parsePtr->numWords != 2) { Tcl_WrongNumArgs(interp, 1, &instNameObj, "boolean"); goto cleanup; } @@ -1358,7 +1358,7 @@ AssembleOneLine( break; case ASSEM_BOOL_LVT4: - if ((int)parsePtr->numWords != 3) { + if (parsePtr->numWords != 3) { Tcl_WrongNumArgs(interp, 1, &instNameObj, "boolean varName"); goto cleanup; } @@ -1374,7 +1374,7 @@ AssembleOneLine( break; case ASSEM_CLOCK_READ: - if ((int)parsePtr->numWords != 2) { + if (parsePtr->numWords != 2) { Tcl_WrongNumArgs(interp, 1, &instNameObj, "imm8"); goto cleanup; } @@ -1391,7 +1391,7 @@ AssembleOneLine( break; case ASSEM_CONCAT1: - if ((int)parsePtr->numWords != 2) { + if (parsePtr->numWords != 2) { Tcl_WrongNumArgs(interp, 1, &instNameObj, "imm8"); goto cleanup; } @@ -1405,7 +1405,7 @@ AssembleOneLine( case ASSEM_DICT_GET: case ASSEM_DICT_GET_DEF: - if ((int)parsePtr->numWords != 2) { + if (parsePtr->numWords != 2) { Tcl_WrongNumArgs(interp, 1, &instNameObj, "count"); goto cleanup; } @@ -1417,7 +1417,7 @@ AssembleOneLine( break; case ASSEM_DICT_SET: - if ((int)parsePtr->numWords != 3) { + if (parsePtr->numWords != 3) { Tcl_WrongNumArgs(interp, 1, &instNameObj, "count varName"); goto cleanup; } @@ -1434,7 +1434,7 @@ AssembleOneLine( break; case ASSEM_DICT_UNSET: - if ((int)parsePtr->numWords != 3) { + if (parsePtr->numWords != 3) { Tcl_WrongNumArgs(interp, 1, &instNameObj, "count varName"); goto cleanup; } @@ -1451,7 +1451,7 @@ AssembleOneLine( break; case ASSEM_END_CATCH: - if ((int)parsePtr->numWords != 1) { + if (parsePtr->numWords != 1) { Tcl_WrongNumArgs(interp, 1, &instNameObj, ""); goto cleanup; } @@ -1465,7 +1465,7 @@ AssembleOneLine( * code, the message ("script" or "expression") and an evaluator * callback that calls TclCompileScript or TclCompileExpr. */ - if ((int)parsePtr->numWords != 2) { + if (parsePtr->numWords != 2) { Tcl_WrongNumArgs(interp, 1, &instNameObj, ((TalInstructionTable[tblIdx].tclInstCode == INST_EVAL_STK) ? "script" : "expression")); @@ -1491,7 +1491,7 @@ AssembleOneLine( break; case ASSEM_INVOKE: - if ((int)parsePtr->numWords != 2) { + if (parsePtr->numWords != 2) { Tcl_WrongNumArgs(interp, 1, &instNameObj, "count"); goto cleanup; } @@ -1505,7 +1505,7 @@ AssembleOneLine( case ASSEM_JUMP: case ASSEM_JUMP4: - if ((int)parsePtr->numWords != 2) { + if (parsePtr->numWords != 2) { Tcl_WrongNumArgs(interp, 1, &instNameObj, "label"); goto cleanup; } @@ -1533,7 +1533,7 @@ AssembleOneLine( break; case ASSEM_JUMPTABLE: - if ((int)parsePtr->numWords != 2) { + if (parsePtr->numWords != 2) { Tcl_WrongNumArgs(interp, 1, &instNameObj, "table"); goto cleanup; } @@ -1561,7 +1561,7 @@ AssembleOneLine( break; case ASSEM_LABEL: - if ((int)parsePtr->numWords != 2) { + if (parsePtr->numWords != 2) { Tcl_WrongNumArgs(interp, 1, &instNameObj, "name"); goto cleanup; } @@ -1579,7 +1579,7 @@ AssembleOneLine( break; case ASSEM_LINDEX_MULTI: - if ((int)parsePtr->numWords != 2) { + if (parsePtr->numWords != 2) { Tcl_WrongNumArgs(interp, 1, &instNameObj, "count"); goto cleanup; } @@ -1591,7 +1591,7 @@ AssembleOneLine( break; case ASSEM_LIST: - if ((int)parsePtr->numWords != 2) { + if (parsePtr->numWords != 2) { Tcl_WrongNumArgs(interp, 1, &instNameObj, "count"); goto cleanup; } @@ -1603,7 +1603,7 @@ AssembleOneLine( break; case ASSEM_INDEX: - if ((int)parsePtr->numWords != 2) { + if (parsePtr->numWords != 2) { Tcl_WrongNumArgs(interp, 1, &instNameObj, "count"); goto cleanup; } @@ -1614,7 +1614,7 @@ AssembleOneLine( break; case ASSEM_LSET_FLAT: - if ((int)parsePtr->numWords != 2) { + if (parsePtr->numWords != 2) { Tcl_WrongNumArgs(interp, 1, &instNameObj, "count"); goto cleanup; } @@ -1633,7 +1633,7 @@ AssembleOneLine( break; case ASSEM_LVT: - if ((int)parsePtr->numWords != 2) { + if (parsePtr->numWords != 2) { Tcl_WrongNumArgs(interp, 1, &instNameObj, "varname"); goto cleanup; } @@ -1645,7 +1645,7 @@ AssembleOneLine( break; case ASSEM_LVT1: - if ((int)parsePtr->numWords != 2) { + if (parsePtr->numWords != 2) { Tcl_WrongNumArgs(interp, 1, &instNameObj, "varname"); goto cleanup; } @@ -1657,7 +1657,7 @@ AssembleOneLine( break; case ASSEM_LVT1_SINT1: - if ((int)parsePtr->numWords != 3) { + if (parsePtr->numWords != 3) { Tcl_WrongNumArgs(interp, 1, &instNameObj, "varName imm8"); goto cleanup; } @@ -1672,7 +1672,7 @@ AssembleOneLine( break; case ASSEM_LVT4: - if ((int)parsePtr->numWords != 2) { + if (parsePtr->numWords != 2) { Tcl_WrongNumArgs(interp, 1, &instNameObj, "varname"); goto cleanup; } @@ -1684,7 +1684,7 @@ AssembleOneLine( break; case ASSEM_OVER: - if ((int)parsePtr->numWords != 2) { + if (parsePtr->numWords != 2) { Tcl_WrongNumArgs(interp, 1, &instNameObj, "count"); goto cleanup; } @@ -1696,7 +1696,7 @@ AssembleOneLine( break; case ASSEM_REGEXP: - if ((int)parsePtr->numWords != 2) { + if (parsePtr->numWords != 2) { Tcl_WrongNumArgs(interp, 1, &instNameObj, "boolean"); goto cleanup; } @@ -1709,7 +1709,7 @@ AssembleOneLine( break; case ASSEM_REVERSE: - if ((int)parsePtr->numWords != 2) { + if (parsePtr->numWords != 2) { Tcl_WrongNumArgs(interp, 1, &instNameObj, "count"); goto cleanup; } @@ -1721,7 +1721,7 @@ AssembleOneLine( break; case ASSEM_SINT1: - if ((int)parsePtr->numWords != 2) { + if (parsePtr->numWords != 2) { Tcl_WrongNumArgs(interp, 1, &instNameObj, "imm8"); goto cleanup; } @@ -1733,7 +1733,7 @@ AssembleOneLine( break; case ASSEM_SINT4_LVT4: - if ((int)parsePtr->numWords != 3) { + if (parsePtr->numWords != 3) { Tcl_WrongNumArgs(interp, 1, &instNameObj, "count varName"); goto cleanup; } diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c index c9a5724..dba05bf 100644 --- a/generic/tclCompCmds.c +++ b/generic/tclCompCmds.c @@ -255,7 +255,7 @@ TclCompileArrayExistsCmd( Tcl_Token *tokenPtr; int isScalar, localIndex; - if ((int)parsePtr->numWords != 2) { + if (parsePtr->numWords != 2) { return TCL_ERROR; } @@ -293,7 +293,7 @@ TclCompileArraySetCmd( Tcl_Obj *literalObj; ForeachInfo *infoPtr; - if ((int)parsePtr->numWords != 3) { + if (parsePtr->numWords != 3) { return TCL_ERROR; } @@ -461,7 +461,7 @@ TclCompileArrayUnsetCmd( Tcl_Token *tokenPtr = TokenAfter(parsePtr->tokenPtr); int isScalar, localIndex; - if ((int)parsePtr->numWords != 2) { + if (parsePtr->numWords != 2) { return TclCompileBasic2ArgCmd(interp, parsePtr, cmdPtr, envPtr); } @@ -519,7 +519,7 @@ TclCompileBreakCmd( ExceptionRange *rangePtr; ExceptionAux *auxPtr; - if ((int)parsePtr->numWords != 1) { + if (parsePtr->numWords != 1) { return TCL_ERROR; } @@ -613,7 +613,7 @@ TclCompileCatchCmd( } /* DKF */ - if ((int)parsePtr->numWords == 4) { + if (parsePtr->numWords == 4) { optsNameTokenPtr = TokenAfter(resultNameTokenPtr); optsIndex = LocalScalarFromToken(optsNameTokenPtr, envPtr); if (optsIndex < 0) { @@ -821,7 +821,7 @@ TclCompileClockReadingCmd( * compiled. */ CompileEnv *envPtr) /* Holds resulting instructions. */ { - if ((int)parsePtr->numWords != 1) { + if (parsePtr->numWords != 1) { return TCL_ERROR; } @@ -862,7 +862,7 @@ TclCompileConcatCmd( int i; /* TODO: Consider compiling expansion case. */ - if ((int)parsePtr->numWords == 1) { + if (parsePtr->numWords == 1) { /* * [concat] without arguments just pushes an empty object. */ @@ -949,7 +949,7 @@ TclCompileContinueCmd( * There should be no argument after the "continue". */ - if ((int)parsePtr->numWords != 1) { + if (parsePtr->numWords != 1) { return TCL_ERROR; } @@ -1076,7 +1076,7 @@ TclCompileDictIncrCmd( * Parse the increment amount, if present. */ - if ((int)parsePtr->numWords == 4) { + if (parsePtr->numWords == 4) { const char *word; size_t numBytes; int code; @@ -1295,7 +1295,7 @@ TclCompileDictCreateCmd( int i; size_t len; - if (((int)parsePtr->numWords & 1) == 0) { + if ((parsePtr->numWords & 1) == 0) { return TCL_ERROR; } @@ -1394,7 +1394,7 @@ TclCompileDictMergeCmd( if ((int)parsePtr->numWords < 2) { PushStringLiteral(envPtr, ""); return TCL_OK; - } else if ((int)parsePtr->numWords == 2) { + } else if (parsePtr->numWords == 2) { tokenPtr = TokenAfter(parsePtr->tokenPtr); CompileWord(envPtr, tokenPtr, interp, 1); TclEmitOpcode( INST_DUP, envPtr); @@ -1539,7 +1539,7 @@ CompileDictEachCmd( * There must be three arguments after the command. */ - if ((int)parsePtr->numWords != 4) { + if (parsePtr->numWords != 4) { return TclCompileBasic3ArgCmd(interp, parsePtr, cmdPtr, envPtr); } @@ -1967,7 +1967,7 @@ TclCompileDictLappendCmd( /* TODO: Consider support for compiling expanded args. */ /* Probably not. Why is INST_DICT_LAPPEND limited to one value? */ - if ((int)parsePtr->numWords != 4) { + if (parsePtr->numWords != 4) { return TCL_ERROR; } @@ -2374,13 +2374,13 @@ TclCompileErrorCmd( * Construct the options. Note that -code and -level are not here. */ - if ((int)parsePtr->numWords == 2) { + if (parsePtr->numWords == 2) { PushStringLiteral(envPtr, ""); } else { PushStringLiteral(envPtr, "-errorinfo"); tokenPtr = TokenAfter(tokenPtr); CompileWord(envPtr, tokenPtr, interp, 2); - if ((int)parsePtr->numWords == 3) { + if (parsePtr->numWords == 3) { TclEmitInstInt4( INST_LIST, 2, envPtr); } else { PushStringLiteral(envPtr, "-errorcode"); @@ -2427,7 +2427,7 @@ TclCompileExprCmd( { Tcl_Token *firstWordPtr; - if ((int)parsePtr->numWords == 1) { + if (parsePtr->numWords == 1) { return TCL_ERROR; } @@ -2475,7 +2475,7 @@ TclCompileForCmd( int bodyCodeOffset, nextCodeOffset, jumpDist; int bodyRange, nextRange; - if ((int)parsePtr->numWords != 5) { + if (parsePtr->numWords != 5) { return TCL_ERROR; } diff --git a/generic/tclCompCmdsGR.c b/generic/tclCompCmdsGR.c index 92dec77..207b247 100644 --- a/generic/tclCompCmdsGR.c +++ b/generic/tclCompCmdsGR.c @@ -478,7 +478,7 @@ TclCompileIncrCmd( Tcl_Token *varTokenPtr, *incrTokenPtr; int isScalar, localIndex, haveImmValue, immValue; - if (((int)parsePtr->numWords != 2) && ((int)parsePtr->numWords != 3)) { + if ((parsePtr->numWords != 2) && (parsePtr->numWords != 3)) { return TCL_ERROR; } @@ -494,7 +494,7 @@ TclCompileIncrCmd( haveImmValue = 0; immValue = 1; - if ((int)parsePtr->numWords == 3) { + if (parsePtr->numWords == 3) { incrTokenPtr = TokenAfter(varTokenPtr); if (incrTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) { const char *word = incrTokenPtr[1].start; @@ -594,9 +594,9 @@ TclCompileInfoCommandsCmd( * We require one compile-time known argument for the case we can compile. */ - if ((int)parsePtr->numWords == 1) { + if (parsePtr->numWords == 1) { return TclCompileBasic0ArgCmd(interp, parsePtr, cmdPtr, envPtr); - } else if ((int)parsePtr->numWords != 2) { + } else if (parsePtr->numWords != 2) { return TCL_ERROR; } tokenPtr = TokenAfter(parsePtr->tokenPtr); @@ -649,7 +649,7 @@ TclCompileInfoCoroutineCmd( * Only compile [info coroutine] without arguments. */ - if ((int)parsePtr->numWords != 1) { + if (parsePtr->numWords != 1) { return TCL_ERROR; } @@ -673,7 +673,7 @@ TclCompileInfoExistsCmd( Tcl_Token *tokenPtr; int isScalar, localIndex; - if ((int)parsePtr->numWords != 2) { + if (parsePtr->numWords != 2) { return TCL_ERROR; } @@ -721,13 +721,13 @@ TclCompileInfoLevelCmd( * Only compile [info level] without arguments or with a single argument. */ - if ((int)parsePtr->numWords == 1) { + if (parsePtr->numWords == 1) { /* * Not much to do; we compile to a single instruction... */ TclEmitOpcode( INST_INFO_LEVEL_NUM, envPtr); - } else if ((int)parsePtr->numWords != 2) { + } else if (parsePtr->numWords != 2) { return TCL_ERROR; } else { DefineLineInformation; /* TIP #280 */ @@ -754,7 +754,7 @@ TclCompileInfoObjectClassCmd( DefineLineInformation; /* TIP #280 */ Tcl_Token *tokenPtr = TokenAfter(parsePtr->tokenPtr); - if ((int)parsePtr->numWords != 2) { + if (parsePtr->numWords != 2) { return TCL_ERROR; } CompileWord(envPtr, tokenPtr, interp, 1); @@ -779,7 +779,7 @@ TclCompileInfoObjectIsACmd( * engine. */ - if ((int)parsePtr->numWords != 3) { + if (parsePtr->numWords != 3) { return TCL_ERROR; } if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD || tokenPtr[1].size < 1 @@ -808,7 +808,7 @@ TclCompileInfoObjectNamespaceCmd( DefineLineInformation; /* TIP #280 */ Tcl_Token *tokenPtr = TokenAfter(parsePtr->tokenPtr); - if ((int)parsePtr->numWords != 2) { + if (parsePtr->numWords != 2) { return TCL_ERROR; } CompileWord(envPtr, tokenPtr, interp, 1); @@ -1155,7 +1155,7 @@ TclCompileListCmd( int i, numWords, concat, build; Tcl_Obj *listObj, *objPtr; - if ((int)parsePtr->numWords == 1) { + if (parsePtr->numWords == 1) { /* * [list] without arguments just pushes an empty object. */ @@ -1266,7 +1266,7 @@ TclCompileLlengthCmd( DefineLineInformation; /* TIP #280 */ Tcl_Token *varTokenPtr; - if ((int)parsePtr->numWords != 2) { + if (parsePtr->numWords != 2) { return TCL_ERROR; } varTokenPtr = TokenAfter(parsePtr->tokenPtr); @@ -1299,7 +1299,7 @@ TclCompileLrangeCmd( Tcl_Token *tokenPtr, *listTokenPtr; int idx1, idx2; - if ((int)parsePtr->numWords != 4) { + if (parsePtr->numWords != 4) { return TCL_ERROR; } listTokenPtr = TokenAfter(parsePtr->tokenPtr); @@ -1392,7 +1392,7 @@ TclCompileLinsertCmd( */ CompileWord(envPtr, listTokenPtr, interp, 1); - if ((int)parsePtr->numWords == 3) { + if (parsePtr->numWords == 3) { TclEmitInstInt4( INST_LIST_RANGE_IMM, 0, envPtr); TclEmitInt4( (int)TCL_INDEX_END, envPtr); return TCL_OK; @@ -1524,7 +1524,7 @@ TclCompileLreplaceCmd( emptyPrefix = 0; } - if ((idx1 == suffixStart) && ((int)parsePtr->numWords == 4)) { + if ((idx1 == suffixStart) && (parsePtr->numWords == 4)) { /* * This is a "no-op". Example: [lreplace {a b c} 2 0] * We still do a list operation to get list-verification @@ -1711,7 +1711,7 @@ TclCompileLsetCmd( * Emit the correct variety of 'lset' instruction. */ - if ((int)parsePtr->numWords == 4) { + if (parsePtr->numWords == 4) { TclEmitOpcode( INST_LSET_LIST, envPtr); } else { TclEmitInstInt4( INST_LSET_FLAT, (int)parsePtr->numWords-1, envPtr); @@ -1770,7 +1770,7 @@ TclCompileNamespaceCurrentCmd( * Only compile [namespace current] without arguments. */ - if ((int)parsePtr->numWords != 1) { + if (parsePtr->numWords != 1) { return TCL_ERROR; } @@ -1793,7 +1793,7 @@ TclCompileNamespaceCodeCmd( DefineLineInformation; /* TIP #280 */ Tcl_Token *tokenPtr; - if ((int)parsePtr->numWords != 2) { + if (parsePtr->numWords != 2) { return TCL_ERROR; } tokenPtr = TokenAfter(parsePtr->tokenPtr); @@ -1842,7 +1842,7 @@ TclCompileNamespaceOriginCmd( DefineLineInformation; /* TIP #280 */ Tcl_Token *tokenPtr; - if ((int)parsePtr->numWords != 2) { + if (parsePtr->numWords != 2) { return TCL_ERROR; } tokenPtr = TokenAfter(parsePtr->tokenPtr); @@ -1864,7 +1864,7 @@ TclCompileNamespaceQualifiersCmd( Tcl_Token *tokenPtr = TokenAfter(parsePtr->tokenPtr); int off; - if ((int)parsePtr->numWords != 2) { + if (parsePtr->numWords != 2) { return TCL_ERROR; } @@ -1899,7 +1899,7 @@ TclCompileNamespaceTailCmd( Tcl_Token *tokenPtr = TokenAfter(parsePtr->tokenPtr); JumpFixup jumpFixup; - if ((int)parsePtr->numWords != 2) { + if (parsePtr->numWords != 2) { return TCL_ERROR; } @@ -2006,7 +2006,7 @@ TclCompileNamespaceWhichCmd( * "-variable" (currently) and anything else is an error. */ - if ((int)parsePtr->numWords == 3) { + if (parsePtr->numWords == 3) { if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { return TCL_ERROR; } @@ -2274,7 +2274,7 @@ TclCompileRegsubCmd( } if (TclGetString(patternObj)[0] == '-') { if (strcmp(TclGetString(patternObj), "--") != 0 - || (int)parsePtr->numWords == 5) { + || parsePtr->numWords == 5) { goto done; } tokenPtr = TokenAfter(tokenPtr); @@ -2283,7 +2283,7 @@ TclCompileRegsubCmd( if (!TclWordKnownAtCompileTime(tokenPtr, patternObj)) { goto done; } - } else if ((int)parsePtr->numWords == 6) { + } else if (parsePtr->numWords == 6) { goto done; } @@ -2980,9 +2980,9 @@ TclCompileObjectSelfCmd( * bytecoding is at all reasonable. */ - if ((int)parsePtr->numWords == 1) { + if (parsePtr->numWords == 1) { goto compileSelfObject; - } else if ((int)parsePtr->numWords == 2) { + } else if (parsePtr->numWords == 2) { Tcl_Token *tokenPtr = TokenAfter(parsePtr->tokenPtr), *subcmd; if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD || tokenPtr[1].size==0) { diff --git a/generic/tclCompCmdsSZ.c b/generic/tclCompCmdsSZ.c index 0e782ac..66b72c0 100644 --- a/generic/tclCompCmdsSZ.c +++ b/generic/tclCompCmdsSZ.c @@ -300,7 +300,7 @@ TclCompileStringCmpCmd( * We don't support any flags; the bytecode isn't that sophisticated. */ - if ((int)parsePtr->numWords != 3) { + if (parsePtr->numWords != 3) { return TCL_ERROR; } @@ -331,7 +331,7 @@ TclCompileStringEqualCmd( * We don't support any flags; the bytecode isn't that sophisticated. */ - if ((int)parsePtr->numWords != 3) { + if (parsePtr->numWords != 3) { return TCL_ERROR; } @@ -362,7 +362,7 @@ TclCompileStringFirstCmd( * We don't support any flags; the bytecode isn't that sophisticated. */ - if ((int)parsePtr->numWords != 3) { + if (parsePtr->numWords != 3) { return TCL_ERROR; } @@ -393,7 +393,7 @@ TclCompileStringLastCmd( * We don't support any flags; the bytecode isn't that sophisticated. */ - if ((int)parsePtr->numWords != 3) { + if (parsePtr->numWords != 3) { return TCL_ERROR; } @@ -420,7 +420,7 @@ TclCompileStringIndexCmd( DefineLineInformation; /* TIP #280 */ Tcl_Token *tokenPtr; - if ((int)parsePtr->numWords != 3) { + if (parsePtr->numWords != 3) { return TCL_ERROR; } @@ -448,7 +448,7 @@ TclCompileStringInsertCmd( Tcl_Token *tokenPtr; int idx; - if ((int)parsePtr->numWords != 4) { + if (parsePtr->numWords != 4) { return TCL_ERROR; } @@ -549,12 +549,12 @@ TclCompileStringIsCmd( * way to have more than 4 arguments. */ - if ((int)parsePtr->numWords != 3 && (int)parsePtr->numWords != 4) { + if (parsePtr->numWords != 3 && parsePtr->numWords != 4) { return TCL_ERROR; } tokenPtr = TokenAfter(tokenPtr); - if ((int)parsePtr->numWords == 3) { + if (parsePtr->numWords == 3) { allowEmpty = 1; } else { if (!GotLiteral(tokenPtr, "-strict")) { @@ -807,7 +807,7 @@ TclCompileStringMatchCmd( * Check if we have a -nocase flag. */ - if ((int)parsePtr->numWords == 4) { + if (parsePtr->numWords == 4) { if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { return TclCompileBasic3ArgCmd(interp, parsePtr, cmdPtr, envPtr); } @@ -877,7 +877,7 @@ TclCompileStringLenCmd( Tcl_Token *tokenPtr; Tcl_Obj *objPtr; - if ((int)parsePtr->numWords != 2) { + if (parsePtr->numWords != 2) { return TCL_ERROR; } @@ -929,7 +929,7 @@ TclCompileStringMapCmd( * thing to map). */ - if ((int)parsePtr->numWords != 3) { + if (parsePtr->numWords != 3) { return TCL_ERROR; } mapTokenPtr = TokenAfter(parsePtr->tokenPtr); @@ -979,7 +979,7 @@ TclCompileStringRangeCmd( Tcl_Token *stringTokenPtr, *fromTokenPtr, *toTokenPtr; int idx1, idx2; - if ((int)parsePtr->numWords != 4) { + if (parsePtr->numWords != 4) { return TCL_ERROR; } stringTokenPtr = TokenAfter(parsePtr->tokenPtr); @@ -1119,7 +1119,7 @@ TclCompileStringReplaceCmd( */ || ((first >= (int)TCL_INDEX_START) && (last >= (int)TCL_INDEX_START) && (last < first))) { /* Know (last < first) */ - if ((int)parsePtr->numWords == 5) { + if (parsePtr->numWords == 5) { tokenPtr = TokenAfter(tokenPtr); CompileWord(envPtr, tokenPtr, interp, 4); OP( POP); /* Pop newString */ @@ -1128,7 +1128,7 @@ TclCompileStringReplaceCmd( return TCL_OK; } - if ((int)parsePtr->numWords == 5) { + if (parsePtr->numWords == 5) { /* * When we have a string replacement, we have to take care about * not replacing empty substrings that [string replace] promises @@ -1230,7 +1230,7 @@ TclCompileStringReplaceCmd( CompileWord(envPtr, tokenPtr, interp, 2); tokenPtr = TokenAfter(tokenPtr); CompileWord(envPtr, tokenPtr, interp, 3); - if ((int)parsePtr->numWords == 5) { + if (parsePtr->numWords == 5) { tokenPtr = TokenAfter(tokenPtr); CompileWord(envPtr, tokenPtr, interp, 4); } else { @@ -1251,13 +1251,13 @@ TclCompileStringTrimLCmd( DefineLineInformation; /* TIP #280 */ Tcl_Token *tokenPtr; - if ((int)parsePtr->numWords != 2 && (int)parsePtr->numWords != 3) { + if (parsePtr->numWords != 2 && parsePtr->numWords != 3) { return TCL_ERROR; } tokenPtr = TokenAfter(parsePtr->tokenPtr); CompileWord(envPtr, tokenPtr, interp, 1); - if ((int)parsePtr->numWords == 3) { + if (parsePtr->numWords == 3) { tokenPtr = TokenAfter(tokenPtr); CompileWord(envPtr, tokenPtr, interp, 2); } else { @@ -1278,13 +1278,13 @@ TclCompileStringTrimRCmd( DefineLineInformation; /* TIP #280 */ Tcl_Token *tokenPtr; - if ((int)parsePtr->numWords != 2 && (int)parsePtr->numWords != 3) { + if (parsePtr->numWords != 2 && parsePtr->numWords != 3) { return TCL_ERROR; } tokenPtr = TokenAfter(parsePtr->tokenPtr); CompileWord(envPtr, tokenPtr, interp, 1); - if ((int)parsePtr->numWords == 3) { + if (parsePtr->numWords == 3) { tokenPtr = TokenAfter(tokenPtr); CompileWord(envPtr, tokenPtr, interp, 2); } else { @@ -1305,13 +1305,13 @@ TclCompileStringTrimCmd( DefineLineInformation; /* TIP #280 */ Tcl_Token *tokenPtr; - if ((int)parsePtr->numWords != 2 && (int)parsePtr->numWords != 3) { + if (parsePtr->numWords != 2 && parsePtr->numWords != 3) { return TCL_ERROR; } tokenPtr = TokenAfter(parsePtr->tokenPtr); CompileWord(envPtr, tokenPtr, interp, 1); - if ((int)parsePtr->numWords == 3) { + if (parsePtr->numWords == 3) { tokenPtr = TokenAfter(tokenPtr); CompileWord(envPtr, tokenPtr, interp, 2); } else { @@ -1333,7 +1333,7 @@ TclCompileStringToUpperCmd( DefineLineInformation; /* TIP #280 */ Tcl_Token *tokenPtr; - if ((int)parsePtr->numWords != 2) { + if (parsePtr->numWords != 2) { return TclCompileBasic1To3ArgCmd(interp, parsePtr, cmdPtr, envPtr); } @@ -1355,7 +1355,7 @@ TclCompileStringToLowerCmd( DefineLineInformation; /* TIP #280 */ Tcl_Token *tokenPtr; - if ((int)parsePtr->numWords != 2) { + if (parsePtr->numWords != 2) { return TclCompileBasic1To3ArgCmd(interp, parsePtr, cmdPtr, envPtr); } @@ -1377,7 +1377,7 @@ TclCompileStringToTitleCmd( DefineLineInformation; /* TIP #280 */ Tcl_Token *tokenPtr; - if ((int)parsePtr->numWords != 2) { + if (parsePtr->numWords != 2) { return TclCompileBasic1To3ArgCmd(interp, parsePtr, cmdPtr, envPtr); } @@ -3767,7 +3767,7 @@ TclCompileWhileCmd( * infinite loop. */ Tcl_Obj *boolObj; - if ((int)parsePtr->numWords != 3) { + if (parsePtr->numWords != 3) { return TCL_ERROR; } @@ -3940,7 +3940,7 @@ TclCompileYieldCmd( return TCL_ERROR; } - if ((int)parsePtr->numWords == 1) { + if (parsePtr->numWords == 1) { PUSH(""); } else { DefineLineInformation; /* TIP #280 */ @@ -4024,7 +4024,7 @@ CompileUnaryOpCmd( DefineLineInformation; /* TIP #280 */ Tcl_Token *tokenPtr; - if ((int)parsePtr->numWords != 2) { + if (parsePtr->numWords != 2) { return TCL_ERROR; } tokenPtr = TokenAfter(parsePtr->tokenPtr); @@ -4116,7 +4116,7 @@ CompileStrictlyBinaryOpCmd( int instruction, CompileEnv *envPtr) { - if ((int)parsePtr->numWords != 3) { + if (parsePtr->numWords != 3) { return TCL_ERROR; } return CompileAssociativeBinaryOpCmd(interp, parsePtr, @@ -4154,7 +4154,7 @@ CompileComparisonOpCmd( /* TODO: Consider support for compiling expanded args. */ if ((int)parsePtr->numWords < 3) { PUSH("1"); - } else if ((int)parsePtr->numWords == 3) { + } else if (parsePtr->numWords == 3) { tokenPtr = TokenAfter(parsePtr->tokenPtr); CompileWord(envPtr, tokenPtr, interp, 1); tokenPtr = TokenAfter(tokenPtr); @@ -4508,7 +4508,7 @@ TclCompileMinusOpCmd( int words; /* TODO: Consider support for compiling expanded args. */ - if ((int)parsePtr->numWords == 1) { + if (parsePtr->numWords == 1) { /* * Fallback to direct eval to report syntax error. */ @@ -4553,14 +4553,14 @@ TclCompileDivOpCmd( int words; /* TODO: Consider support for compiling expanded args. */ - if ((int)parsePtr->numWords == 1) { + if (parsePtr->numWords == 1) { /* * Fallback to direct eval to report syntax error. */ return TCL_ERROR; } - if ((int)parsePtr->numWords == 2) { + if (parsePtr->numWords == 2) { PUSH("1.0"); } for (words=1 ; words<(int)parsePtr->numWords ; words++) { diff --git a/generic/tclCompile.c b/generic/tclCompile.c index a0004dc..bcd8026 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -2215,7 +2215,7 @@ TclCompileScript( numBytes -= next - p; p = next; - if ((int)parsePtr->numWords == 0) { + if (parsePtr->numWords == 0) { /* * The "command" parsed has no words. In this case we can skip * the rest of the loop body. With no words, clearly @@ -2991,7 +2991,7 @@ TclFindCompiledLocal( { CompiledLocal *localPtr; int localVar = -1; - int i; + size_t i; Proc *procPtr; /* @@ -3029,7 +3029,7 @@ TclFindCompiledLocal( } if (name != NULL) { - int localCt = procPtr->numCompiledLocals; + size_t localCt = procPtr->numCompiledLocals; localPtr = procPtr->firstLocalPtr; for (i = 0; i < localCt; i++) { diff --git a/generic/tclEnsemble.c b/generic/tclEnsemble.c index 56dc3c1..738668f 100644 --- a/generic/tclEnsemble.c +++ b/generic/tclEnsemble.c @@ -3489,7 +3489,7 @@ TclCompileBasic0ArgCmd( * which is the only code that sees the shenanigans of ensemble dispatch. */ - if ((int)parsePtr->numWords != 1) { + if (parsePtr->numWords != 1) { return TCL_ERROR; } @@ -3511,7 +3511,7 @@ TclCompileBasic1ArgCmd( * which is the only code that sees the shenanigans of ensemble dispatch. */ - if ((int)parsePtr->numWords != 2) { + if (parsePtr->numWords != 2) { return TCL_ERROR; } @@ -3533,7 +3533,7 @@ TclCompileBasic2ArgCmd( * which is the only code that sees the shenanigans of ensemble dispatch. */ - if ((int)parsePtr->numWords != 3) { + if (parsePtr->numWords != 3) { return TCL_ERROR; } @@ -3555,7 +3555,7 @@ TclCompileBasic3ArgCmd( * which is the only code that sees the shenanigans of ensemble dispatch. */ - if ((int)parsePtr->numWords != 4) { + if (parsePtr->numWords != 4) { return TCL_ERROR; } @@ -3577,7 +3577,7 @@ TclCompileBasic0Or1ArgCmd( * which is the only code that sees the shenanigans of ensemble dispatch. */ - if ((int)parsePtr->numWords != 1 && (int)parsePtr->numWords != 2) { + if (parsePtr->numWords != 1 && parsePtr->numWords != 2) { return TCL_ERROR; } @@ -3599,7 +3599,7 @@ TclCompileBasic1Or2ArgCmd( * which is the only code that sees the shenanigans of ensemble dispatch. */ - if ((int)parsePtr->numWords != 2 && (int)parsePtr->numWords != 3) { + if (parsePtr->numWords != 2 && parsePtr->numWords != 3) { return TCL_ERROR; } @@ -3621,7 +3621,7 @@ TclCompileBasic2Or3ArgCmd( * which is the only code that sees the shenanigans of ensemble dispatch. */ - if ((int)parsePtr->numWords != 3 && (int)parsePtr->numWords != 4) { + if (parsePtr->numWords != 3 && parsePtr->numWords != 4) { return TCL_ERROR; } diff --git a/generic/tclInt.h b/generic/tclInt.h index 29e5009..10b4137 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -1090,7 +1090,7 @@ typedef struct AssocData { typedef struct LocalCache { size_t refCount; - int numVars; + size_t numVars; Tcl_Obj *varName0; } LocalCache; @@ -1292,7 +1292,7 @@ typedef struct CFWordBC { #define CLL_END (-1) typedef struct ContLineLoc { - int num; /* Number of entries in loc, not counting the + size_t num; /* Number of entries in loc, not counting the * final -1 marker entry. */ int loc[TCLFLEXARRAY];/* Table of locations, as character offsets. * The table is allocated as part of the @@ -2877,7 +2877,7 @@ MODULE_SCOPE Tcl_ObjCmdProc TclChannelNamesCmd; MODULE_SCOPE Tcl_NRPostProc TclClearRootEnsemble; MODULE_SCOPE int TclCompareTwoNumbers(Tcl_Obj *valuePtr, Tcl_Obj *value2Ptr); -MODULE_SCOPE ContLineLoc *TclContinuationsEnter(Tcl_Obj *objPtr, int num, +MODULE_SCOPE ContLineLoc *TclContinuationsEnter(Tcl_Obj *objPtr, size_t num, int *loc); MODULE_SCOPE void TclContinuationsEnterDerived(Tcl_Obj *objPtr, int start, int *clNext); diff --git a/generic/tclObj.c b/generic/tclObj.c index 361d466..2351fb2 100644 --- a/generic/tclObj.c +++ b/generic/tclObj.c @@ -525,7 +525,7 @@ TclGetContLineTable(void) ContLineLoc * TclContinuationsEnter( Tcl_Obj *objPtr, - int num, + size_t num, int *loc) { int newEntry; diff --git a/generic/tclParse.c b/generic/tclParse.c index 1462fd7..5b4689f 100644 --- a/generic/tclParse.c +++ b/generic/tclParse.c @@ -1543,7 +1543,7 @@ Tcl_ParseVar( if (termPtr != NULL) { *termPtr = start + parsePtr->tokenPtr->size; } - if ((int)parsePtr->numTokens == 1) { + if (parsePtr->numTokens == 1) { /* * There isn't a variable name after all: the $ is just a $. */ diff --git a/generic/tclProc.c b/generic/tclProc.c index 7940cb1..74e6310 100644 --- a/generic/tclProc.c +++ b/generic/tclProc.c @@ -1246,7 +1246,7 @@ TclFreeLocalCache( Tcl_Interp *interp, LocalCache *localCachePtr) { - int i; + size_t i; Tcl_Obj **namePtrPtr = &localCachePtr->varName0; for (i = 0; i < localCachePtr->numVars; i++, namePtrPtr++) { @@ -1266,8 +1266,8 @@ InitLocalCache( { Interp *iPtr = procPtr->iPtr; ByteCode *codePtr; - int localCt = procPtr->numCompiledLocals; - int numArgs = procPtr->numArgs, i = 0; + size_t localCt = procPtr->numCompiledLocals; + size_t numArgs = procPtr->numArgs, i = 0; Tcl_Obj **namePtr; Var *varPtr; -- cgit v0.12 From 5f7628019d2481e58ddee7d42ade95085cf69687 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 18 Mar 2022 23:09:03 +0000 Subject: Further , --- generic/tclCompile.c | 8 ++++---- generic/tclCompile.h | 4 ++-- generic/tclDisassemble.c | 14 +++++++------- generic/tclExecute.c | 6 +++--- generic/tclInt.h | 2 +- 5 files changed, 17 insertions(+), 17 deletions(-) diff --git a/generic/tclCompile.c b/generic/tclCompile.c index bcd8026..e23b0e6 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -1036,7 +1036,7 @@ CleanupByteCode( statsPtr = &iPtr->stats; statsPtr->numByteCodesFreed++; - statsPtr->currentSrcBytes -= (double) codePtr->numSrcBytes; + statsPtr->currentSrcBytes -= (double) (int)codePtr->numSrcBytes; statsPtr->currentByteCodeBytes -= (double) codePtr->structureSize; statsPtr->currentInstBytes -= (double) codePtr->numCodeBytes; @@ -4527,12 +4527,12 @@ RecordByteCodeStats( statsPtr = &(iPtr->stats); statsPtr->numCompilations++; - statsPtr->totalSrcBytes += (double) codePtr->numSrcBytes; + statsPtr->totalSrcBytes += (double) (int)codePtr->numSrcBytes; statsPtr->totalByteCodeBytes += (double) codePtr->structureSize; - statsPtr->currentSrcBytes += (double) codePtr->numSrcBytes; + statsPtr->currentSrcBytes += (double) (int)codePtr->numSrcBytes; statsPtr->currentByteCodeBytes += (double) codePtr->structureSize; - statsPtr->srcCount[TclLog2(codePtr->numSrcBytes)]++; + statsPtr->srcCount[TclLog2((int)codePtr->numSrcBytes)]++; statsPtr->byteCodeCount[TclLog2((int) codePtr->structureSize)]++; statsPtr->currentInstBytes += (double) codePtr->numCodeBytes; diff --git a/generic/tclCompile.h b/generic/tclCompile.h index 439122b..669e11d 100644 --- a/generic/tclCompile.h +++ b/generic/tclCompile.h @@ -459,8 +459,8 @@ typedef struct ByteCode { * itself. Does not include heap space for * literal Tcl objects or storage referenced * by AuxData entries. */ - int numCommands; /* Number of commands compiled. */ - int numSrcBytes; /* Number of source bytes compiled. */ + size_t numCommands; /* Number of commands compiled. */ + size_t numSrcBytes; /* Number of source bytes compiled. */ int numCodeBytes; /* Number of code bytes. */ int numLitObjects; /* Number of objects in literal array. */ int numExceptRanges; /* Number of ExceptionRange array elems. */ diff --git a/generic/tclDisassemble.c b/generic/tclDisassemble.c index f0dd908..a8a9606 100644 --- a/generic/tclDisassemble.c +++ b/generic/tclDisassemble.c @@ -270,7 +270,7 @@ DisassembleByteCodeObj( codeStart = codePtr->codeStart; codeLimit = codeStart + codePtr->numCodeBytes; - numCmds = codePtr->numCommands; + numCmds = (int)codePtr->numCommands; /* * Print header lines describing the ByteCode. @@ -281,7 +281,7 @@ DisassembleByteCodeObj( codePtr, codePtr->refCount, codePtr->compileEpoch, iPtr, iPtr->compileEpoch); Tcl_AppendToObj(bufferObj, " Source ", -1); PrintSourceToObj(bufferObj, codePtr->source, - TclMin(codePtr->numSrcBytes, 55)); + TclMin((int)codePtr->numSrcBytes, 55)); GetLocationInformation(codePtr->procPtr, &fileObj, &line); if (line >= 0 && fileObj != NULL) { Tcl_AppendPrintfToObj(bufferObj, "\n File \"%s\" Line %d", @@ -289,12 +289,12 @@ DisassembleByteCodeObj( } Tcl_AppendPrintfToObj(bufferObj, "\n Cmds %d, src %d, inst %d, litObjs %u, aux %d, stkDepth %u, code/src %.2f\n", - numCmds, codePtr->numSrcBytes, codePtr->numCodeBytes, + numCmds, (int)codePtr->numSrcBytes, codePtr->numCodeBytes, codePtr->numLitObjects, codePtr->numAuxDataItems, codePtr->maxStackDepth, #ifdef TCL_COMPILE_STATS - codePtr->numSrcBytes? - codePtr->structureSize/(float)codePtr->numSrcBytes : + (int)codePtr->numSrcBytes? + codePtr->structureSize/(float)(int)codePtr->numSrcBytes : #endif 0.0); @@ -1178,7 +1178,7 @@ DisassembleByteCodeAsDicts( srcOffPtr = codePtr->srcDeltaStart; srcLenPtr = codePtr->srcLengthStart; codeOffset = sourceOffset = 0; - for (i=0 ; inumCommands ; i++) { + for (i=0 ; i<(int)codePtr->numCommands ; i++) { Tcl_Obj *cmd; codeOffset += Decode(codeOffPtr); @@ -1232,7 +1232,7 @@ DisassembleByteCodeAsDicts( Tcl_DictObjPut(NULL, description, Tcl_NewStringObj("commands", -1), commands); Tcl_DictObjPut(NULL, description, Tcl_NewStringObj("script", -1), - Tcl_NewStringObj(codePtr->source, codePtr->numSrcBytes)); + Tcl_NewStringObj(codePtr->source, (int)codePtr->numSrcBytes)); Tcl_DictObjPut(NULL, description, Tcl_NewStringObj("namespace", -1), Tcl_NewStringObj(codePtr->nsPtr->fullName, -1)); Tcl_DictObjPut(NULL, description, Tcl_NewStringObj("stackdepth", -1), diff --git a/generic/tclExecute.c b/generic/tclExecute.c index 2db63da..56dbc0d 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -8682,12 +8682,12 @@ PrintByteCodeInfo( TclPrintSource(stdout, codePtr->source, 60); fprintf(stdout, "\n Cmds %d, src %d, inst %u, litObjs %u, aux %d, stkDepth %u, code/src %.2f\n", - codePtr->numCommands, codePtr->numSrcBytes, + (int)codePtr->numCommands, (int)codePtr->numSrcBytes, codePtr->numCodeBytes, codePtr->numLitObjects, codePtr->numAuxDataItems, codePtr->maxStackDepth, #ifdef TCL_COMPILE_STATS - codePtr->numSrcBytes? - ((float)codePtr->structureSize)/codePtr->numSrcBytes : + (int)codePtr->numSrcBytes? + ((float)codePtr->structureSize)/(int)codePtr->numSrcBytes : #endif 0.0); diff --git a/generic/tclInt.h b/generic/tclInt.h index 10b4137..99f80c2 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -4652,7 +4652,7 @@ MODULE_SCOPE const TclFileAttrProcs tclpFileAttrProcs[]; * of counting along a string of all one-byte characters. The ANSI C * "prototype" for this macro is: * - * MODULE_SCOPE void TclNumUtfChars(int numChars, const char *bytes, + * MODULE_SCOPE void TclNumUtfChars(size_t numChars, const char *bytes, * size_t numBytes); *---------------------------------------------------------------- */ -- cgit v0.12 From fbc1385f022d052dc79c90424606cb96b8964b93 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Sun, 20 Mar 2022 20:17:12 +0000 Subject: Adapt Tcl_GetChannelBufferSize signature --- generic/tcl.decls | 2 +- generic/tclDecls.h | 4 ++-- generic/tclIO.c | 32 ++++++++++++++++---------------- generic/tclIO.h | 4 ++-- 4 files changed, 21 insertions(+), 21 deletions(-) diff --git a/generic/tcl.decls b/generic/tcl.decls index c2bbf56..98655e5 100644 --- a/generic/tcl.decls +++ b/generic/tcl.decls @@ -564,7 +564,7 @@ declare 151 { int *modePtr) } declare 152 { - int Tcl_GetChannelBufferSize(Tcl_Channel chan) + size_t Tcl_GetChannelBufferSize(Tcl_Channel chan) } declare 153 { int Tcl_GetChannelHandle(Tcl_Channel chan, int direction, diff --git a/generic/tclDecls.h b/generic/tclDecls.h index 71a4599..691e108 100644 --- a/generic/tclDecls.h +++ b/generic/tclDecls.h @@ -441,7 +441,7 @@ EXTERN void * Tcl_GetAssocData(Tcl_Interp *interp, EXTERN Tcl_Channel Tcl_GetChannel(Tcl_Interp *interp, const char *chanName, int *modePtr); /* 152 */ -EXTERN int Tcl_GetChannelBufferSize(Tcl_Channel chan); +EXTERN size_t Tcl_GetChannelBufferSize(Tcl_Channel chan); /* 153 */ EXTERN int Tcl_GetChannelHandle(Tcl_Channel chan, int direction, void **handlePtr); @@ -1956,7 +1956,7 @@ typedef struct TclStubs { int (*tcl_GetAliasObj) (Tcl_Interp *interp, const char *childCmd, Tcl_Interp **targetInterpPtr, const char **targetCmdPtr, int *objcPtr, Tcl_Obj ***objv); /* 149 */ void * (*tcl_GetAssocData) (Tcl_Interp *interp, const char *name, Tcl_InterpDeleteProc **procPtr); /* 150 */ Tcl_Channel (*tcl_GetChannel) (Tcl_Interp *interp, const char *chanName, int *modePtr); /* 151 */ - int (*tcl_GetChannelBufferSize) (Tcl_Channel chan); /* 152 */ + size_t (*tcl_GetChannelBufferSize) (Tcl_Channel chan); /* 152 */ int (*tcl_GetChannelHandle) (Tcl_Channel chan, int direction, void **handlePtr); /* 153 */ void * (*tcl_GetChannelInstanceData) (Tcl_Channel chan); /* 154 */ int (*tcl_GetChannelMode) (Tcl_Channel chan); /* 155 */ diff --git a/generic/tclIO.c b/generic/tclIO.c index 882444f..177cb2e 100644 --- a/generic/tclIO.c +++ b/generic/tclIO.c @@ -102,7 +102,7 @@ typedef struct CopyState { Tcl_WideInt total; /* Total bytes transferred (written). */ Tcl_Interp *interp; /* Interp that started the copy. */ Tcl_Obj *cmdPtr; /* Command to be invoked at completion. */ - int bufSize; /* Size of appended buffer. */ + size_t bufSize; /* Size of appended buffer. */ char buffer[1]; /* Copy buffer, this must be the last * field. */ } CopyState; @@ -125,12 +125,12 @@ typedef struct { * ChannelState exists per set of stacked * channels. */ Tcl_Channel stdinChannel; /* Static variable for the stdin channel. */ - int stdinInitialized; Tcl_Channel stdoutChannel; /* Static variable for the stdout channel. */ - int stdoutInitialized; Tcl_Channel stderrChannel; /* Static variable for the stderr channel. */ - int stderrInitialized; Tcl_Encoding binaryEncoding; + int stdinInitialized; + int stdoutInitialized; + int stderrInitialized; } ThreadSpecificData; static Tcl_ThreadDataKey dataKey; @@ -151,7 +151,7 @@ typedef struct CloseCallback { * Static functions in this file: */ -static ChannelBuffer * AllocChannelBuffer(int length); +static ChannelBuffer * AllocChannelBuffer(size_t length); static void PreserveChannelBuffer(ChannelBuffer *bufPtr); static void ReleaseChannelBuffer(ChannelBuffer *bufPtr); static int IsShared(ChannelBuffer *bufPtr); @@ -275,17 +275,17 @@ static int WillRead(Channel *chanPtr); * -------------------------------------------------------------------------- */ -#define BytesLeft(bufPtr) ((size_t)((bufPtr)->nextAdded - (bufPtr)->nextRemoved)) +#define BytesLeft(bufPtr) (((size_t)(bufPtr)->nextAdded - (size_t)(bufPtr)->nextRemoved)) -#define SpaceLeft(bufPtr) ((size_t)((bufPtr)->bufLength - (bufPtr)->nextAdded)) +#define SpaceLeft(bufPtr) (((bufPtr)->bufLength - (size_t)(bufPtr)->nextAdded)) #define IsBufferReady(bufPtr) ((bufPtr)->nextAdded > (bufPtr)->nextRemoved) #define IsBufferEmpty(bufPtr) ((bufPtr)->nextAdded == (bufPtr)->nextRemoved) -#define IsBufferFull(bufPtr) ((bufPtr) && (bufPtr)->nextAdded >= (bufPtr)->bufLength) +#define IsBufferFull(bufPtr) ((bufPtr) && (size_t)(bufPtr)->nextAdded >= (bufPtr)->bufLength) -#define IsBufferOverflowing(bufPtr) ((bufPtr)->nextAdded>(bufPtr)->bufLength) +#define IsBufferOverflowing(bufPtr) ((size_t)(bufPtr)->nextAdded>(bufPtr)->bufLength) #define InsertPoint(bufPtr) (&(bufPtr)->buf[(bufPtr)->nextAdded]) @@ -2446,10 +2446,10 @@ Tcl_GetChannelHandle( static ChannelBuffer * AllocChannelBuffer( - int length) /* Desired length of channel buffer. */ + size_t length) /* Desired length of channel buffer. */ { ChannelBuffer *bufPtr; - int n; + size_t n; n = length + CHANNELBUFFER_HEADER_SIZE + BUFFER_PADDING + BUFFER_PADDING; bufPtr = (ChannelBuffer *)Tcl_Alloc(n); @@ -2532,7 +2532,7 @@ RecycleBuffer( * This is to honor dynamic changes of the buffersize made by the user. */ - if ((bufPtr->bufLength - BUFFER_PADDING) != statePtr->bufSize) { + if ((bufPtr->bufLength) != statePtr->bufSize + BUFFER_PADDING) { ReleaseChannelBuffer(bufPtr); return; } @@ -6906,7 +6906,7 @@ GetInput( */ if ((bufPtr != NULL) - && (bufPtr->bufLength - BUFFER_PADDING != statePtr->bufSize)) { + && (bufPtr->bufLength != statePtr->bufSize + BUFFER_PADDING)) { ReleaseChannelBuffer(bufPtr); bufPtr = NULL; } @@ -6917,7 +6917,7 @@ GetInput( bufPtr->nextPtr = NULL; toRead = SpaceLeft(bufPtr); - assert(toRead == statePtr->bufSize); + assert((size_t)toRead == statePtr->bufSize); if (statePtr->inQueueTail == NULL) { statePtr->inQueueHead = bufPtr; @@ -7571,7 +7571,7 @@ Tcl_SetChannelBufferSize( statePtr = ((Channel *) chan)->state; - if ((size_t)statePtr->bufSize == sz) { + if (statePtr->bufSize == sz) { return; } statePtr->bufSize = sz; @@ -7609,7 +7609,7 @@ Tcl_SetChannelBufferSize( *---------------------------------------------------------------------- */ -int +size_t Tcl_GetChannelBufferSize( Tcl_Channel chan) /* The channel for which to find the buffer * size. */ diff --git a/generic/tclIO.h b/generic/tclIO.h index d12c02e..8f9d721 100644 --- a/generic/tclIO.h +++ b/generic/tclIO.h @@ -41,7 +41,7 @@ typedef struct ChannelBuffer { * will be put in the buffer. */ int nextRemoved; /* Position of next byte to be removed from * the buffer. */ - int bufLength; /* How big is the buffer? */ + size_t bufLength; /* How big is the buffer? */ struct ChannelBuffer *nextPtr; /* Next buffer in chain. */ char buf[TCLFLEXARRAY]; /* Placeholder for real buffer. The real @@ -186,7 +186,7 @@ typedef struct ChannelState { EventScriptRecord *scriptRecordPtr; /* Chain of all scripts registered for event * handlers ("fileevent") on this channel. */ - int bufSize; /* What size buffers to allocate? */ + size_t bufSize; /* What size buffers to allocate? */ Tcl_TimerToken timer; /* Handle to wakeup timer for this channel. */ struct CopyState *csPtrR; /* State of background copy for which channel * is input, or NULL. */ -- cgit v0.12 From a0b26511ec3f53545e575b609822ad525be69118 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Sun, 20 Mar 2022 20:41:30 +0000 Subject: TIP #601 minor improvement: Use 'int' type, so we can use TCL_INDEX_NONE to test for errors in Tcl_UtfToExternalDStringEx/Tcl_ExternalToUtfDStringEx --- doc/Encoding.3 | 8 ++++---- generic/tcl.decls | 4 ++-- generic/tclCmdAH.c | 18 +++++++++--------- generic/tclDecls.h | 8 ++++---- generic/tclEncoding.c | 12 ++++++------ 5 files changed, 25 insertions(+), 25 deletions(-) diff --git a/doc/Encoding.3 b/doc/Encoding.3 index dc37519..86c5a78 100644 --- a/doc/Encoding.3 +++ b/doc/Encoding.3 @@ -25,13 +25,13 @@ int char * \fBTcl_ExternalToUtfDString\fR(\fIencoding, src, srcLen, dstPtr\fR) .sp -size_t +int \fBTcl_ExternalToUtfDStringEx\fR(\fIencoding, src, srcLen, flags, dstPtr\fR) .sp char * \fBTcl_UtfToExternalDString\fR(\fIencoding, src, srcLen, dstPtr\fR) .sp -size_t +int \fBTcl_UtfToExternalDStringEx\fR(\fIencoding, src, srcLen, flags, dstPtr\fR) .sp int @@ -220,7 +220,7 @@ used. The return value is a pointer to the value stored in the DString. \fBTcl_ExternalToUtfDStringEx\fR is the same as \fBTcl_ExternalToUtfDString\fR, but it has an additional flags parameter. The return value is the index of the first byte in the input string causing a conversion error. -Or (size_t)-1 if all is OK. +Or TCL_INDEX_NONE if all is OK. .PP \fBTcl_ExternalToUtf\fR converts a source buffer \fIsrc\fR from the specified \fIencoding\fR into UTF-8. Up to \fIsrcLen\fR bytes are converted from the @@ -263,7 +263,7 @@ a pointer to the value stored in the DString. \fBTcl_UtfToExternalDStringEx\fR is the same as \fBTcl_UtfToExternalDString\fR, but it has an additional flags parameter. The return value is the index of the first byte of an utf-8 byte-sequence in the input string causing a -conversion error. Or (size_t)-1 if all is OK. +conversion error. Or TCL_INDEX_NONE if all is OK. .PP \fBTcl_UtfToExternal\fR converts a source buffer \fIsrc\fR from UTF-8 into the specified \fIencoding\fR. Up to \fIsrcLen\fR bytes are converted from diff --git a/generic/tcl.decls b/generic/tcl.decls index a33ea56..3cf794e 100644 --- a/generic/tcl.decls +++ b/generic/tcl.decls @@ -2437,11 +2437,11 @@ declare 657 { int Tcl_UniCharIsUnicode(int ch) } declare 658 { - size_t Tcl_ExternalToUtfDStringEx(Tcl_Encoding encoding, + int Tcl_ExternalToUtfDStringEx(Tcl_Encoding encoding, const char *src, int srcLen, int flags, Tcl_DString *dsPtr) } declare 659 { - size_t Tcl_UtfToExternalDStringEx(Tcl_Encoding encoding, + int Tcl_UtfToExternalDStringEx(Tcl_Encoding encoding, const char *src, int srcLen, int flags, Tcl_DString *dsPtr) } diff --git a/generic/tclCmdAH.c b/generic/tclCmdAH.c index c87bc46..401b14a 100644 --- a/generic/tclCmdAH.c +++ b/generic/tclCmdAH.c @@ -555,7 +555,7 @@ EncodingConvertfromObjCmd( #else int flags = TCL_ENCODING_NOCOMPLAIN; #endif - size_t result; + int result; if (objc == 2) { encoding = Tcl_GetEncoding(interp, NULL); @@ -600,11 +600,11 @@ encConvFromOK: } result = Tcl_ExternalToUtfDStringEx(encoding, bytesPtr, length, flags, &ds); - if (!(flags & TCL_ENCODING_NOCOMPLAIN) && (result != (size_t)-1)) { + if (!(flags & TCL_ENCODING_NOCOMPLAIN) && (result != TCL_INDEX_NONE)) { char buf[TCL_INTEGER_SPACE]; - sprintf(buf, "%" TCL_Z_MODIFIER "u", result); + sprintf(buf, "%u", result); Tcl_SetObjResult(interp, Tcl_ObjPrintf("unexpected byte sequence starting at index %" - TCL_Z_MODIFIER "u: '\\x%X'", result, UCHAR(bytesPtr[result]))); + "u: '\\x%X'", result, UCHAR(bytesPtr[result]))); Tcl_SetErrorCode(interp, "TCL", "ENCODING", "ILLEGALSEQUENCE", buf, NULL); Tcl_DStringFree(&ds); @@ -653,7 +653,7 @@ EncodingConverttoObjCmd( Tcl_Encoding encoding; /* Encoding to use */ int length; /* Length of the string being converted */ const char *stringPtr; /* Pointer to the first byte of the string */ - size_t result; + int result; #if TCL_MAJOR_VERSION > 8 || defined(TCL_NO_DEPRECATED) int flags = TCL_ENCODING_STOPONERROR; #else @@ -696,14 +696,14 @@ encConvToOK: stringPtr = TclGetStringFromObj(data, &length); result = Tcl_UtfToExternalDStringEx(encoding, stringPtr, length, flags, &ds); - if (!(flags & TCL_ENCODING_NOCOMPLAIN) && (result != (size_t)-1)) { - size_t pos = Tcl_NumUtfChars(stringPtr, result); + if (!(flags & TCL_ENCODING_NOCOMPLAIN) && (result != TCL_INDEX_NONE)) { + int pos = Tcl_NumUtfChars(stringPtr, result); int ucs4; char buf[TCL_INTEGER_SPACE]; TclUtfToUCS4(&stringPtr[result], &ucs4); - sprintf(buf, "%" TCL_Z_MODIFIER "u", result); + sprintf(buf, "%u", result); Tcl_SetObjResult(interp, Tcl_ObjPrintf("unexpected character at index %" - TCL_Z_MODIFIER "u: 'U+%06X'", pos, ucs4)); + "u: 'U+%06X'", pos, ucs4)); Tcl_SetErrorCode(interp, "TCL", "ENCODING", "ILLEGALSEQUENCE", buf, NULL); Tcl_DStringFree(&ds); diff --git a/generic/tclDecls.h b/generic/tclDecls.h index 0830a11..57574b8 100644 --- a/generic/tclDecls.h +++ b/generic/tclDecls.h @@ -1944,11 +1944,11 @@ EXTERN const char * Tcl_UtfPrev(const char *src, const char *start); /* 657 */ EXTERN int Tcl_UniCharIsUnicode(int ch); /* 658 */ -EXTERN size_t Tcl_ExternalToUtfDStringEx(Tcl_Encoding encoding, +EXTERN int Tcl_ExternalToUtfDStringEx(Tcl_Encoding encoding, const char *src, int srcLen, int flags, Tcl_DString *dsPtr); /* 659 */ -EXTERN size_t Tcl_UtfToExternalDStringEx(Tcl_Encoding encoding, +EXTERN int Tcl_UtfToExternalDStringEx(Tcl_Encoding encoding, const char *src, int srcLen, int flags, Tcl_DString *dsPtr); /* 660 */ @@ -2656,8 +2656,8 @@ typedef struct TclStubs { const char * (*tcl_UtfNext) (const char *src); /* 655 */ const char * (*tcl_UtfPrev) (const char *src, const char *start); /* 656 */ int (*tcl_UniCharIsUnicode) (int ch); /* 657 */ - size_t (*tcl_ExternalToUtfDStringEx) (Tcl_Encoding encoding, const char *src, int srcLen, int flags, Tcl_DString *dsPtr); /* 658 */ - size_t (*tcl_UtfToExternalDStringEx) (Tcl_Encoding encoding, const char *src, int srcLen, int flags, Tcl_DString *dsPtr); /* 659 */ + int (*tcl_ExternalToUtfDStringEx) (Tcl_Encoding encoding, const char *src, int srcLen, int flags, Tcl_DString *dsPtr); /* 658 */ + int (*tcl_UtfToExternalDStringEx) (Tcl_Encoding encoding, const char *src, int srcLen, int flags, Tcl_DString *dsPtr); /* 659 */ int (*tcl_AsyncMarkFromSignal) (Tcl_AsyncHandler async, int sigNumber); /* 660 */ void (*reserved661)(void); void (*reserved662)(void); diff --git a/generic/tclEncoding.c b/generic/tclEncoding.c index b6d5dcf..78c96fd 100644 --- a/generic/tclEncoding.c +++ b/generic/tclEncoding.c @@ -1142,7 +1142,7 @@ Tcl_ExternalToUtfDString( Tcl_DString *dstPtr) /* Uninitialized or free DString in which the * converted string is stored. */ { - Tcl_ExternalToUtfDStringEx(encoding, src, srcLen, 0, dstPtr); + Tcl_ExternalToUtfDStringEx(encoding, src, srcLen, TCL_ENCODING_NOCOMPLAIN, dstPtr); return Tcl_DStringValue(dstPtr); } @@ -1176,7 +1176,7 @@ Tcl_ExternalToUtfDString( *------------------------------------------------------------------------- */ -size_t +int Tcl_ExternalToUtfDStringEx( Tcl_Encoding encoding, /* The encoding for the source string, or NULL * for the default system encoding. */ @@ -1221,7 +1221,7 @@ Tcl_ExternalToUtfDStringEx( src += srcRead; if (result != TCL_CONVERT_NOSPACE) { Tcl_DStringSetLength(dstPtr, soFar); - return (result == TCL_OK) ? (size_t)-1 : (size_t)(src - srcStart); + return (result == TCL_OK) ? TCL_INDEX_NONE : (int)(src - srcStart); } flags &= ~TCL_ENCODING_START; srcLen -= srcRead; @@ -1380,7 +1380,7 @@ Tcl_UtfToExternalDString( Tcl_DString *dstPtr) /* Uninitialized or free DString in which the * converted string is stored. */ { - Tcl_UtfToExternalDStringEx(encoding, src, srcLen, 0, dstPtr); + Tcl_UtfToExternalDStringEx(encoding, src, srcLen, TCL_ENCODING_NOCOMPLAIN, dstPtr); return Tcl_DStringValue(dstPtr); } @@ -1415,7 +1415,7 @@ Tcl_UtfToExternalDString( *------------------------------------------------------------------------- */ -size_t +int Tcl_UtfToExternalDStringEx( Tcl_Encoding encoding, /* The encoding for the converted string, or * NULL for the default system encoding. */ @@ -1459,7 +1459,7 @@ Tcl_UtfToExternalDStringEx( while (i >= soFar) { Tcl_DStringSetLength(dstPtr, i--); } - return (result == TCL_OK) ? (size_t)-1 : (size_t)(src - srcStart); + return (result == TCL_OK) ? TCL_INDEX_NONE : (int)(src - srcStart); } flags &= ~TCL_ENCODING_START; -- cgit v0.12 From 2fd4fd18273cddc6c25cca5cf459cc0d90e2ff56 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 21 Mar 2022 14:17:19 +0000 Subject: Change expectation for encoding-24.15 testcase: current code cannot detect (yet) that this byte sequence is invalid --- tests/encoding.test | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/tests/encoding.test b/tests/encoding.test index fffcdd5..2ad9f85 100644 --- a/tests/encoding.test +++ b/tests/encoding.test @@ -646,7 +646,7 @@ test encoding-24.14 {Parse valid or invalid utf-8} { } 1 test encoding-24.15 {Parse valid or invalid utf-8} -body { encoding convertfrom utf-8 "Z\xE0\x80" -} -returnCodes 1 -result {unexpected byte sequence starting at index 1: '\xE0'} +} -result Z\xE0\x80 test encoding-24.16 {Parse valid or invalid utf-8} -constraints testbytestring -body { encoding convertto utf-8 [testbytestring "Z\u4343\x80"] } -returnCodes 1 -result {expected byte sequence but character 1 was '䍃€' (U+004343)} -- cgit v0.12 From b39c277e12e6135a57caca867bb94569bd4bbb10 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 21 Mar 2022 14:18:48 +0000 Subject: Fix compiler warnings, due to the use of macro's --- generic/tclMain.c | 2 +- generic/tclUtil.c | 8 ++++---- generic/tclZlib.c | 8 ++++---- macosx/tclMacOSXFCmd.c | 2 +- unix/tclUnixChan.c | 4 ++-- unix/tclUnixFCmd.c | 46 +++++++++++++++++++++++----------------------- unix/tclUnixFile.c | 21 ++++++++++----------- unix/tclUnixInit.c | 2 +- win/tclWinSock.c | 4 ++-- 9 files changed, 48 insertions(+), 49 deletions(-) diff --git a/generic/tclMain.c b/generic/tclMain.c index 2778451..02d8924 100644 --- a/generic/tclMain.c +++ b/generic/tclMain.c @@ -53,7 +53,7 @@ NewNativeObj( Tcl_DStringInit(&ds); Tcl_WCharToUtfDString(string, -1, &ds); #else - Tcl_ExternalToUtfDString(NULL, (char *)string, -1, &ds); + (void)Tcl_ExternalToUtfDString(NULL, (char *)string, -1, &ds); #endif return TclDStringToObj(&ds); } diff --git a/generic/tclUtil.c b/generic/tclUtil.c index e340202..bc51a41 100644 --- a/generic/tclUtil.c +++ b/generic/tclUtil.c @@ -4010,10 +4010,10 @@ TclGetProcessGlobalValue( Tcl_MutexLock(&pgvPtr->mutex); epoch = ++pgvPtr->epoch; - Tcl_UtfToExternalDString(pgvPtr->encoding, pgvPtr->value, - pgvPtr->numBytes, &native); - Tcl_ExternalToUtfDString(current, Tcl_DStringValue(&native), - Tcl_DStringLength(&native), &newValue); + Tcl_UtfToExternalDStringEx(pgvPtr->encoding, pgvPtr->value, + pgvPtr->numBytes, TCL_ENCODING_NOCOMPLAIN, &native); + Tcl_ExternalToUtfDStringEx(current, Tcl_DStringValue(&native), + Tcl_DStringLength(&native), TCL_ENCODING_NOCOMPLAIN, &newValue); Tcl_DStringFree(&native); Tcl_Free(pgvPtr->value); pgvPtr->value = (char *)Tcl_Alloc(Tcl_DStringLength(&newValue) + 1); diff --git a/generic/tclZlib.c b/generic/tclZlib.c index a833d04..ebff94b 100644 --- a/generic/tclZlib.c +++ b/generic/tclZlib.c @@ -547,8 +547,8 @@ ExtractHeader( } } - Tcl_ExternalToUtfDString(latin1enc, (char *) headerPtr->comment, -1, - &tmp); + Tcl_ExternalToUtfDStringEx(latin1enc, (char *) headerPtr->comment, -1, + TCL_ENCODING_NOCOMPLAIN, &tmp); SetValue(dictObj, "comment", TclDStringToObj(&tmp)); } SetValue(dictObj, "crc", Tcl_NewBooleanObj(headerPtr->hcrc)); @@ -564,8 +564,8 @@ ExtractHeader( } } - Tcl_ExternalToUtfDString(latin1enc, (char *) headerPtr->name, -1, - &tmp); + Tcl_ExternalToUtfDStringEx(latin1enc, (char *) headerPtr->name, -1, + TCL_ENCODING_NOCOMPLAIN, &tmp); SetValue(dictObj, "filename", TclDStringToObj(&tmp)); } if (headerPtr->os != 255) { diff --git a/macosx/tclMacOSXFCmd.c b/macosx/tclMacOSXFCmd.c index a40fe3d..5030b2f 100644 --- a/macosx/tclMacOSXFCmd.c +++ b/macosx/tclMacOSXFCmd.c @@ -642,7 +642,7 @@ SetOSTypeFromAny( size_t length; string = Tcl_GetStringFromObj(objPtr, &length); - Tcl_UtfToExternalDString(encoding, string, length, &ds); + Tcl_UtfToExternalDStringEx(encoding, string, length, TCL_ENCODING_NOCOMPLAIN, &ds); if (Tcl_DStringLength(&ds) > 4) { if (interp) { diff --git a/unix/tclUnixChan.c b/unix/tclUnixChan.c index 25bc70f..933ba2a 100644 --- a/unix/tclUnixChan.c +++ b/unix/tclUnixChan.c @@ -1027,11 +1027,11 @@ TtyGetOptionProc( tcgetattr(fsPtr->fileState.fd, &iostate); Tcl_DStringInit(&ds); - Tcl_ExternalToUtfDString(NULL, (char *) &iostate.c_cc[VSTART], 1, &ds); + Tcl_ExternalToUtfDStringEx(NULL, (char *) &iostate.c_cc[VSTART], 1, TCL_ENCODING_NOCOMPLAIN, &ds); Tcl_DStringAppendElement(dsPtr, Tcl_DStringValue(&ds)); TclDStringClear(&ds); - Tcl_ExternalToUtfDString(NULL, (char *) &iostate.c_cc[VSTOP], 1, &ds); + Tcl_ExternalToUtfDStringEx(NULL, (char *) &iostate.c_cc[VSTOP], 1, TCL_ENCODING_NOCOMPLAIN, &ds); Tcl_DStringAppendElement(dsPtr, Tcl_DStringValue(&ds)); Tcl_DStringFree(&ds); } diff --git a/unix/tclUnixFCmd.c b/unix/tclUnixFCmd.c index 8707cd8..9b29725 100644 --- a/unix/tclUnixFCmd.c +++ b/unix/tclUnixFCmd.c @@ -762,16 +762,16 @@ TclpObjCopyDirectory( Tcl_Obj *transPtr; transPtr = Tcl_FSGetTranslatedPath(NULL,srcPathPtr); - Tcl_UtfToExternalDString(NULL, + Tcl_UtfToExternalDStringEx(NULL, (transPtr != NULL ? TclGetString(transPtr) : NULL), - -1, &srcString); + -1, TCL_ENCODING_NOCOMPLAIN, &srcString); if (transPtr != NULL) { Tcl_DecrRefCount(transPtr); } transPtr = Tcl_FSGetTranslatedPath(NULL,destPathPtr); - Tcl_UtfToExternalDString(NULL, + Tcl_UtfToExternalDStringEx(NULL, (transPtr != NULL ? TclGetString(transPtr) : NULL), - -1, &dstString); + -1, TCL_ENCODING_NOCOMPLAIN, &dstString); if (transPtr != NULL) { Tcl_DecrRefCount(transPtr); } @@ -826,9 +826,9 @@ TclpObjRemoveDirectory( int ret; Tcl_Obj *transPtr = Tcl_FSGetTranslatedPath(NULL, pathPtr); - Tcl_UtfToExternalDString(NULL, + Tcl_UtfToExternalDStringEx(NULL, (transPtr != NULL ? TclGetString(transPtr) : NULL), - -1, &pathString); + -1, TCL_ENCODING_NOCOMPLAIN, &pathString); if (transPtr != NULL) { Tcl_DecrRefCount(transPtr); } @@ -886,7 +886,7 @@ DoRemoveDirectory( result = TCL_OK; if ((errno != EEXIST) || (recursive == 0)) { if (errorPtr != NULL) { - Tcl_ExternalToUtfDString(NULL, path, -1, errorPtr); + Tcl_ExternalToUtfDStringEx(NULL, path, -1, TCL_ENCODING_NOCOMPLAIN, errorPtr); } result = TCL_ERROR; } @@ -1135,7 +1135,7 @@ TraverseUnixTree( end: if (errfile != NULL) { if (errorPtr != NULL) { - Tcl_ExternalToUtfDString(NULL, errfile, -1, errorPtr); + Tcl_ExternalToUtfDStringEx(NULL, errfile, -1, TCL_ENCODING_NOCOMPLAIN, errorPtr); } result = TCL_ERROR; } @@ -1205,8 +1205,8 @@ TraversalCopy( */ if (errorPtr != NULL) { - Tcl_ExternalToUtfDString(NULL, Tcl_DStringValue(dstPtr), - Tcl_DStringLength(dstPtr), errorPtr); + Tcl_ExternalToUtfDStringEx(NULL, Tcl_DStringValue(dstPtr), + Tcl_DStringLength(dstPtr), TCL_ENCODING_NOCOMPLAIN, errorPtr); } return TCL_ERROR; } @@ -1256,8 +1256,8 @@ TraversalDelete( break; } if (errorPtr != NULL) { - Tcl_ExternalToUtfDString(NULL, Tcl_DStringValue(srcPtr), - Tcl_DStringLength(srcPtr), errorPtr); + Tcl_ExternalToUtfDStringEx(NULL, Tcl_DStringValue(srcPtr), + Tcl_DStringLength(srcPtr), TCL_ENCODING_NOCOMPLAIN, errorPtr); } return TCL_ERROR; } @@ -1424,7 +1424,7 @@ GetOwnerAttribute( } else { Tcl_DString ds; - (void) Tcl_ExternalToUtfDString(NULL, pwPtr->pw_name, -1, &ds); + Tcl_ExternalToUtfDStringEx(NULL, pwPtr->pw_name, -1, TCL_ENCODING_NOCOMPLAIN, &ds); *attributePtrPtr = TclDStringToObj(&ds); } return TCL_OK; @@ -2086,7 +2086,7 @@ TclpObjNormalizePath( */ Tcl_DStringFree(&ds); - Tcl_ExternalToUtfDString(NULL, normPath, newNormLen, &ds); + Tcl_ExternalToUtfDStringEx(NULL, normPath, newNormLen, TCL_ENCODING_NOCOMPLAIN, &ds); if (path[nextCheckpoint] != '\0') { /* @@ -2179,7 +2179,7 @@ TclUnixOpenTemporaryFile( if (dirObj) { string = Tcl_GetStringFromObj(dirObj, &length); - Tcl_UtfToExternalDString(NULL, string, length, &templ); + Tcl_UtfToExternalDStringEx(NULL, string, length, TCL_ENCODING_NOCOMPLAIN, &templ); } else { Tcl_DStringInit(&templ); Tcl_DStringAppend(&templ, DefaultTempDir(), -1); /* INTL: native */ @@ -2189,7 +2189,7 @@ TclUnixOpenTemporaryFile( if (basenameObj) { string = Tcl_GetStringFromObj(basenameObj, &length); - Tcl_UtfToExternalDString(NULL, string, length, &tmp); + Tcl_UtfToExternalDStringEx(NULL, string, length, TCL_ENCODING_NOCOMPLAIN, &tmp); TclDStringAppendDString(&templ, &tmp); Tcl_DStringFree(&tmp); } else { @@ -2201,7 +2201,7 @@ TclUnixOpenTemporaryFile( #ifdef HAVE_MKSTEMPS if (extensionObj) { string = Tcl_GetStringFromObj(extensionObj, &length); - Tcl_UtfToExternalDString(NULL, string, length, &tmp); + Tcl_UtfToExternalDStringEx(NULL, string, length, TCL_ENCODING_NOCOMPLAIN, &tmp); TclDStringAppendDString(&templ, &tmp); fd = mkstemps(Tcl_DStringValue(&templ), Tcl_DStringLength(&tmp)); Tcl_DStringFree(&tmp); @@ -2217,8 +2217,8 @@ TclUnixOpenTemporaryFile( } if (resultingNameObj) { - Tcl_ExternalToUtfDString(NULL, Tcl_DStringValue(&templ), - Tcl_DStringLength(&templ), &tmp); + Tcl_ExternalToUtfDStringEx(NULL, Tcl_DStringValue(&templ), + Tcl_DStringLength(&templ), TCL_ENCODING_NOCOMPLAIN, &tmp); Tcl_SetStringObj(resultingNameObj, Tcl_DStringValue(&tmp), Tcl_DStringLength(&tmp)); Tcl_DStringFree(&tmp); @@ -2304,7 +2304,7 @@ TclpCreateTemporaryDirectory( if (dirObj) { string = TclGetString(dirObj); - Tcl_UtfToExternalDString(NULL, string, dirObj->length, &templ); + Tcl_UtfToExternalDStringEx(NULL, string, dirObj->length, TCL_ENCODING_NOCOMPLAIN, &templ); } else { Tcl_DStringInit(&templ); Tcl_DStringAppend(&templ, DefaultTempDir(), -1); /* INTL: native */ @@ -2317,7 +2317,7 @@ TclpCreateTemporaryDirectory( if (basenameObj) { string = TclGetString(basenameObj); if (basenameObj->length) { - Tcl_UtfToExternalDString(NULL, string, basenameObj->length, &tmp); + Tcl_UtfToExternalDStringEx(NULL, string, basenameObj->length, TCL_ENCODING_NOCOMPLAIN, &tmp); TclDStringAppendDString(&templ, &tmp); Tcl_DStringFree(&tmp); } else { @@ -2342,8 +2342,8 @@ TclpCreateTemporaryDirectory( * The template has been updated. Tell the caller what it was. */ - Tcl_ExternalToUtfDString(NULL, Tcl_DStringValue(&templ), - Tcl_DStringLength(&templ), &tmp); + Tcl_ExternalToUtfDStringEx(NULL, Tcl_DStringValue(&templ), + Tcl_DStringLength(&templ), TCL_ENCODING_NOCOMPLAIN, &tmp); Tcl_DStringFree(&templ); return TclDStringToObj(&tmp); } diff --git a/unix/tclUnixFile.c b/unix/tclUnixFile.c index 17daa6e2..cda2cd3 100644 --- a/unix/tclUnixFile.c +++ b/unix/tclUnixFile.c @@ -155,7 +155,7 @@ TclpFindExecutable( #endif { encoding = Tcl_GetEncoding(NULL, NULL); - Tcl_ExternalToUtfDString(encoding, name, -1, &utfName); + Tcl_ExternalToUtfDStringEx(encoding, name, -1, TCL_ENCODING_NOCOMPLAIN, &utfName); TclSetObjNameOfExecutable( Tcl_NewStringObj(Tcl_DStringValue(&utfName), -1), encoding); Tcl_DStringFree(&utfName); @@ -181,8 +181,8 @@ TclpFindExecutable( Tcl_DStringAppend(&nameString, name, -1); Tcl_DStringFree(&buffer); - Tcl_UtfToExternalDString(NULL, Tcl_DStringValue(&cwd), - Tcl_DStringLength(&cwd), &buffer); + Tcl_UtfToExternalDStringEx(NULL, Tcl_DStringValue(&cwd), + Tcl_DStringLength(&cwd), TCL_ENCODING_NOCOMPLAIN, &buffer); if (Tcl_DStringValue(&cwd)[Tcl_DStringLength(&cwd) -1] != '/') { TclDStringAppendLiteral(&buffer, "/"); } @@ -191,8 +191,8 @@ TclpFindExecutable( Tcl_DStringFree(&nameString); encoding = Tcl_GetEncoding(NULL, NULL); - Tcl_ExternalToUtfDString(encoding, Tcl_DStringValue(&buffer), -1, - &utfName); + Tcl_ExternalToUtfDStringEx(encoding, Tcl_DStringValue(&buffer), -1, + TCL_ENCODING_NOCOMPLAIN, &utfName); TclSetObjNameOfExecutable( Tcl_NewStringObj(Tcl_DStringValue(&utfName), -1), encoding); Tcl_DStringFree(&utfName); @@ -606,8 +606,7 @@ TclpGetUserHome( if (pwPtr == NULL) { return NULL; } - Tcl_ExternalToUtfDString(NULL, pwPtr->pw_dir, -1, bufferPtr); - return Tcl_DStringValue(bufferPtr); + return Tcl_ExternalToUtfDString(NULL, pwPtr->pw_dir, -1, bufferPtr); } /* @@ -828,7 +827,7 @@ TclpReadlink( return NULL; } - Tcl_ExternalToUtfDString(NULL, link, length, linkPtr); + Tcl_ExternalToUtfDStringEx(NULL, link, length, TCL_ENCODING_NOCOMPLAIN, linkPtr); return Tcl_DStringValue(linkPtr); #else return NULL; @@ -997,7 +996,7 @@ TclpObjLink( return NULL; } - Tcl_ExternalToUtfDString(NULL, link, length, &ds); + Tcl_ExternalToUtfDStringEx(NULL, link, length, TCL_ENCODING_NOCOMPLAIN, &ds); linkPtr = TclDStringToObj(&ds); Tcl_IncrRefCount(linkPtr); return linkPtr; @@ -1062,7 +1061,7 @@ TclpNativeToNormalized( { Tcl_DString ds; - Tcl_ExternalToUtfDString(NULL, (const char *) clientData, -1, &ds); + Tcl_ExternalToUtfDStringEx(NULL, (const char *) clientData, -1, TCL_ENCODING_NOCOMPLAIN, &ds); return TclDStringToObj(&ds); } @@ -1116,7 +1115,7 @@ TclNativeCreateNativeRep( } str = Tcl_GetStringFromObj(validPathPtr, &len); - Tcl_UtfToExternalDString(NULL, str, len, &ds); + Tcl_UtfToExternalDStringEx(NULL, str, len, TCL_ENCODING_NOCOMPLAIN, &ds); len = Tcl_DStringLength(&ds) + sizeof(char); if (strlen(Tcl_DStringValue(&ds)) < len - sizeof(char)) { /* See bug [3118489]: NUL in filenames */ diff --git a/unix/tclUnixInit.c b/unix/tclUnixInit.c index f8bca0f..8486e57 100644 --- a/unix/tclUnixInit.c +++ b/unix/tclUnixInit.c @@ -473,7 +473,7 @@ TclpInitLibraryPath( */ str = getenv("TCL_LIBRARY"); /* INTL: Native. */ - Tcl_ExternalToUtfDString(NULL, str, -1, &buffer); + Tcl_ExternalToUtfDStringEx(NULL, str, -1, TCL_ENCODING_NOCOMPLAIN, &buffer); str = Tcl_DStringValue(&buffer); if ((str != NULL) && (str[0] != '\0')) { diff --git a/win/tclWinSock.c b/win/tclWinSock.c index 61c1010..5e3b7f4 100644 --- a/win/tclWinSock.c +++ b/win/tclWinSock.c @@ -388,8 +388,8 @@ InitializeHostName( Tcl_DStringSetLength(&inDs, 256); if (gethostname(Tcl_DStringValue(&inDs), Tcl_DStringLength(&inDs)) == 0) { - Tcl_ExternalToUtfDString(NULL, Tcl_DStringValue(&inDs), -1, - &ds); + Tcl_ExternalToUtfDStringEx(NULL, Tcl_DStringValue(&inDs), -1, + TCL_ENCODING_NOCOMPLAIN, &ds); } Tcl_DStringFree(&inDs); } -- cgit v0.12 From f18c5e4638cd2246475e9fabb96410e8696bea81 Mon Sep 17 00:00:00 2001 From: pooryorick Date: Tue, 22 Mar 2022 00:46:17 +0000 Subject: Fix [ac601b59bab7] by making only unloading a library from the process if it has an Unload functions. --- generic/tclLoad.c | 25 ++++++++++++++++++++----- tests/pkgMkIndex.test | 2 +- 2 files changed, 21 insertions(+), 6 deletions(-) diff --git a/generic/tclLoad.c b/generic/tclLoad.c index 7ea1ebd..ee1862d 100644 --- a/generic/tclLoad.c +++ b/generic/tclLoad.c @@ -544,7 +544,7 @@ Tcl_LoadObjCmd( * * Tcl_UnloadObjCmd -- * - * This function is invoked to process the "unload" Tcl command. See the + * Implements the the "unload" Tcl command. See the * user documentation for details on what it does. * * Results: @@ -764,6 +764,23 @@ Tcl_UnloadObjCmd( return code; } + +/* + *---------------------------------------------------------------------- + * + * UnloadLibrary -- + * + * Unloads a library from an interpreter, and also from the process if it + * is unloadable, i.e. if it provides an "unload" function. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See description. + * + *---------------------------------------------------------------------- + */ static int UnloadLibrary( Tcl_Interp *interp, @@ -884,11 +901,9 @@ UnloadLibrary( } /* - * The unload function executed fine. Examine the reference count to see - * if we unload the DLL. + * The unload function was called succesfully. */ - Tcl_MutexLock(&libraryMutex); if (Tcl_IsSafe(target)) { libraryPtr->safeInterpRefCount--; @@ -917,7 +932,7 @@ UnloadLibrary( code = TCL_OK; if (libraryPtr->safeInterpRefCount <= 0 && libraryPtr->interpRefCount <= 0 - && !keepLibrary) { + && (unloadProc != NULL) && !keepLibrary) { /* * Unload the shared library from the application memory... */ diff --git a/tests/pkgMkIndex.test b/tests/pkgMkIndex.test index 62bd3d4..25840c6 100644 --- a/tests/pkgMkIndex.test +++ b/tests/pkgMkIndex.test @@ -591,7 +591,7 @@ test pkgMkIndex-10.2 {package in DLL hidden by -load} [list exec $dll] { "[list pkg_mkIndex -lazy -load Pkg* $fullPkgPath [file tail $x]]" exec [interpreter] << $script pkgtest::runCreatedIndex {0 {}} -lazy -load Pkg* -- $fullPkgPath pkga[info sharedlibextension] -} "0 {{pkga:1.0 {tclPkgSetup {pkga[info sharedlibextension] load {pkga_eq pkga_quote}}}}}" +} "0 {}" if {[testConstraint $dll]} { file delete -force [file join $fullPkgPath [file tail $x]] -- cgit v0.12 From d2abd44f2bc2abbd42bda4643478e51c2ae04e3d Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 22 Mar 2022 08:16:01 +0000 Subject: Add UTF-16 versions of Tcl_UniCharLength/Tcl_NumUtfChars/Tcl_UtfAtIndex. Needed for Tk's glyph_indexing_2, and possibly other extensions sticking at TCL_UTF_MAX=3 --- generic/tcl.decls | 15 ++++++++-- generic/tclDecls.h | 47 ++++++++++++++++++++++++-------- generic/tclInt.h | 2 +- generic/tclStringObj.c | 46 ++++++++++++++++++++++++++++--- generic/tclStubInit.c | 9 ++++-- generic/tclUtf.c | 74 ++++++++++++++++++++++++++++++++++++++++++++++++++ 6 files changed, 170 insertions(+), 23 deletions(-) diff --git a/generic/tcl.decls b/generic/tcl.decls index 5a03bd2..98419d6 100644 --- a/generic/tcl.decls +++ b/generic/tcl.decls @@ -1162,7 +1162,7 @@ declare 311 { const Tcl_Time *timePtr) } declare 312 { - size_t Tcl_NumUtfChars(const char *src, size_t length) + size_t TclNumUtfChars(const char *src, size_t length) } declare 313 { size_t Tcl_ReadChars(Tcl_Channel channel, Tcl_Obj *objPtr, @@ -1206,7 +1206,7 @@ declare 324 { int Tcl_UniCharToUtf(int ch, char *buf) } declare 325 { - const char *Tcl_UtfAtIndex(const char *src, size_t index) + const char *TclUtfAtIndex(const char *src, size_t index) } declare 326 { int TclUtfCharComplete(const char *src, size_t length) @@ -1396,7 +1396,7 @@ declare 379 { size_t numChars) } declare 380 { - size_t Tcl_GetCharLength(Tcl_Obj *objPtr) + size_t TclGetCharLength(Tcl_Obj *objPtr) } declare 381 { int Tcl_GetUniChar(Tcl_Obj *objPtr, size_t index) @@ -2516,6 +2516,15 @@ declare 660 { declare 668 { size_t Tcl_UniCharLen(const int *uniStr) } +declare 669 { + size_t Tcl_NumUtfChars(const char *src, size_t length) +} +declare 670 { + size_t Tcl_GetCharLength(Tcl_Obj *objPtr) +} +declare 671 { + const char *Tcl_UtfAtIndex(const char *src, size_t index) +} # ----- BASELINE -- FOR -- 8.7.0 ----- # diff --git a/generic/tclDecls.h b/generic/tclDecls.h index cc33cf8..81ce6f8 100644 --- a/generic/tclDecls.h +++ b/generic/tclDecls.h @@ -828,7 +828,7 @@ EXTERN void Tcl_ConditionNotify(Tcl_Condition *condPtr); EXTERN void Tcl_ConditionWait(Tcl_Condition *condPtr, Tcl_Mutex *mutexPtr, const Tcl_Time *timePtr); /* 312 */ -EXTERN size_t Tcl_NumUtfChars(const char *src, size_t length); +EXTERN size_t TclNumUtfChars(const char *src, size_t length); /* 313 */ EXTERN size_t Tcl_ReadChars(Tcl_Channel channel, Tcl_Obj *objPtr, size_t charsToRead, int appendFlag); @@ -857,7 +857,7 @@ EXTERN int Tcl_UniCharToUpper(int ch); /* 324 */ EXTERN int Tcl_UniCharToUtf(int ch, char *buf); /* 325 */ -EXTERN const char * Tcl_UtfAtIndex(const char *src, size_t index); +EXTERN const char * TclUtfAtIndex(const char *src, size_t index); /* 326 */ EXTERN int TclUtfCharComplete(const char *src, size_t length); /* 327 */ @@ -996,7 +996,7 @@ EXTERN Tcl_Obj * Tcl_NewUnicodeObj(const Tcl_UniChar *unicode, EXTERN void Tcl_SetUnicodeObj(Tcl_Obj *objPtr, const Tcl_UniChar *unicode, size_t numChars); /* 380 */ -EXTERN size_t Tcl_GetCharLength(Tcl_Obj *objPtr); +EXTERN size_t TclGetCharLength(Tcl_Obj *objPtr); /* 381 */ EXTERN int Tcl_GetUniChar(Tcl_Obj *objPtr, size_t index); /* Slot 382 is reserved */ @@ -1774,6 +1774,12 @@ EXTERN int Tcl_AsyncMarkFromSignal(Tcl_AsyncHandler async, /* Slot 667 is reserved */ /* 668 */ EXTERN size_t Tcl_UniCharLen(const int *uniStr); +/* 669 */ +EXTERN size_t Tcl_NumUtfChars(const char *src, size_t length); +/* 670 */ +EXTERN size_t Tcl_GetCharLength(Tcl_Obj *objPtr); +/* 671 */ +EXTERN const char * Tcl_UtfAtIndex(const char *src, size_t index); typedef struct { const struct TclPlatStubs *tclPlatStubs; @@ -2097,7 +2103,7 @@ typedef struct TclStubs { void (*tcl_MutexUnlock) (Tcl_Mutex *mutexPtr); /* 309 */ void (*tcl_ConditionNotify) (Tcl_Condition *condPtr); /* 310 */ void (*tcl_ConditionWait) (Tcl_Condition *condPtr, Tcl_Mutex *mutexPtr, const Tcl_Time *timePtr); /* 311 */ - size_t (*tcl_NumUtfChars) (const char *src, size_t length); /* 312 */ + size_t (*tclNumUtfChars) (const char *src, size_t length); /* 312 */ size_t (*tcl_ReadChars) (Tcl_Channel channel, Tcl_Obj *objPtr, size_t charsToRead, int appendFlag); /* 313 */ void (*reserved314)(void); void (*reserved315)(void); @@ -2110,7 +2116,7 @@ typedef struct TclStubs { int (*tcl_UniCharToTitle) (int ch); /* 322 */ int (*tcl_UniCharToUpper) (int ch); /* 323 */ int (*tcl_UniCharToUtf) (int ch, char *buf); /* 324 */ - const char * (*tcl_UtfAtIndex) (const char *src, size_t index); /* 325 */ + const char * (*tclUtfAtIndex) (const char *src, size_t index); /* 325 */ int (*tclUtfCharComplete) (const char *src, size_t length); /* 326 */ size_t (*tcl_UtfBackslash) (const char *src, int *readPtr, char *dst); /* 327 */ const char * (*tcl_UtfFindFirst) (const char *src, int ch); /* 328 */ @@ -2165,7 +2171,7 @@ typedef struct TclStubs { void (*tcl_RegExpGetInfo) (Tcl_RegExp regexp, Tcl_RegExpInfo *infoPtr); /* 377 */ Tcl_Obj * (*tcl_NewUnicodeObj) (const Tcl_UniChar *unicode, size_t numChars); /* 378 */ void (*tcl_SetUnicodeObj) (Tcl_Obj *objPtr, const Tcl_UniChar *unicode, size_t numChars); /* 379 */ - size_t (*tcl_GetCharLength) (Tcl_Obj *objPtr); /* 380 */ + size_t (*tclGetCharLength) (Tcl_Obj *objPtr); /* 380 */ int (*tcl_GetUniChar) (Tcl_Obj *objPtr, size_t index); /* 381 */ void (*reserved382)(void); Tcl_Obj * (*tcl_GetRange) (Tcl_Obj *objPtr, size_t first, size_t last); /* 383 */ @@ -2454,6 +2460,9 @@ typedef struct TclStubs { void (*reserved666)(void); void (*reserved667)(void); size_t (*tcl_UniCharLen) (const int *uniStr); /* 668 */ + size_t (*tcl_NumUtfChars) (const char *src, size_t length); /* 669 */ + size_t (*tcl_GetCharLength) (Tcl_Obj *objPtr); /* 670 */ + const char * (*tcl_UtfAtIndex) (const char *src, size_t index); /* 671 */ } TclStubs; extern const TclStubs *tclStubsPtr; @@ -3046,8 +3055,8 @@ extern const TclStubs *tclStubsPtr; (tclStubsPtr->tcl_ConditionNotify) /* 310 */ #define Tcl_ConditionWait \ (tclStubsPtr->tcl_ConditionWait) /* 311 */ -#define Tcl_NumUtfChars \ - (tclStubsPtr->tcl_NumUtfChars) /* 312 */ +#define TclNumUtfChars \ + (tclStubsPtr->tclNumUtfChars) /* 312 */ #define Tcl_ReadChars \ (tclStubsPtr->tcl_ReadChars) /* 313 */ /* Slot 314 is reserved */ @@ -3070,8 +3079,8 @@ extern const TclStubs *tclStubsPtr; (tclStubsPtr->tcl_UniCharToUpper) /* 323 */ #define Tcl_UniCharToUtf \ (tclStubsPtr->tcl_UniCharToUtf) /* 324 */ -#define Tcl_UtfAtIndex \ - (tclStubsPtr->tcl_UtfAtIndex) /* 325 */ +#define TclUtfAtIndex \ + (tclStubsPtr->tclUtfAtIndex) /* 325 */ #define TclUtfCharComplete \ (tclStubsPtr->tclUtfCharComplete) /* 326 */ #define Tcl_UtfBackslash \ @@ -3176,8 +3185,8 @@ extern const TclStubs *tclStubsPtr; (tclStubsPtr->tcl_NewUnicodeObj) /* 378 */ #define Tcl_SetUnicodeObj \ (tclStubsPtr->tcl_SetUnicodeObj) /* 379 */ -#define Tcl_GetCharLength \ - (tclStubsPtr->tcl_GetCharLength) /* 380 */ +#define TclGetCharLength \ + (tclStubsPtr->tclGetCharLength) /* 380 */ #define Tcl_GetUniChar \ (tclStubsPtr->tcl_GetUniChar) /* 381 */ /* Slot 382 is reserved */ @@ -3736,6 +3745,12 @@ extern const TclStubs *tclStubsPtr; /* Slot 667 is reserved */ #define Tcl_UniCharLen \ (tclStubsPtr->tcl_UniCharLen) /* 668 */ +#define Tcl_NumUtfChars \ + (tclStubsPtr->tcl_NumUtfChars) /* 669 */ +#define Tcl_GetCharLength \ + (tclStubsPtr->tcl_GetCharLength) /* 670 */ +#define Tcl_UtfAtIndex \ + (tclStubsPtr->tcl_UtfAtIndex) /* 671 */ #endif /* defined(USE_TCL_STUBS) */ @@ -3937,6 +3952,14 @@ extern const TclStubs *tclStubsPtr; # define Tcl_UtfToUniChar Tcl_UtfToChar16 # undef Tcl_UniCharLen # define Tcl_UniCharLen Tcl_Char16Len +#if !defined(BUILD_tcl) +# undef Tcl_NumUtfChars +# define Tcl_NumUtfChars TclNumUtfChars +# undef Tcl_GetCharLength +# define Tcl_GetCharLength TclGetCharLength +# undef Tcl_UtfAtIndex +# define Tcl_UtfAtIndex TclUtfAtIndex +#endif #endif #if defined(USE_TCL_STUBS) # define Tcl_WCharToUtfDString (sizeof(wchar_t) != sizeof(short) \ diff --git a/generic/tclInt.h b/generic/tclInt.h index 596e1cb..055c497 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -4668,7 +4668,7 @@ MODULE_SCOPE const TclFileAttrProcs tclpFileAttrProcs[]; *---------------------------------------------------------------- */ -#define TclNumUtfChars(numChars, bytes, numBytes) \ +#define TclNumUtfChars_NOTUSED(numChars, bytes, numBytes) \ do { \ size_t _count, _i = (numBytes); \ unsigned char *_str = (unsigned char *) (bytes); \ diff --git a/generic/tclStringObj.c b/generic/tclStringObj.c index c8d9df7..76d43a6 100644 --- a/generic/tclStringObj.c +++ b/generic/tclStringObj.c @@ -394,6 +394,7 @@ Tcl_NewUnicodeObj( *---------------------------------------------------------------------- */ +#undef Tcl_GetCharLength size_t Tcl_GetCharLength( Tcl_Obj *objPtr) /* The String object to get the num chars @@ -440,12 +441,49 @@ Tcl_GetCharLength( */ if (numChars == TCL_INDEX_NONE) { - TclNumUtfChars(numChars, objPtr->bytes, objPtr->length); + numChars = Tcl_NumUtfChars(objPtr->bytes, objPtr->length); stringPtr->numChars = numChars; } return numChars; } +size_t +TclGetCharLength( + Tcl_Obj *objPtr) /* The String object to get the num chars + * of. */ +{ + size_t numChars = 0; + + /* + * Quick, no-shimmer return for short string reps. + */ + + if ((objPtr->bytes) && (objPtr->length < 2)) { + /* 0 bytes -> 0 chars; 1 byte -> 1 char */ + return objPtr->length; + } + + /* + * Optimize the case where we're really dealing with a bytearray object; + * we don't need to convert to a string to perform the get-length operation. + * + * Starting in Tcl 8.7, we check for a "pure" bytearray, because the + * machinery behind that test is using a proper bytearray ObjType. We + * could also compute length of an improper bytearray without shimmering + * but there's no value in that. We *want* to shimmer an improper bytearray + * because improper bytearrays have worthless internal reps. + */ + + if (TclIsPureByteArray(objPtr)) { + (void) Tcl_GetByteArrayFromObj(objPtr, &numChars); + } else { + numChars = TclNumUtfChars(objPtr->bytes, objPtr->length); + } + + return numChars; +} + + /* *---------------------------------------------------------------------- * @@ -543,7 +581,7 @@ Tcl_GetUniChar( */ if (stringPtr->numChars == TCL_INDEX_NONE) { - TclNumUtfChars(stringPtr->numChars, objPtr->bytes, objPtr->length); + stringPtr->numChars = Tcl_NumUtfChars(objPtr->bytes, objPtr->length); } if (stringPtr->numChars == objPtr->length) { return (unsigned char) objPtr->bytes[index]; @@ -709,7 +747,7 @@ Tcl_GetRange( */ if (stringPtr->numChars == TCL_INDEX_NONE) { - TclNumUtfChars(stringPtr->numChars, objPtr->bytes, objPtr->length); + stringPtr->numChars = Tcl_NumUtfChars(objPtr->bytes, objPtr->length); } if (stringPtr->numChars == objPtr->length) { if (last >= stringPtr->numChars) { @@ -4045,7 +4083,7 @@ ExtendUnicodeRepWithString( numOrigChars = stringPtr->numChars; } if (numAppendChars == TCL_INDEX_NONE) { - TclNumUtfChars(numAppendChars, bytes, numBytes); + numAppendChars = Tcl_NumUtfChars(bytes, numBytes); } needed = numOrigChars + numAppendChars; diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c index ea7083f..6704df8 100644 --- a/generic/tclStubInit.c +++ b/generic/tclStubInit.c @@ -1005,7 +1005,7 @@ const TclStubs tclStubs = { Tcl_MutexUnlock, /* 309 */ Tcl_ConditionNotify, /* 310 */ Tcl_ConditionWait, /* 311 */ - Tcl_NumUtfChars, /* 312 */ + TclNumUtfChars, /* 312 */ Tcl_ReadChars, /* 313 */ 0, /* 314 */ 0, /* 315 */ @@ -1018,7 +1018,7 @@ const TclStubs tclStubs = { Tcl_UniCharToTitle, /* 322 */ Tcl_UniCharToUpper, /* 323 */ Tcl_UniCharToUtf, /* 324 */ - Tcl_UtfAtIndex, /* 325 */ + TclUtfAtIndex, /* 325 */ TclUtfCharComplete, /* 326 */ Tcl_UtfBackslash, /* 327 */ Tcl_UtfFindFirst, /* 328 */ @@ -1073,7 +1073,7 @@ const TclStubs tclStubs = { Tcl_RegExpGetInfo, /* 377 */ Tcl_NewUnicodeObj, /* 378 */ Tcl_SetUnicodeObj, /* 379 */ - Tcl_GetCharLength, /* 380 */ + TclGetCharLength, /* 380 */ Tcl_GetUniChar, /* 381 */ 0, /* 382 */ Tcl_GetRange, /* 383 */ @@ -1362,6 +1362,9 @@ const TclStubs tclStubs = { 0, /* 666 */ 0, /* 667 */ Tcl_UniCharLen, /* 668 */ + Tcl_NumUtfChars, /* 669 */ + Tcl_GetCharLength, /* 670 */ + Tcl_UtfAtIndex, /* 671 */ }; /* !END!: Do not edit above this line. */ diff --git a/generic/tclUtf.c b/generic/tclUtf.c index e353b7f..6c6940c 100644 --- a/generic/tclUtf.c +++ b/generic/tclUtf.c @@ -799,6 +799,7 @@ Tcl_UtfCharComplete( *--------------------------------------------------------------------------- */ +#undef Tcl_NumUtfChars size_t Tcl_NumUtfChars( const char *src, /* The UTF-8 string to measure. */ @@ -851,6 +852,58 @@ Tcl_NumUtfChars( return i; } +size_t +TclNumUtfChars( + const char *src, /* The UTF-8 string to measure. */ + size_t length) /* The length of the string in bytes, or + * TCL_INDEX_NONE for strlen(src). */ +{ + unsigned short ch = 0; + size_t i = 0; + + if (length == TCL_INDEX_NONE) { + /* string is NUL-terminated, so TclUtfToUniChar calls are safe. */ + while (*src != '\0') { + src += Tcl_UtfToChar16(src, &ch); + i++; + } + } else { + /* Will return value between 0 and length. No overflow checks. */ + + /* Pointer to the end of string. Never read endPtr[0] */ + const char *endPtr = src + length; + /* Pointer to last byte where optimization still can be used */ + const char *optPtr = endPtr - 4; + + /* + * Optimize away the call in this loop. Justified because... + * when (src <= optPtr), (endPtr - src) >= (endPtr - optPtr) + * By initialization above (endPtr - optPtr) = TCL_UTF_MAX + * So (endPtr - src) >= TCL_UTF_MAX, and passing that to + * Tcl_UtfCharComplete we know will cause return of 1. + */ + while (src <= optPtr + /* && Tcl_UtfCharComplete(src, endPtr - src) */ ) { + src += Tcl_UtfToChar16(src, &ch); + i++; + } + /* Loop over the remaining string where call must happen */ + while (src < endPtr) { + if (Tcl_UtfCharComplete(src, endPtr - src)) { + src += Tcl_UtfToChar16(src, &ch); + } else { + /* + * src points to incomplete UTF-8 sequence + * Treat first byte as character and count it + */ + src++; + } + i++; + } + } + return i; +} + /* *--------------------------------------------------------------------------- * @@ -1167,6 +1220,7 @@ Tcl_UniCharAtIndex( *--------------------------------------------------------------------------- */ +#undef Tcl_UtfAtIndex const char * Tcl_UtfAtIndex( const char *src, /* The UTF-8 string. */ @@ -1195,6 +1249,26 @@ Tcl_UtfAtIndex( return src; } +const char * +TclUtfAtIndex( + const char *src, /* The UTF-8 string. */ + size_t index) /* The position of the desired character. */ +{ + unsigned short ch = 0; + size_t len = 0; + + if (index != TCL_INDEX_NONE) { + while (index--) { + src += (len = Tcl_UtfToChar16(src, &ch)); + } + if ((ch >= 0xD800) && (len < 3)) { + /* Index points at character following high Surrogate */ + src += Tcl_UtfToChar16(src, &ch); + } + } + return src; +} + /* *--------------------------------------------------------------------------- * -- cgit v0.12 From 7d893da1b984ded235163f3ec8018195d9058f2a Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 22 Mar 2022 11:25:13 +0000 Subject: More progress --- generic/tclInt.h | 4 ++++ generic/tclStringObj.c | 17 +++++------------ generic/tclStubInit.c | 2 ++ generic/tclUtf.c | 1 + tests/string.test | 2 +- tests/utf.test | 2 +- 6 files changed, 14 insertions(+), 14 deletions(-) diff --git a/generic/tclInt.h b/generic/tclInt.h index 0705c1d..538bca3 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -3328,6 +3328,10 @@ MODULE_SCOPE int TclZipfs_Init(Tcl_Interp *interp); MODULE_SCOPE int TclUniCharCaseMatch(const int *, const int *, int); MODULE_SCOPE int TclUniCharNcmp(const int *, const int *, unsigned long); MODULE_SCOPE const char *TclUtfAtIndex(const char *, int); +# undef Tcl_GetCharLength +# define Tcl_GetCharLength TclGetCharLength +# undef Tcl_UtfAtIndex +# define Tcl_UtfAtIndex TclUtfAtIndex #else # define TclGetUnicodeFromObj_ Tcl_GetUnicodeFromObj # define TclNewUnicodeObj Tcl_NewUnicodeObj diff --git a/generic/tclStringObj.c b/generic/tclStringObj.c index 2dc79eb..6417e1b 100644 --- a/generic/tclStringObj.c +++ b/generic/tclStringObj.c @@ -644,12 +644,12 @@ TclGetCharLength( } #if TCL_UTF_MAX > 3 +#undef Tcl_GetCharLength int Tcl_GetCharLength( Tcl_Obj *objPtr) /* The String object to get the num chars * of. */ { - String *stringPtr; int numChars; /* @@ -673,19 +673,12 @@ Tcl_GetCharLength( */ if (TclIsPureByteArray(objPtr)) { - int length; - (void) Tcl_GetByteArrayFromObj(objPtr, &length); - return length; + (void) Tcl_GetByteArrayFromObj(objPtr, &numChars); + } else { + numChars = Tcl_NumUtfChars(Tcl_GetString(objPtr), -1); } - - /* - * OK, need to work with the object as a string. - */ - - SetUTF16StringFromAny(NULL, objPtr); - stringPtr = GET_STRING(objPtr); - return stringPtr->numChars; + return numChars; } #endif diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c index f9430cb..e3ebb8b 100644 --- a/generic/tclStubInit.c +++ b/generic/tclStubInit.c @@ -76,6 +76,8 @@ #undef Tcl_MacOSXOpenBundleResources #undef TclWinConvertWSAError #undef TclWinConvertError +#undef Tcl_GetCharLength +#undef Tcl_UtfAtIndex #if defined(_WIN32) || defined(__CYGWIN__) #define TclWinConvertWSAError (void (*)(DWORD))(void *)Tcl_WinConvertError #define TclWinConvertError (void (*)(DWORD))(void *)Tcl_WinConvertError diff --git a/generic/tclUtf.c b/generic/tclUtf.c index c47ee97..4dd1e09 100644 --- a/generic/tclUtf.c +++ b/generic/tclUtf.c @@ -1193,6 +1193,7 @@ TclUtfAtIndex( } #if TCL_UTF_MAX > 3 +#undef Tcl_UtfAtIndex const char * Tcl_UtfAtIndex( const char *src, /* The UTF-8 string. */ diff --git a/tests/string.test b/tests/string.test index 9cac73d..203d0c6 100644 --- a/tests/string.test +++ b/tests/string.test @@ -422,7 +422,7 @@ test string-4.16.$noComp {string first, normal string vs pure unicode string} -b # Representation checks are canaries run {list [representationpoke $s] [representationpoke $m] \ [string first $m $s]} -} -result {{utf32string 1} {utf32string 0} 2} +} -result {{string 1} {string 0} 2} test string-4.17.$noComp {string first, corner case} -body { run {string first a aaa 4294967295} } -result {-1} diff --git a/tests/utf.test b/tests/utf.test index 477216c..c79492e 100644 --- a/tests/utf.test +++ b/tests/utf.test @@ -1230,7 +1230,7 @@ test utf-19.1 {TclUniCharLen} -body { test utf-20.1 {TclUniCharNcmp} ucs4 { string compare [string range [format %c 0xFFFF] 0 0] [string range [format %c 0x10000] 0 0] } -1 -test utf-20.2 {[4c591fa487] TclUniCharNcmp/TclUtfNcmp} { +test utf-20.2 {[4c591fa487] TclUniCharNcmp/TclUtfNcmp} ucs4 { set one [format %c 0xFFFF] set two [format %c 0x10000] set first [string compare $one $two] -- cgit v0.12 From b5e6f95ea90be59cb281c089806f0e446e1272bc Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 22 Mar 2022 15:38:25 +0000 Subject: Feature-complete --- generic/tcl.decls | 9 ++++++++ generic/tclDecls.h | 15 +++++++++++++ generic/tclInt.h | 12 +++++++---- generic/tclStringObj.c | 8 +++---- generic/tclStubInit.c | 3 +++ generic/tclUtf.c | 57 +++++++++++++++++++++++++++++++++++++++++++++++++- tests/string.test | 2 +- 7 files changed, 96 insertions(+), 10 deletions(-) diff --git a/generic/tcl.decls b/generic/tcl.decls index f5b2e78..fa844e0 100644 --- a/generic/tcl.decls +++ b/generic/tcl.decls @@ -2446,6 +2446,15 @@ declare 660 { declare 668 { int Tcl_UniCharLen(const int *uniStr) } +declare 669 { + int TclNumUtfChars(const char *src, int length) +} +declare 670 { + int TclGetCharLength(Tcl_Obj *objPtr) +} +declare 671 { + const char *TclUtfAtIndex(const char *src, int index) +} # ----- BASELINE -- FOR -- 8.7.0 ----- # diff --git a/generic/tclDecls.h b/generic/tclDecls.h index 1952641..9f5e798 100644 --- a/generic/tclDecls.h +++ b/generic/tclDecls.h @@ -1957,6 +1957,12 @@ EXTERN int Tcl_AsyncMarkFromSignal(Tcl_AsyncHandler async, /* Slot 667 is reserved */ /* 668 */ EXTERN int Tcl_UniCharLen(const int *uniStr); +/* 669 */ +EXTERN int TclNumUtfChars(const char *src, int length); +/* 670 */ +EXTERN int TclGetCharLength(Tcl_Obj *objPtr); +/* 671 */ +EXTERN const char * TclUtfAtIndex(const char *src, int index); typedef struct { const struct TclPlatStubs *tclPlatStubs; @@ -2661,6 +2667,9 @@ typedef struct TclStubs { void (*reserved666)(void); void (*reserved667)(void); int (*tcl_UniCharLen) (const int *uniStr); /* 668 */ + int (*tclNumUtfChars) (const char *src, int length); /* 669 */ + int (*tclGetCharLength) (Tcl_Obj *objPtr); /* 670 */ + const char * (*tclUtfAtIndex) (const char *src, int index); /* 671 */ } TclStubs; extern const TclStubs *tclStubsPtr; @@ -4020,6 +4029,12 @@ extern const TclStubs *tclStubsPtr; /* Slot 667 is reserved */ #define Tcl_UniCharLen \ (tclStubsPtr->tcl_UniCharLen) /* 668 */ +#define TclNumUtfChars \ + (tclStubsPtr->tclNumUtfChars) /* 669 */ +#define TclGetCharLength \ + (tclStubsPtr->tclGetCharLength) /* 670 */ +#define TclUtfAtIndex \ + (tclStubsPtr->tclUtfAtIndex) /* 671 */ #endif /* defined(USE_TCL_STUBS) */ diff --git a/generic/tclInt.h b/generic/tclInt.h index 538bca3..73d6386 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -3322,12 +3322,12 @@ MODULE_SCOPE int TclZipfs_Init(Tcl_Interp *interp); #if TCL_UTF_MAX > 3 MODULE_SCOPE int *TclGetUnicodeFromObj_(Tcl_Obj *, int *); MODULE_SCOPE Tcl_Obj *TclNewUnicodeObj(const int *, int); - MODULE_SCOPE int TclGetCharLength(Tcl_Obj *); MODULE_SCOPE void TclAppendUnicodeToObj(Tcl_Obj *, const int *, int); MODULE_SCOPE int TclUniCharNcasecmp(const int *, const int *, unsigned long); MODULE_SCOPE int TclUniCharCaseMatch(const int *, const int *, int); MODULE_SCOPE int TclUniCharNcmp(const int *, const int *, unsigned long); - MODULE_SCOPE const char *TclUtfAtIndex(const char *, int); +# undef Tcl_NumUtfChars +# define Tcl_NumUtfChars TclNumUtfChars # undef Tcl_GetCharLength # define Tcl_GetCharLength TclGetCharLength # undef Tcl_UtfAtIndex @@ -3335,11 +3335,15 @@ MODULE_SCOPE int TclZipfs_Init(Tcl_Interp *interp); #else # define TclGetUnicodeFromObj_ Tcl_GetUnicodeFromObj # define TclNewUnicodeObj Tcl_NewUnicodeObj -# define TclGetCharLength Tcl_GetCharLength # define TclAppendUnicodeToObj Tcl_AppendUnicodeToObj # define TclUniCharNcasecmp Tcl_UniCharNcasecmp # define TclUniCharCaseMatch Tcl_UniCharCaseMatch # define TclUniCharNcmp Tcl_UniCharNcmp +# undef TclNumUtfChars +# define TclNumUtfChars Tcl_NumUtfChars +# undef TclGetCharLength +# define TclGetCharLength Tcl_GetCharLength +# undef TclUtfAtIndex # define TclUtfAtIndex Tcl_UtfAtIndex #endif @@ -4764,7 +4768,7 @@ MODULE_SCOPE const TclFileAttrProcs tclpFileAttrProcs[]; *---------------------------------------------------------------- */ -#define TclNumUtfChars(numChars, bytes, numBytes) \ +#define TclNumUtfChars_UNUSED(numChars, bytes, numBytes) \ do { \ int _count, _i = (numBytes); \ unsigned char *_str = (unsigned char *) (bytes); \ diff --git a/generic/tclStringObj.c b/generic/tclStringObj.c index 6417e1b..2b11877 100644 --- a/generic/tclStringObj.c +++ b/generic/tclStringObj.c @@ -637,7 +637,7 @@ TclGetCharLength( */ if (numChars == -1) { - TclNumUtfChars(numChars, objPtr->bytes, objPtr->length); + numChars = Tcl_NumUtfChars(objPtr->bytes, objPtr->length); stringPtr->numChars = numChars; } return numChars; @@ -782,7 +782,7 @@ Tcl_GetUniChar( */ if (stringPtr->numChars == -1) { - TclNumUtfChars(stringPtr->numChars, objPtr->bytes, objPtr->length); + stringPtr->numChars = Tcl_NumUtfChars(objPtr->bytes, objPtr->length); } if (stringPtr->numChars == objPtr->length) { return (unsigned char) objPtr->bytes[index]; @@ -991,7 +991,7 @@ Tcl_GetRange( */ if (stringPtr->numChars == -1) { - TclNumUtfChars(stringPtr->numChars, objPtr->bytes, objPtr->length); + stringPtr->numChars = Tcl_NumUtfChars(objPtr->bytes, objPtr->length); } if (stringPtr->numChars == objPtr->length) { if (last < 0 || last >= stringPtr->numChars) { @@ -4447,7 +4447,7 @@ ExtendUnicodeRepWithString( numOrigChars = stringPtr->numChars; } if (numAppendChars == -1) { - TclNumUtfChars(numAppendChars, bytes, numBytes); + numAppendChars = Tcl_NumUtfChars(bytes, numBytes); } needed = numOrigChars + numAppendChars; uniCharStringCheckLimits(needed); diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c index e3ebb8b..09163c3 100644 --- a/generic/tclStubInit.c +++ b/generic/tclStubInit.c @@ -1937,6 +1937,9 @@ const TclStubs tclStubs = { 0, /* 666 */ 0, /* 667 */ Tcl_UniCharLen, /* 668 */ + TclNumUtfChars, /* 669 */ + TclGetCharLength, /* 670 */ + TclUtfAtIndex, /* 671 */ }; /* !END!: Do not edit above this line. */ diff --git a/generic/tclUtf.c b/generic/tclUtf.c index 4dd1e09..eda317f 100644 --- a/generic/tclUtf.c +++ b/generic/tclUtf.c @@ -799,7 +799,7 @@ Tcl_UtfCharComplete( */ int -Tcl_NumUtfChars( +TclNumUtfChars( const char *src, /* The UTF-8 string to measure. */ int length) /* The length of the string in bytes, or -1 * for strlen(string). */ @@ -850,6 +850,61 @@ Tcl_NumUtfChars( return i; } +#if TCL_UTF_MAX > 3 +#undef Tcl_NumUtfChars +int +Tcl_NumUtfChars( + const char *src, /* The UTF-8 string to measure. */ + int length) /* The length of the string in bytes, or -1 + * for strlen(string). */ +{ + unsigned short ch = 0; + int i = 0; + + if (length < 0) { + /* string is NUL-terminated, so TclUtfToUniChar calls are safe. */ + while ((*src != '\0') && (i < INT_MAX)) { + src += Tcl_UtfToChar16(src, &ch); + i++; + } + } else { + /* Will return value between 0 and length. No overflow checks. */ + + /* Pointer to the end of string. Never read endPtr[0] */ + const char *endPtr = src + length; + /* Pointer to last byte where optimization still can be used */ + const char *optPtr = endPtr - 4; + + /* + * Optimize away the call in this loop. Justified because... + * when (src <= optPtr), (endPtr - src) >= (endPtr - optPtr) + * By initialization above (endPtr - optPtr) = TCL_UTF_MAX + * So (endPtr - src) >= TCL_UTF_MAX, and passing that to + * Tcl_UtfCharComplete we know will cause return of 1. + */ + while (src <= optPtr + /* && Tcl_UtfCharComplete(src, endPtr - src) */ ) { + src += Tcl_UtfToChar16(src, &ch); + i++; + } + /* Loop over the remaining string where call must happen */ + while (src < endPtr) { + if (Tcl_UtfCharComplete(src, endPtr - src)) { + src += Tcl_UtfToChar16(src, &ch); + } else { + /* + * src points to incomplete UTF-8 sequence + * Treat first byte as character and count it + */ + src++; + } + i++; + } + } + return i; +} +#endif + /* *--------------------------------------------------------------------------- * diff --git a/tests/string.test b/tests/string.test index 203d0c6..6863c23 100644 --- a/tests/string.test +++ b/tests/string.test @@ -422,7 +422,7 @@ test string-4.16.$noComp {string first, normal string vs pure unicode string} -b # Representation checks are canaries run {list [representationpoke $s] [representationpoke $m] \ [string first $m $s]} -} -result {{string 1} {string 0} 2} +} -match glob -result {{*string 1} {*string 0} 2} test string-4.17.$noComp {string first, corner case} -body { run {string first a aaa 4294967295} } -result {-1} -- cgit v0.12 From d4c27c94668a30f48edee251104255b27230107e Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 22 Mar 2022 16:12:20 +0000 Subject: ucs4 -> utf32 --- tests/stringObj.test | 17 +++++++++-------- tests/utf.test | 46 +++++++++++++++++++++++----------------------- 2 files changed, 32 insertions(+), 31 deletions(-) diff --git a/tests/stringObj.test b/tests/stringObj.test index bae61ab..c11bf7f 100644 --- a/tests/stringObj.test +++ b/tests/stringObj.test @@ -25,7 +25,8 @@ 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}] - +testConstraint utf32 [expr {[string length [format %c 0x10000]] == 1}] + test stringObj-1.1 {string type registration} testobj { set t [testobj types] set first [string first "string" $t] @@ -57,7 +58,7 @@ test stringObj-3.2 {Tcl_SetStringObj, existing non-"empty string" object} testob lappend result [testobj refcount 1] } {{} 512 foo string 2} -test stringObj-4.1 {Tcl_SetObjLength procedure, string gets shorter} {testobj fullutf} { +test stringObj-4.1 {Tcl_SetObjLength procedure, string gets shorter} {testobj utf32} { testobj freeallvars teststringobj set 1 test teststringobj setlength 1 3 @@ -70,7 +71,7 @@ test stringObj-4.2 {Tcl_SetObjLength procedure, string gets longer} testobj { teststringobj setlength 1 10 list [teststringobj length 1] [teststringobj length2 1] } {10 10} -test stringObj-4.3 {Tcl_SetObjLength procedure, string gets longer} {testobj fullutf} { +test stringObj-4.3 {Tcl_SetObjLength procedure, string gets longer} {testobj utf32} { testobj freeallvars teststringobj set 1 abcdef teststringobj append 1 xyzq -1 @@ -97,7 +98,7 @@ test stringObj-5.2 {Tcl_AppendToObj procedure, length calculation} testobj { teststringobj append 1 123 -1 teststringobj get 1 } {x y bbCC123} -test stringObj-5.3 {Tcl_AppendToObj procedure, reallocating space} {testobj fullutf} { +test stringObj-5.3 {Tcl_AppendToObj procedure, reallocating space} {testobj utf32} { testobj freeallvars teststringobj set 1 xyz teststringobj setlength 1 15 @@ -135,7 +136,7 @@ test stringObj-6.4 {Tcl_AppendStringsToObj procedure, counting space} testobj { teststringobj appendstrings 1 { 123 } abcdefg list [teststringobj length 1] [teststringobj get 1] } {15 {abc 123 abcdefg}} -test stringObj-6.5 {Tcl_AppendStringsToObj procedure, don't double space if initial string empty} {testobj fullutf} { +test stringObj-6.5 {Tcl_AppendStringsToObj procedure, don't double space if initial string empty} {testobj utf32} { testobj freeallvars testobj newobj 1 teststringobj appendstrings 1 123 abcdefg @@ -150,7 +151,7 @@ test stringObj-6.6 {Tcl_AppendStringsToObj procedure, space reallocation} testob list [teststringobj length 1] [teststringobj length2 1] \ [teststringobj get 1] } {10 10 ab34567890} -test stringObj-6.7 {Tcl_AppendStringsToObj procedure, space reallocation} {testobj fullutf} { +test stringObj-6.7 {Tcl_AppendStringsToObj procedure, space reallocation} {testobj utf32} { testobj freeallvars teststringobj set 1 abc teststringobj setlength 1 10 @@ -172,7 +173,7 @@ test stringObj-6.9 {Tcl_AppendStringToObj, pure unicode} testobj { teststringobj get 1 } adcfoobarsoom -test stringObj-7.1 {SetStringFromAny procedure} {testobj fullutf} { +test stringObj-7.1 {SetStringFromAny procedure} {testobj utf32} { testobj freeallvars teststringobj set2 1 [list a b] teststringobj append 1 x -1 @@ -197,7 +198,7 @@ test stringObj-7.4 {SetStringFromAny called with string obj} testobj { [string length $x] [testobj objtype $x] } {6 string 6 string} -test stringObj-8.1 {DupStringInternalRep procedure} {testobj fullutf} { +test stringObj-8.1 {DupStringInternalRep procedure} {testobj utf32} { testobj freeallvars teststringobj set 1 {} teststringobj append 1 abcde -1 diff --git a/tests/utf.test b/tests/utf.test index c79492e..c0d64e2 100644 --- a/tests/utf.test +++ b/tests/utf.test @@ -19,7 +19,7 @@ catch [list package require -exact tcl::test [info patchlevel]] testConstraint ucs2 [expr {[format %c 0x010000] eq "\uFFFD"}] testConstraint fullutf [expr {[format %c 0x010000] ne "\uFFFD"}] testConstraint utf16 [expr {[string length [format %c 0x10000]] == 2}] -testConstraint ucs4 [expr {[testConstraint fullutf] +testConstraint utf32 [expr {[testConstraint fullutf] && [string length [format %c 0x10000]] == 1}] testConstraint Uesc [expr {"\U0041" eq "A"}] @@ -131,7 +131,7 @@ test utf-2.8.0 {Tcl_UtfToUniChar: lead (4-byte) followed by 3 trail} {ucs2 testb test utf-2.8.1 {Tcl_UtfToUniChar: lead (4-byte) followed by 3 trail} utf16 { string length 𐀀 } 2 -test utf-2.8.2 {Tcl_UtfToUniChar: lead (4-byte) followed by 3 trail} ucs4 { +test utf-2.8.2 {Tcl_UtfToUniChar: lead (4-byte) followed by 3 trail} utf32 { string length 𐀀 } 1 test utf-2.9.0 {Tcl_UtfToUniChar: lead (4-byte) followed by 3 trail} {ucs2 testbytestring} { @@ -140,7 +140,7 @@ test utf-2.9.0 {Tcl_UtfToUniChar: lead (4-byte) followed by 3 trail} {ucs2 testb test utf-2.9.1 {Tcl_UtfToUniChar: lead (4-byte) followed by 3 trail} utf16 { string length \U10FFFF } 2 -test utf-2.9.2 {Tcl_UtfToUniChar: lead (4-byte) followed by 3 trail} ucs4 { +test utf-2.9.2 {Tcl_UtfToUniChar: lead (4-byte) followed by 3 trail} utf32 { string length \U10FFFF } 1 test utf-2.10 {Tcl_UtfToUniChar: lead (4-byte) followed by 3 trail, underflow} testbytestring { @@ -194,7 +194,7 @@ test utf-4.11 {Tcl_NumUtfChars: 3 bytes of 4-byte UTF-8 characater} {testnumutfc test utf-4.12.0 {Tcl_NumUtfChars: #4-byte UTF-8 character} {testnumutfchars testbytestring ucs2} { testnumutfchars [testbytestring \xF0\x9F\x92\xA9] end } 2 -test utf-4.12.1 {Tcl_NumUtfChars: #4-byte UTF-8 character} {testnumutfchars testbytestring ucs4} { +test utf-4.12.1 {Tcl_NumUtfChars: #4-byte UTF-8 character} {testnumutfchars testbytestring utf32} { testnumutfchars [testbytestring \xF0\x9F\x92\xA9] end } 1 test utf-4.13 {Tcl_NumUtfChars: end of string} {testnumutfchars testbytestring} { @@ -878,7 +878,7 @@ test utf-8.4 {Tcl_UniCharAtIndex: index > 0} { test utf-8.5.0 {Tcl_UniCharAtIndex: high surrogate} ucs2 { string index \uD842 0 } \uD842 -test utf-8.5.1 {Tcl_UniCharAtIndex: high surrogate} ucs4 { +test utf-8.5.1 {Tcl_UniCharAtIndex: high surrogate} utf32 { string index \uD842 0 } \uD842 test utf-8.5.2 {Tcl_UniCharAtIndex: high surrogate} utf16 { @@ -890,7 +890,7 @@ test utf-8.6 {Tcl_UniCharAtIndex: low surrogate} { test utf-8.7.0 {Tcl_UniCharAtIndex: Emoji} ucs2 { string index \uD83D\uDE00G 0 } \uD83D -test utf-8.7.1 {Tcl_UniCharAtIndex: Emoji} ucs4 { +test utf-8.7.1 {Tcl_UniCharAtIndex: Emoji} utf32 { string index 😀G 0 } 😀 test utf-8.7.2 {Tcl_UniCharAtIndex: Emoji} utf16 { @@ -899,7 +899,7 @@ test utf-8.7.2 {Tcl_UniCharAtIndex: Emoji} utf16 { test utf-8.8.0 {Tcl_UniCharAtIndex: Emoji} ucs2 { string index \uD83D\uDE00G 1 } \uDE00 -test utf-8.8.1 {Tcl_UniCharAtIndex: Emoji} ucs4 { +test utf-8.8.1 {Tcl_UniCharAtIndex: Emoji} utf32 { string index 😀G 1 } G test utf-8.8.2 {Tcl_UniCharAtIndex: Emoji} utf16 { @@ -908,7 +908,7 @@ test utf-8.8.2 {Tcl_UniCharAtIndex: Emoji} utf16 { test utf-8.9.0 {Tcl_UniCharAtIndex: Emoji} ucs2 { string index \uD83D\uDE00G 2 } G -test utf-8.9.1 {Tcl_UniCharAtIndex: Emoji} ucs4 { +test utf-8.9.1 {Tcl_UniCharAtIndex: Emoji} utf32 { string index 😀G 2 } {} test utf-8.9.2 {Tcl_UniCharAtIndex: Emoji} utf16 { @@ -917,7 +917,7 @@ test utf-8.9.2 {Tcl_UniCharAtIndex: Emoji} utf16 { test utf-8.10.0 {Tcl_UniCharAtIndex: Emoji} ucs2 { string index 😀G 0 } \uFFFD -test utf-8.10.1 {Tcl_UniCharAtIndex: Emoji} ucs4 { +test utf-8.10.1 {Tcl_UniCharAtIndex: Emoji} utf32 { string index 😀G 0 } 😀 test utf-8.10.2 {Tcl_UniCharAtIndex: Emoji} utf16 { @@ -926,7 +926,7 @@ test utf-8.10.2 {Tcl_UniCharAtIndex: Emoji} utf16 { test utf-8.11.0 {Tcl_UniCharAtIndex: Emoji} ucs2 { string index 😀G 1 } G -test utf-8.11.1 {Tcl_UniCharAtIndex: Emoji} ucs4 { +test utf-8.11.1 {Tcl_UniCharAtIndex: Emoji} utf32 { string index 😀G 1 } G test utf-8.11.2 {Tcl_UniCharAtIndex: Emoji} utf16 { @@ -935,7 +935,7 @@ test utf-8.11.2 {Tcl_UniCharAtIndex: Emoji} utf16 { test utf-8.12.0 {Tcl_UniCharAtIndex: Emoji} ucs2 { string index 😀G 2 } {} -test utf-8.12.1 {Tcl_UniCharAtIndex: Emoji} ucs4 { +test utf-8.12.1 {Tcl_UniCharAtIndex: Emoji} utf32 { string index 😀G 2 } {} test utf-8.12.2 {Tcl_UniCharAtIndex: Emoji} utf16 { @@ -951,7 +951,7 @@ test utf-9.2 {Tcl_UtfAtIndex: index > 0} { test utf-9.3.0 {Tcl_UtfAtIndex: index = 0, Emoji} ucs2 { string range \uD83D\uDE00G 0 0 } \uD83D -test utf-9.3.1 {Tcl_UtfAtIndex: index = 0, Emoji} ucs4 { +test utf-9.3.1 {Tcl_UtfAtIndex: index = 0, Emoji} utf32 { string range 😀G 0 0 } 😀 test utf-9.3.2 {Tcl_UtfAtIndex: index = 0, Emoji} utf16 { @@ -960,7 +960,7 @@ test utf-9.3.2 {Tcl_UtfAtIndex: index = 0, Emoji} utf16 { test utf-9.4.0 {Tcl_UtfAtIndex: index > 0, Emoji} ucs2 { string range \uD83D\uDE00G 1 1 } \uDE00 -test utf-9.4.1 {Tcl_UtfAtIndex: index > 0, Emoji} ucs4 { +test utf-9.4.1 {Tcl_UtfAtIndex: index > 0, Emoji} utf32 { string range 😀G 1 1 } G test utf-9.4.2 {Tcl_UtfAtIndex: index > 0, Emoji} utf16 { @@ -969,7 +969,7 @@ test utf-9.4.2 {Tcl_UtfAtIndex: index > 0, Emoji} utf16 { test utf-9.5.0 {Tcl_UtfAtIndex: index > 0, Emoji} ucs2 { string range \uD83D\uDE00G 2 2 } G -test utf-9.5.1 {Tcl_UtfAtIndex: index > 0, Emoji} ucs4 { +test utf-9.5.1 {Tcl_UtfAtIndex: index > 0, Emoji} utf32 { string range 😀G 2 2 } {} test utf-9.5.2 {Tcl_UtfAtIndex: index > 0, Emoji} utf16 { @@ -978,7 +978,7 @@ test utf-9.5.2 {Tcl_UtfAtIndex: index > 0, Emoji} utf16 { test utf-9.6.0 {Tcl_UtfAtIndex: index = 0, Emoji} ucs2 { string range 😀G 0 0 } \uFFFD -test utf-9.6.1 {Tcl_UtfAtIndex: index = 0, Emoji} ucs4 { +test utf-9.6.1 {Tcl_UtfAtIndex: index = 0, Emoji} utf32 { string range 😀G 0 0 } 😀 test utf-9.6.2 {Tcl_UtfAtIndex: index = 0, Emoji} utf16 { @@ -987,7 +987,7 @@ test utf-9.6.2 {Tcl_UtfAtIndex: index = 0, Emoji} utf16 { test utf-9.7.0 {Tcl_UtfAtIndex: index > 0, Emoji} ucs2 { string range 😀G 1 1 } G -test utf-9.7.1 {Tcl_UtfAtIndex: index > 0, Emoji} ucs4 { +test utf-9.7.1 {Tcl_UtfAtIndex: index > 0, Emoji} utf32 { string range 😀G 1 1 } G test utf-9.7.2 {Tcl_UtfAtIndex: index > 0, Emoji} utf16 { @@ -996,7 +996,7 @@ test utf-9.7.2 {Tcl_UtfAtIndex: index > 0, Emoji} utf16 { test utf-9.8.0 {Tcl_UtfAtIndex: index > 0, Emoji} ucs2 { string range 😀G 2 2 } {} -test utf-9.8.1 {Tcl_UtfAtIndex: index > 0, Emoji} ucs4 { +test utf-9.8.1 {Tcl_UtfAtIndex: index > 0, Emoji} utf32 { string range 😀G 2 2 } {} test utf-9.8.2 {Tcl_UtfAtIndex: index > 0, Emoji} utf16 { @@ -1227,10 +1227,10 @@ test utf-19.1 {TclUniCharLen} -body { unset -nocomplain foo } -result {1 4} -test utf-20.1 {TclUniCharNcmp} ucs4 { +test utf-20.1 {TclUniCharNcmp} utf32 { string compare [string range [format %c 0xFFFF] 0 0] [string range [format %c 0x10000] 0 0] } -1 -test utf-20.2 {[4c591fa487] TclUniCharNcmp/TclUtfNcmp} ucs4 { +test utf-20.2 {[4c591fa487] TclUniCharNcmp/TclUtfNcmp} utf32 { set one [format %c 0xFFFF] set two [format %c 0x10000] set first [string compare $one $two] @@ -1357,10 +1357,10 @@ UniCharCaseCmpTest < a b UniCharCaseCmpTest > b a UniCharCaseCmpTest > B a UniCharCaseCmpTest > aBcB abca -UniCharCaseCmpTest < \uFFFF [format %c 0x10000] ucs4 -UniCharCaseCmpTest < \uFFFF \U10000 ucs4 -UniCharCaseCmpTest > [format %c 0x10000] \uFFFF ucs4 -UniCharCaseCmpTest > \U10000 \uFFFF ucs4 +UniCharCaseCmpTest < \uFFFF [format %c 0x10000] utf32 +UniCharCaseCmpTest < \uFFFF \U10000 utf32 +UniCharCaseCmpTest > [format %c 0x10000] \uFFFF utf32 +UniCharCaseCmpTest > \U10000 \uFFFF utf32 test utf-26.1 {Tcl_UniCharDString} -setup { -- cgit v0.12 From 842ee17d6f2ba6644263a7e2f3335a9e5d613edc Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 22 Mar 2022 16:45:14 +0000 Subject: Reserve 3 more stub entries --- generic/tcl.decls | 2 +- generic/tclDecls.h | 15 ++++++++++++--- generic/tclStubInit.c | 5 ++++- 3 files changed, 17 insertions(+), 5 deletions(-) diff --git a/generic/tcl.decls b/generic/tcl.decls index 01318dd..8536168 100644 --- a/generic/tcl.decls +++ b/generic/tcl.decls @@ -2111,7 +2111,7 @@ declare 579 { # ----- BASELINE -- FOR -- 8.5.0 ----- # -declare 670 { +declare 673 { void TclUnusedStubEntry(void) } diff --git a/generic/tclDecls.h b/generic/tclDecls.h index 10e9fc8..b8b17d2 100644 --- a/generic/tclDecls.h +++ b/generic/tclDecls.h @@ -3502,9 +3502,12 @@ EXTERN void Tcl_AppendPrintfToObj(Tcl_Obj *objPtr, /* Slot 667 is reserved */ /* Slot 668 is reserved */ /* Slot 669 is reserved */ +/* Slot 670 is reserved */ +/* Slot 671 is reserved */ +/* Slot 672 is reserved */ #ifndef TclUnusedStubEntry_TCL_DECLARED #define TclUnusedStubEntry_TCL_DECLARED -/* 670 */ +/* 673 */ EXTERN void TclUnusedStubEntry(void); #endif @@ -4212,7 +4215,10 @@ typedef struct TclStubs { VOID *reserved667; VOID *reserved668; VOID *reserved669; - void (*tclUnusedStubEntry) (void); /* 670 */ + VOID *reserved670; + VOID *reserved671; + VOID *reserved672; + void (*tclUnusedStubEntry) (void); /* 673 */ } TclStubs; extern TclStubs *tclStubsPtr; @@ -6655,9 +6661,12 @@ extern TclStubs *tclStubsPtr; /* Slot 667 is reserved */ /* Slot 668 is reserved */ /* Slot 669 is reserved */ +/* Slot 670 is reserved */ +/* Slot 671 is reserved */ +/* Slot 672 is reserved */ #ifndef TclUnusedStubEntry #define TclUnusedStubEntry \ - (tclStubsPtr->tclUnusedStubEntry) /* 670 */ + (tclStubsPtr->tclUnusedStubEntry) /* 673 */ #endif #endif /* defined(USE_TCL_STUBS) && !defined(USE_TCL_STUB_PROCS) */ diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c index 3859995..e7dc0c1 100644 --- a/generic/tclStubInit.c +++ b/generic/tclStubInit.c @@ -1468,7 +1468,10 @@ TclStubs tclStubs = { NULL, /* 667 */ NULL, /* 668 */ NULL, /* 669 */ - TclUnusedStubEntry, /* 670 */ + NULL, /* 670 */ + NULL, /* 671 */ + NULL, /* 672 */ + TclUnusedStubEntry, /* 673 */ }; /* !END!: Do not edit above this line. */ -- cgit v0.12 From 23f5c44173c5b8ee32b7adb786e2c2124909bfcf Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 22 Mar 2022 16:45:57 +0000 Subject: Update tzdata to 2022a --- library/tzdata/America/Punta_Arenas | 12 +-- library/tzdata/America/Santiago | 14 +-- library/tzdata/Asia/Gaza | 202 ++++++++++++++++++------------------ library/tzdata/Asia/Hebron | 202 ++++++++++++++++++------------------ library/tzdata/Europe/Kiev | 20 ++-- library/tzdata/Europe/Simferopol | 12 +-- library/tzdata/Europe/Uzhgorod | 22 ++-- library/tzdata/Europe/Zaporozhye | 21 ++-- tools/tclZIC.tcl | 4 +- 9 files changed, 255 insertions(+), 254 deletions(-) diff --git a/library/tzdata/America/Punta_Arenas b/library/tzdata/America/Punta_Arenas index 5e8202a..959a0c1 100644 --- a/library/tzdata/America/Punta_Arenas +++ b/library/tzdata/America/Punta_Arenas @@ -2,12 +2,12 @@ set TZData(:America/Punta_Arenas) { {-9223372036854775808 -17020 0 LMT} - {-2524504580 -16966 0 SMT} - {-1892661434 -18000 0 -05} - {-1688410800 -16966 0 SMT} - {-1619205434 -14400 0 -04} - {-1593806400 -16966 0 SMT} - {-1335986234 -18000 0 -05} + {-2524504580 -16965 0 SMT} + {-1892661435 -18000 0 -05} + {-1688410800 -16965 0 SMT} + {-1619205435 -14400 0 -04} + {-1593806400 -16965 0 SMT} + {-1335986235 -18000 0 -05} {-1335985200 -14400 1 -05} {-1317585600 -18000 0 -05} {-1304362800 -14400 1 -05} diff --git a/library/tzdata/America/Santiago b/library/tzdata/America/Santiago index 55212b9..801d3f2 100644 --- a/library/tzdata/America/Santiago +++ b/library/tzdata/America/Santiago @@ -1,13 +1,13 @@ # created by tools/tclZIC.tcl - do not edit set TZData(:America/Santiago) { - {-9223372036854775808 -16966 0 LMT} - {-2524504634 -16966 0 SMT} - {-1892661434 -18000 0 -05} - {-1688410800 -16966 0 SMT} - {-1619205434 -14400 0 -04} - {-1593806400 -16966 0 SMT} - {-1335986234 -18000 0 -05} + {-9223372036854775808 -16965 0 LMT} + {-2524504635 -16965 0 SMT} + {-1892661435 -18000 0 -05} + {-1688410800 -16965 0 SMT} + {-1619205435 -14400 0 -04} + {-1593806400 -16965 0 SMT} + {-1335986235 -18000 0 -05} {-1335985200 -14400 1 -05} {-1317585600 -18000 0 -05} {-1304362800 -14400 1 -05} diff --git a/library/tzdata/Asia/Gaza b/library/tzdata/Asia/Gaza index 86282fa..e819d87 100644 --- a/library/tzdata/Asia/Gaza +++ b/library/tzdata/Asia/Gaza @@ -125,160 +125,160 @@ set TZData(:Asia/Gaza) { {1603490400 7200 0 EET} {1616796000 10800 1 EEST} {1635458400 7200 0 EET} - {1648245600 10800 1 EEST} + {1648332000 10800 1 EEST} {1666908000 7200 0 EET} - {1679695200 10800 1 EEST} + {1679781600 10800 1 EEST} {1698357600 7200 0 EET} - {1711749600 10800 1 EEST} + {1711836000 10800 1 EEST} {1729807200 7200 0 EET} - {1743199200 10800 1 EEST} - {1761861600 7200 0 EET} - {1774648800 10800 1 EEST} - {1793311200 7200 0 EET} - {1806098400 10800 1 EEST} + {1743285600 10800 1 EEST} + {1761256800 7200 0 EET} + {1774735200 10800 1 EEST} + {1792706400 7200 0 EET} + {1806184800 10800 1 EEST} {1824760800 7200 0 EET} - {1837548000 10800 1 EEST} + {1837634400 10800 1 EEST} {1856210400 7200 0 EET} - {1868997600 10800 1 EEST} + {1869084000 10800 1 EEST} {1887660000 7200 0 EET} - {1901052000 10800 1 EEST} + {1901138400 10800 1 EEST} {1919109600 7200 0 EET} - {1932501600 10800 1 EEST} - {1951164000 7200 0 EET} - {1963951200 10800 1 EEST} + {1932588000 10800 1 EEST} + {1950559200 7200 0 EET} + {1964037600 10800 1 EEST} {1982613600 7200 0 EET} - {1995400800 10800 1 EEST} + {1995487200 10800 1 EEST} {2014063200 7200 0 EET} - {2026850400 10800 1 EEST} + {2026936800 10800 1 EEST} {2045512800 7200 0 EET} - {2058300000 10800 1 EEST} + {2058386400 10800 1 EEST} {2076962400 7200 0 EET} - {2090354400 10800 1 EEST} - {2109016800 7200 0 EET} - {2121804000 10800 1 EEST} - {2140466400 7200 0 EET} - {2153253600 10800 1 EEST} + {2090440800 10800 1 EEST} + {2108412000 7200 0 EET} + {2121890400 10800 1 EEST} + {2139861600 7200 0 EET} + {2153340000 10800 1 EEST} {2171916000 7200 0 EET} - {2184703200 10800 1 EEST} + {2184789600 10800 1 EEST} {2203365600 7200 0 EET} - {2216152800 10800 1 EEST} + {2216239200 10800 1 EEST} {2234815200 7200 0 EET} - {2248207200 10800 1 EEST} + {2248293600 10800 1 EEST} {2266264800 7200 0 EET} - {2279656800 10800 1 EEST} - {2298319200 7200 0 EET} - {2311106400 10800 1 EEST} - {2329768800 7200 0 EET} - {2342556000 10800 1 EEST} + {2279743200 10800 1 EEST} + {2297714400 7200 0 EET} + {2311192800 10800 1 EEST} + {2329164000 7200 0 EET} + {2342642400 10800 1 EEST} {2361218400 7200 0 EET} - {2374005600 10800 1 EEST} + {2374092000 10800 1 EEST} {2392668000 7200 0 EET} - {2405455200 10800 1 EEST} + {2405541600 10800 1 EEST} {2424117600 7200 0 EET} - {2437509600 10800 1 EEST} + {2437596000 10800 1 EEST} {2455567200 7200 0 EET} - {2468959200 10800 1 EEST} - {2487621600 7200 0 EET} - {2500408800 10800 1 EEST} + {2469045600 10800 1 EEST} + {2487016800 7200 0 EET} + {2500495200 10800 1 EEST} {2519071200 7200 0 EET} - {2531858400 10800 1 EEST} + {2531944800 10800 1 EEST} {2550520800 7200 0 EET} - {2563308000 10800 1 EEST} + {2563394400 10800 1 EEST} {2581970400 7200 0 EET} - {2595362400 10800 1 EEST} + {2595448800 10800 1 EEST} {2613420000 7200 0 EET} - {2626812000 10800 1 EEST} - {2645474400 7200 0 EET} - {2658261600 10800 1 EEST} - {2676924000 7200 0 EET} - {2689711200 10800 1 EEST} + {2626898400 10800 1 EEST} + {2644869600 7200 0 EET} + {2658348000 10800 1 EEST} + {2676319200 7200 0 EET} + {2689797600 10800 1 EEST} {2708373600 7200 0 EET} - {2721160800 10800 1 EEST} + {2721247200 10800 1 EEST} {2739823200 7200 0 EET} - {2752610400 10800 1 EEST} + {2752696800 10800 1 EEST} {2771272800 7200 0 EET} - {2784664800 10800 1 EEST} + {2784751200 10800 1 EEST} {2802722400 7200 0 EET} - {2816114400 10800 1 EEST} - {2834776800 7200 0 EET} - {2847564000 10800 1 EEST} + {2816200800 10800 1 EEST} + {2834172000 7200 0 EET} + {2847650400 10800 1 EEST} {2866226400 7200 0 EET} - {2879013600 10800 1 EEST} + {2879100000 10800 1 EEST} {2897676000 7200 0 EET} - {2910463200 10800 1 EEST} + {2910549600 10800 1 EEST} {2929125600 7200 0 EET} - {2941912800 10800 1 EEST} + {2941999200 10800 1 EEST} {2960575200 7200 0 EET} - {2973967200 10800 1 EEST} - {2992629600 7200 0 EET} - {3005416800 10800 1 EEST} - {3024079200 7200 0 EET} - {3036866400 10800 1 EEST} + {2974053600 10800 1 EEST} + {2992024800 7200 0 EET} + {3005503200 10800 1 EEST} + {3023474400 7200 0 EET} + {3036952800 10800 1 EEST} {3055528800 7200 0 EET} - {3068316000 10800 1 EEST} + {3068402400 10800 1 EEST} {3086978400 7200 0 EET} - {3099765600 10800 1 EEST} + {3099852000 10800 1 EEST} {3118428000 7200 0 EET} - {3131820000 10800 1 EEST} + {3131906400 10800 1 EEST} {3149877600 7200 0 EET} - {3163269600 10800 1 EEST} - {3181932000 7200 0 EET} - {3194719200 10800 1 EEST} - {3213381600 7200 0 EET} - {3226168800 10800 1 EEST} + {3163356000 10800 1 EEST} + {3181327200 7200 0 EET} + {3194805600 10800 1 EEST} + {3212776800 7200 0 EET} + {3226255200 10800 1 EEST} {3244831200 7200 0 EET} - {3257618400 10800 1 EEST} + {3257704800 10800 1 EEST} {3276280800 7200 0 EET} - {3289068000 10800 1 EEST} + {3289154400 10800 1 EEST} {3307730400 7200 0 EET} - {3321122400 10800 1 EEST} + {3321208800 10800 1 EEST} {3339180000 7200 0 EET} - {3352572000 10800 1 EEST} - {3371234400 7200 0 EET} - {3384021600 10800 1 EEST} + {3352658400 10800 1 EEST} + {3370629600 7200 0 EET} + {3384108000 10800 1 EEST} {3402684000 7200 0 EET} - {3415471200 10800 1 EEST} + {3415557600 10800 1 EEST} {3434133600 7200 0 EET} - {3446920800 10800 1 EEST} + {3447007200 10800 1 EEST} {3465583200 7200 0 EET} - {3478975200 10800 1 EEST} + {3479061600 10800 1 EEST} {3497032800 7200 0 EET} - {3510424800 10800 1 EEST} - {3529087200 7200 0 EET} - {3541874400 10800 1 EEST} - {3560536800 7200 0 EET} - {3573324000 10800 1 EEST} + {3510511200 10800 1 EEST} + {3528482400 7200 0 EET} + {3541960800 10800 1 EEST} + {3559932000 7200 0 EET} + {3573410400 10800 1 EEST} {3591986400 7200 0 EET} - {3604773600 10800 1 EEST} + {3604860000 10800 1 EEST} {3623436000 7200 0 EET} - {3636223200 10800 1 EEST} + {3636309600 10800 1 EEST} {3654885600 7200 0 EET} - {3668277600 10800 1 EEST} + {3668364000 10800 1 EEST} {3686335200 7200 0 EET} - {3699727200 10800 1 EEST} - {3718389600 7200 0 EET} - {3731176800 10800 1 EEST} + {3699813600 10800 1 EEST} + {3717784800 7200 0 EET} + {3731263200 10800 1 EEST} {3749839200 7200 0 EET} - {3762626400 10800 1 EEST} + {3762712800 10800 1 EEST} {3781288800 7200 0 EET} - {3794076000 10800 1 EEST} + {3794162400 10800 1 EEST} {3812738400 7200 0 EET} - {3825525600 10800 1 EEST} + {3825612000 10800 1 EEST} {3844188000 7200 0 EET} - {3857580000 10800 1 EEST} - {3876242400 7200 0 EET} - {3889029600 10800 1 EEST} - {3907692000 7200 0 EET} - {3920479200 10800 1 EEST} + {3857666400 10800 1 EEST} + {3875637600 7200 0 EET} + {3889116000 10800 1 EEST} + {3907087200 7200 0 EET} + {3920565600 10800 1 EEST} {3939141600 7200 0 EET} - {3951928800 10800 1 EEST} + {3952015200 10800 1 EEST} {3970591200 7200 0 EET} - {3983378400 10800 1 EEST} + {3983464800 10800 1 EEST} {4002040800 7200 0 EET} - {4015432800 10800 1 EEST} + {4015519200 10800 1 EEST} {4033490400 7200 0 EET} - {4046882400 10800 1 EEST} - {4065544800 7200 0 EET} - {4078332000 10800 1 EEST} - {4096994400 7200 0 EET} + {4046968800 10800 1 EEST} + {4064940000 7200 0 EET} + {4078418400 10800 1 EEST} + {4096389600 7200 0 EET} } diff --git a/library/tzdata/Asia/Hebron b/library/tzdata/Asia/Hebron index 7559347..b484c6f 100644 --- a/library/tzdata/Asia/Hebron +++ b/library/tzdata/Asia/Hebron @@ -124,160 +124,160 @@ set TZData(:Asia/Hebron) { {1603490400 7200 0 EET} {1616796000 10800 1 EEST} {1635458400 7200 0 EET} - {1648245600 10800 1 EEST} + {1648332000 10800 1 EEST} {1666908000 7200 0 EET} - {1679695200 10800 1 EEST} + {1679781600 10800 1 EEST} {1698357600 7200 0 EET} - {1711749600 10800 1 EEST} + {1711836000 10800 1 EEST} {1729807200 7200 0 EET} - {1743199200 10800 1 EEST} - {1761861600 7200 0 EET} - {1774648800 10800 1 EEST} - {1793311200 7200 0 EET} - {1806098400 10800 1 EEST} + {1743285600 10800 1 EEST} + {1761256800 7200 0 EET} + {1774735200 10800 1 EEST} + {1792706400 7200 0 EET} + {1806184800 10800 1 EEST} {1824760800 7200 0 EET} - {1837548000 10800 1 EEST} + {1837634400 10800 1 EEST} {1856210400 7200 0 EET} - {1868997600 10800 1 EEST} + {1869084000 10800 1 EEST} {1887660000 7200 0 EET} - {1901052000 10800 1 EEST} + {1901138400 10800 1 EEST} {1919109600 7200 0 EET} - {1932501600 10800 1 EEST} - {1951164000 7200 0 EET} - {1963951200 10800 1 EEST} + {1932588000 10800 1 EEST} + {1950559200 7200 0 EET} + {1964037600 10800 1 EEST} {1982613600 7200 0 EET} - {1995400800 10800 1 EEST} + {1995487200 10800 1 EEST} {2014063200 7200 0 EET} - {2026850400 10800 1 EEST} + {2026936800 10800 1 EEST} {2045512800 7200 0 EET} - {2058300000 10800 1 EEST} + {2058386400 10800 1 EEST} {2076962400 7200 0 EET} - {2090354400 10800 1 EEST} - {2109016800 7200 0 EET} - {2121804000 10800 1 EEST} - {2140466400 7200 0 EET} - {2153253600 10800 1 EEST} + {2090440800 10800 1 EEST} + {2108412000 7200 0 EET} + {2121890400 10800 1 EEST} + {2139861600 7200 0 EET} + {2153340000 10800 1 EEST} {2171916000 7200 0 EET} - {2184703200 10800 1 EEST} + {2184789600 10800 1 EEST} {2203365600 7200 0 EET} - {2216152800 10800 1 EEST} + {2216239200 10800 1 EEST} {2234815200 7200 0 EET} - {2248207200 10800 1 EEST} + {2248293600 10800 1 EEST} {2266264800 7200 0 EET} - {2279656800 10800 1 EEST} - {2298319200 7200 0 EET} - {2311106400 10800 1 EEST} - {2329768800 7200 0 EET} - {2342556000 10800 1 EEST} + {2279743200 10800 1 EEST} + {2297714400 7200 0 EET} + {2311192800 10800 1 EEST} + {2329164000 7200 0 EET} + {2342642400 10800 1 EEST} {2361218400 7200 0 EET} - {2374005600 10800 1 EEST} + {2374092000 10800 1 EEST} {2392668000 7200 0 EET} - {2405455200 10800 1 EEST} + {2405541600 10800 1 EEST} {2424117600 7200 0 EET} - {2437509600 10800 1 EEST} + {2437596000 10800 1 EEST} {2455567200 7200 0 EET} - {2468959200 10800 1 EEST} - {2487621600 7200 0 EET} - {2500408800 10800 1 EEST} + {2469045600 10800 1 EEST} + {2487016800 7200 0 EET} + {2500495200 10800 1 EEST} {2519071200 7200 0 EET} - {2531858400 10800 1 EEST} + {2531944800 10800 1 EEST} {2550520800 7200 0 EET} - {2563308000 10800 1 EEST} + {2563394400 10800 1 EEST} {2581970400 7200 0 EET} - {2595362400 10800 1 EEST} + {2595448800 10800 1 EEST} {2613420000 7200 0 EET} - {2626812000 10800 1 EEST} - {2645474400 7200 0 EET} - {2658261600 10800 1 EEST} - {2676924000 7200 0 EET} - {2689711200 10800 1 EEST} + {2626898400 10800 1 EEST} + {2644869600 7200 0 EET} + {2658348000 10800 1 EEST} + {2676319200 7200 0 EET} + {2689797600 10800 1 EEST} {2708373600 7200 0 EET} - {2721160800 10800 1 EEST} + {2721247200 10800 1 EEST} {2739823200 7200 0 EET} - {2752610400 10800 1 EEST} + {2752696800 10800 1 EEST} {2771272800 7200 0 EET} - {2784664800 10800 1 EEST} + {2784751200 10800 1 EEST} {2802722400 7200 0 EET} - {2816114400 10800 1 EEST} - {2834776800 7200 0 EET} - {2847564000 10800 1 EEST} + {2816200800 10800 1 EEST} + {2834172000 7200 0 EET} + {2847650400 10800 1 EEST} {2866226400 7200 0 EET} - {2879013600 10800 1 EEST} + {2879100000 10800 1 EEST} {2897676000 7200 0 EET} - {2910463200 10800 1 EEST} + {2910549600 10800 1 EEST} {2929125600 7200 0 EET} - {2941912800 10800 1 EEST} + {2941999200 10800 1 EEST} {2960575200 7200 0 EET} - {2973967200 10800 1 EEST} - {2992629600 7200 0 EET} - {3005416800 10800 1 EEST} - {3024079200 7200 0 EET} - {3036866400 10800 1 EEST} + {2974053600 10800 1 EEST} + {2992024800 7200 0 EET} + {3005503200 10800 1 EEST} + {3023474400 7200 0 EET} + {3036952800 10800 1 EEST} {3055528800 7200 0 EET} - {3068316000 10800 1 EEST} + {3068402400 10800 1 EEST} {3086978400 7200 0 EET} - {3099765600 10800 1 EEST} + {3099852000 10800 1 EEST} {3118428000 7200 0 EET} - {3131820000 10800 1 EEST} + {3131906400 10800 1 EEST} {3149877600 7200 0 EET} - {3163269600 10800 1 EEST} - {3181932000 7200 0 EET} - {3194719200 10800 1 EEST} - {3213381600 7200 0 EET} - {3226168800 10800 1 EEST} + {3163356000 10800 1 EEST} + {3181327200 7200 0 EET} + {3194805600 10800 1 EEST} + {3212776800 7200 0 EET} + {3226255200 10800 1 EEST} {3244831200 7200 0 EET} - {3257618400 10800 1 EEST} + {3257704800 10800 1 EEST} {3276280800 7200 0 EET} - {3289068000 10800 1 EEST} + {3289154400 10800 1 EEST} {3307730400 7200 0 EET} - {3321122400 10800 1 EEST} + {3321208800 10800 1 EEST} {3339180000 7200 0 EET} - {3352572000 10800 1 EEST} - {3371234400 7200 0 EET} - {3384021600 10800 1 EEST} + {3352658400 10800 1 EEST} + {3370629600 7200 0 EET} + {3384108000 10800 1 EEST} {3402684000 7200 0 EET} - {3415471200 10800 1 EEST} + {3415557600 10800 1 EEST} {3434133600 7200 0 EET} - {3446920800 10800 1 EEST} + {3447007200 10800 1 EEST} {3465583200 7200 0 EET} - {3478975200 10800 1 EEST} + {3479061600 10800 1 EEST} {3497032800 7200 0 EET} - {3510424800 10800 1 EEST} - {3529087200 7200 0 EET} - {3541874400 10800 1 EEST} - {3560536800 7200 0 EET} - {3573324000 10800 1 EEST} + {3510511200 10800 1 EEST} + {3528482400 7200 0 EET} + {3541960800 10800 1 EEST} + {3559932000 7200 0 EET} + {3573410400 10800 1 EEST} {3591986400 7200 0 EET} - {3604773600 10800 1 EEST} + {3604860000 10800 1 EEST} {3623436000 7200 0 EET} - {3636223200 10800 1 EEST} + {3636309600 10800 1 EEST} {3654885600 7200 0 EET} - {3668277600 10800 1 EEST} + {3668364000 10800 1 EEST} {3686335200 7200 0 EET} - {3699727200 10800 1 EEST} - {3718389600 7200 0 EET} - {3731176800 10800 1 EEST} + {3699813600 10800 1 EEST} + {3717784800 7200 0 EET} + {3731263200 10800 1 EEST} {3749839200 7200 0 EET} - {3762626400 10800 1 EEST} + {3762712800 10800 1 EEST} {3781288800 7200 0 EET} - {3794076000 10800 1 EEST} + {3794162400 10800 1 EEST} {3812738400 7200 0 EET} - {3825525600 10800 1 EEST} + {3825612000 10800 1 EEST} {3844188000 7200 0 EET} - {3857580000 10800 1 EEST} - {3876242400 7200 0 EET} - {3889029600 10800 1 EEST} - {3907692000 7200 0 EET} - {3920479200 10800 1 EEST} + {3857666400 10800 1 EEST} + {3875637600 7200 0 EET} + {3889116000 10800 1 EEST} + {3907087200 7200 0 EET} + {3920565600 10800 1 EEST} {3939141600 7200 0 EET} - {3951928800 10800 1 EEST} + {3952015200 10800 1 EEST} {3970591200 7200 0 EET} - {3983378400 10800 1 EEST} + {3983464800 10800 1 EEST} {4002040800 7200 0 EET} - {4015432800 10800 1 EEST} + {4015519200 10800 1 EEST} {4033490400 7200 0 EET} - {4046882400 10800 1 EEST} - {4065544800 7200 0 EET} - {4078332000 10800 1 EEST} - {4096994400 7200 0 EET} + {4046968800 10800 1 EEST} + {4064940000 7200 0 EET} + {4078418400 10800 1 EEST} + {4096389600 7200 0 EET} } diff --git a/library/tzdata/Europe/Kiev b/library/tzdata/Europe/Kiev index 55015fa..8da7061 100644 --- a/library/tzdata/Europe/Kiev +++ b/library/tzdata/Europe/Kiev @@ -31,16 +31,16 @@ set TZData(:Europe/Kiev) { {638319600 14400 1 MSD} {646786800 10800 1 EEST} {686102400 7200 0 EET} - {701820000 10800 1 EEST} - {717541200 7200 0 EET} - {733269600 10800 1 EEST} - {748990800 7200 0 EET} - {764719200 10800 1 EEST} - {780440400 7200 0 EET} - {788911200 7200 0 EET} - {796179600 10800 1 EEST} - {811904400 7200 0 EET} - {828234000 10800 1 EEST} + {701827200 10800 1 EEST} + {717552000 7200 0 EET} + {733276800 10800 1 EEST} + {749001600 7200 0 EET} + {764726400 10800 1 EEST} + {780451200 7200 0 EET} + {796176000 10800 1 EEST} + {811900800 7200 0 EET} + {828230400 10800 1 EEST} + {831938400 10800 0 EEST} {846378000 7200 0 EET} {859683600 10800 1 EEST} {877827600 7200 0 EET} diff --git a/library/tzdata/Europe/Simferopol b/library/tzdata/Europe/Simferopol index 3e4b60a..e296862 100644 --- a/library/tzdata/Europe/Simferopol +++ b/library/tzdata/Europe/Simferopol @@ -31,12 +31,12 @@ set TZData(:Europe/Simferopol) { {622594800 10800 0 MSK} {631141200 10800 0 MSK} {646786800 7200 0 EET} - {694216800 7200 0 EET} - {701820000 10800 1 EEST} - {717541200 7200 0 EET} - {733269600 10800 1 EEST} - {748990800 7200 0 EET} - {764719200 10800 1 EEST} + {701042400 7200 0 EET} + {701827200 10800 1 EEST} + {717552000 7200 0 EET} + {733276800 10800 1 EEST} + {749001600 7200 0 EET} + {764726400 10800 1 EEST} {767743200 14400 0 MSD} {780436800 10800 0 MSK} {796165200 14400 1 MSD} diff --git a/library/tzdata/Europe/Uzhgorod b/library/tzdata/Europe/Uzhgorod index f6e580b..0a058db 100644 --- a/library/tzdata/Europe/Uzhgorod +++ b/library/tzdata/Europe/Uzhgorod @@ -33,17 +33,17 @@ set TZData(:Europe/Uzhgorod) { {631141200 10800 0 MSK} {646786800 3600 0 CET} {670384800 7200 0 EET} - {694216800 7200 0 EET} - {701820000 10800 1 EEST} - {717541200 7200 0 EET} - {733269600 10800 1 EEST} - {748990800 7200 0 EET} - {764719200 10800 1 EEST} - {780440400 7200 0 EET} - {788911200 7200 0 EET} - {796179600 10800 1 EEST} - {811904400 7200 0 EET} - {828234000 10800 1 EEST} + {701042400 7200 0 EET} + {701827200 10800 1 EEST} + {717552000 7200 0 EET} + {733276800 10800 1 EEST} + {749001600 7200 0 EET} + {764726400 10800 1 EEST} + {780451200 7200 0 EET} + {796176000 10800 1 EEST} + {811900800 7200 0 EET} + {828230400 10800 1 EEST} + {831938400 10800 0 EEST} {846378000 7200 0 EET} {859683600 10800 1 EEST} {877827600 7200 0 EET} diff --git a/library/tzdata/Europe/Zaporozhye b/library/tzdata/Europe/Zaporozhye index 478a61c..8ae9604 100644 --- a/library/tzdata/Europe/Zaporozhye +++ b/library/tzdata/Europe/Zaporozhye @@ -32,16 +32,17 @@ set TZData(:Europe/Zaporozhye) { {654649200 10800 0 MSK} {670374000 10800 0 EEST} {686091600 7200 0 EET} - {701820000 10800 1 EEST} - {717541200 7200 0 EET} - {733269600 10800 1 EEST} - {748990800 7200 0 EET} - {764719200 10800 1 EEST} - {780440400 7200 0 EET} - {788911200 7200 0 EET} - {796179600 10800 1 EEST} - {811904400 7200 0 EET} - {828234000 10800 1 EEST} + {701042400 7200 0 EET} + {701827200 10800 1 EEST} + {717552000 7200 0 EET} + {733276800 10800 1 EEST} + {749001600 7200 0 EET} + {764726400 10800 1 EEST} + {780451200 7200 0 EET} + {796176000 10800 1 EEST} + {811900800 7200 0 EET} + {828230400 10800 1 EEST} + {831938400 10800 0 EEST} {846378000 7200 0 EET} {859683600 10800 1 EEST} {877827600 7200 0 EET} diff --git a/tools/tclZIC.tcl b/tools/tclZIC.tcl index 85c9ba9..6b7d97a 100755 --- a/tools/tclZIC.tcl +++ b/tools/tclZIC.tcl @@ -3,14 +3,14 @@ # tclZIC.tcl -- # # Take the time zone data source files from Arthur Olson's -# repository at elsie.nci.nih.gov, and prepare time zone +# repository at https://www.iana.org/time-zones, and prepare time zone # information files for Tcl. # # Usage: # tclsh tclZIC.tcl inputDir outputDir # # Parameters: -# inputDir - Directory (e.g., tzdata2003e) where Olson's source +# inputDir - Directory (e.g., tzdata2022a) where Olson's source # files are to be found. # outputDir - Directory (e.g., ../library/tzdata) where # the time zone information files are to be placed. -- cgit v0.12 From f13079289a274d0195bb0a57b34fa61bd1775e28 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 22 Mar 2022 17:06:57 +0000 Subject: Put back TclNumUtfChars (as TclNumUtfCharsM) macro for speedup --- generic/tclInt.h | 2 +- generic/tclStringObj.c | 8 ++++---- 2 files changed, 5 insertions(+), 5 deletions(-) diff --git a/generic/tclInt.h b/generic/tclInt.h index 055c497..8c6d5f0 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -4668,7 +4668,7 @@ MODULE_SCOPE const TclFileAttrProcs tclpFileAttrProcs[]; *---------------------------------------------------------------- */ -#define TclNumUtfChars_NOTUSED(numChars, bytes, numBytes) \ +#define TclNumUtfCharsM(numChars, bytes, numBytes) \ do { \ size_t _count, _i = (numBytes); \ unsigned char *_str = (unsigned char *) (bytes); \ diff --git a/generic/tclStringObj.c b/generic/tclStringObj.c index 76d43a6..7e65ef1 100644 --- a/generic/tclStringObj.c +++ b/generic/tclStringObj.c @@ -441,7 +441,7 @@ Tcl_GetCharLength( */ if (numChars == TCL_INDEX_NONE) { - numChars = Tcl_NumUtfChars(objPtr->bytes, objPtr->length); + TclNumUtfCharsM(numChars, objPtr->bytes, objPtr->length); stringPtr->numChars = numChars; } return numChars; @@ -581,7 +581,7 @@ Tcl_GetUniChar( */ if (stringPtr->numChars == TCL_INDEX_NONE) { - stringPtr->numChars = Tcl_NumUtfChars(objPtr->bytes, objPtr->length); + TclNumUtfCharsM(stringPtr->numChars, objPtr->bytes, objPtr->length); } if (stringPtr->numChars == objPtr->length) { return (unsigned char) objPtr->bytes[index]; @@ -747,7 +747,7 @@ Tcl_GetRange( */ if (stringPtr->numChars == TCL_INDEX_NONE) { - stringPtr->numChars = Tcl_NumUtfChars(objPtr->bytes, objPtr->length); + TclNumUtfCharsM(stringPtr->numChars, objPtr->bytes, objPtr->length); } if (stringPtr->numChars == objPtr->length) { if (last >= stringPtr->numChars) { @@ -4083,7 +4083,7 @@ ExtendUnicodeRepWithString( numOrigChars = stringPtr->numChars; } if (numAppendChars == TCL_INDEX_NONE) { - numAppendChars = Tcl_NumUtfChars(bytes, numBytes); + TclNumUtfCharsM(numAppendChars, bytes, numBytes); } needed = numOrigChars + numAppendChars; -- cgit v0.12 From 7b333ba9056bfea7a16de7fa67405a0a9279de14 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 22 Mar 2022 19:48:53 +0000 Subject: Fix [0e8fd6c6d5]: (unsigned)STRING_SIZE(STRING_MAXCHARS) is 0 (and optimize STRING_SIZE a little bit) --- generic/tclStringRep.h | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/generic/tclStringRep.h b/generic/tclStringRep.h index c0adc10..dc33f4b 100644 --- a/generic/tclStringRep.h +++ b/generic/tclStringRep.h @@ -65,9 +65,9 @@ typedef struct String { } String; #define STRING_MAXCHARS \ - (int)(((size_t)UINT_MAX - 1 - TclOffset(String, unicode))/sizeof(Tcl_UniChar)) + (int)(((size_t)UINT_MAX - TclOffset(String, unicode))/sizeof(Tcl_UniChar) - 1) #define STRING_SIZE(numChars) \ - (TclOffset(String, unicode) + (((numChars) + 1U) * sizeof(Tcl_UniChar))) + (TclOffset(String, unicode) + sizeof(Tcl_UniChar) + ((numChars) * sizeof(Tcl_UniChar))) #define stringCheckLimits(numChars) \ do { \ if ((numChars) < 0 || (numChars) > STRING_MAXCHARS) { \ -- cgit v0.12 From 4fcff1f053c279076fb2bc1507dac8a26b3c562b Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 22 Mar 2022 23:18:23 +0000 Subject: Simplyfy Tcl_UtfAtIndex --- generic/tclUtf.c | 25 ++++++------------------- 1 file changed, 6 insertions(+), 19 deletions(-) diff --git a/generic/tclUtf.c b/generic/tclUtf.c index 6c6940c..09e464f 100644 --- a/generic/tclUtf.c +++ b/generic/tclUtf.c @@ -1226,25 +1226,12 @@ Tcl_UtfAtIndex( const char *src, /* The UTF-8 string. */ size_t index) /* The position of the desired character. */ { - Tcl_UniChar ch = 0; -#if TCL_UTF_MAX < 4 - size_t len = 0; -#endif + int ch = 0; if (index != TCL_INDEX_NONE) { while (index--) { -#if TCL_UTF_MAX < 4 - src += (len = TclUtfToUniChar(src, &ch)); -#else - src += TclUtfToUniChar(src, &ch); -#endif + src += Tcl_UtfToUniChar(src, &ch); } -#if TCL_UTF_MAX < 4 - if ((ch >= 0xD800) && (len < 3)) { - /* Index points at character following high Surrogate */ - src += TclUtfToUniChar(src, &ch); - } -#endif } return src; } @@ -1261,10 +1248,10 @@ TclUtfAtIndex( while (index--) { src += (len = Tcl_UtfToChar16(src, &ch)); } - if ((ch >= 0xD800) && (len < 3)) { - /* Index points at character following high Surrogate */ - src += Tcl_UtfToChar16(src, &ch); - } + if ((ch >= 0xD800) && (len < 3)) { + /* Index points at character following high Surrogate */ + src += Tcl_UtfToChar16(src, &ch); + } } return src; } -- cgit v0.12 From 1f3d3d7671748e4eb36cc0846e3e953bdb29c227 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 23 Mar 2022 13:31:43 +0000 Subject: Fix crash in (compabitility) "string" objType --- generic/tclStringObj.c | 13 +++++++------ 1 file changed, 7 insertions(+), 6 deletions(-) diff --git a/generic/tclStringObj.c b/generic/tclStringObj.c index d43c507..9655479 100644 --- a/generic/tclStringObj.c +++ b/generic/tclStringObj.c @@ -208,13 +208,14 @@ SetUTF16StringFromAny( Tcl_DStringInit(&ds); unsigned short *utf16string = Tcl_UtfToChar16DString(objPtr->bytes, objPtr->length, &ds); - size_t size = Tcl_DStringLength(&ds); - String *stringPtr = (String *)ckalloc((offsetof(String, unicode) + 2U) + size); + int size = Tcl_DStringLength(&ds); + String *stringPtr = (String *)ckalloc((offsetof(String, unicode) + sizeof(unsigned short)) + size); + memcpy(stringPtr->unicode, utf16string, size); - stringPtr->unicode[size] = 0; Tcl_DStringFree(&ds); - size /= sizeof(unsigned short); + stringPtr->unicode[size] = 0; + stringPtr->numChars = size; stringPtr->allocated = size; stringPtr->maxChars = size; @@ -222,7 +223,7 @@ SetUTF16StringFromAny( objPtr->internalRep.twoPtrValue.ptr1 = stringPtr; objPtr->typePtr = &tclStringType; } - return TCL_OK; + return TCL_OK; } static void @@ -237,10 +238,10 @@ UpdateStringOfUTF16String( char *bytes = (char *)ckalloc(Tcl_DStringLength(&ds) + 1U); memcpy(bytes, string, Tcl_DStringLength(&ds)); + bytes[Tcl_DStringLength(&ds)] = 0; Tcl_DStringFree(&ds); objPtr->bytes = bytes; objPtr->length = Tcl_DStringLength(&ds); - printf("UpdateStringOfUTF16String %d %d\n", stringPtr->unicode[0], stringPtr->unicode[1]); } #endif -- cgit v0.12 From 369bc9b1594ea304387a97eef5658a5998699534 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 23 Mar 2022 14:32:08 +0000 Subject: Fix Tcl_UniCharAtIndex() for UTF-16 compabitility layer --- generic/tclUtf.c | 6 ++---- 1 file changed, 2 insertions(+), 4 deletions(-) diff --git a/generic/tclUtf.c b/generic/tclUtf.c index eda317f..cfd9915 100644 --- a/generic/tclUtf.c +++ b/generic/tclUtf.c @@ -1182,22 +1182,20 @@ Tcl_UniCharAtIndex( const char *src, /* The UTF-8 string to dereference. */ int index) /* The position of the desired character. */ { - Tcl_UniChar ch = 0; + unsigned short ch = 0; int i = 0; if (index < 0) { return -1; } while (index-- > 0) { - i = TclUtfToUniChar(src, &ch); + i = Tcl_UtfToChar16(src, &ch); src += i; } -#if TCL_UTF_MAX < 4 if ((ch >= 0xD800) && (i < 3)) { /* Index points at character following high Surrogate */ return -1; } -#endif TclUtfToUCS4(src, &i); return i; } -- cgit v0.12 From af426f828e2e3391d7b4ed399040300821a156e9 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 23 Mar 2022 16:19:54 +0000 Subject: Put back TclNumUtfChars() macro as TclNumUtfCharsM() --- generic/tclInt.h | 4 ++-- generic/tclStringObj.c | 26 +++++++++++++------------- 2 files changed, 15 insertions(+), 15 deletions(-) diff --git a/generic/tclInt.h b/generic/tclInt.h index 73d6386..3aa2626 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -4768,14 +4768,14 @@ MODULE_SCOPE const TclFileAttrProcs tclpFileAttrProcs[]; *---------------------------------------------------------------- */ -#define TclNumUtfChars_UNUSED(numChars, bytes, numBytes) \ +#define TclNumUtfCharsM(numChars, bytes, numBytes) \ do { \ int _count, _i = (numBytes); \ unsigned char *_str = (unsigned char *) (bytes); \ while (_i && (*_str < 0xC0)) { _i--; _str++; } \ _count = (numBytes) - _i; \ if (_i) { \ - _count += Tcl_NumUtfChars((bytes) + _count, _i); \ + _count += TclNumUtfChars((bytes) + _count, _i); \ } \ (numChars) = _count; \ } while (0); diff --git a/generic/tclStringObj.c b/generic/tclStringObj.c index 9655479..784ed44 100644 --- a/generic/tclStringObj.c +++ b/generic/tclStringObj.c @@ -55,14 +55,14 @@ static void AppendUtfToUtfRep(Tcl_Obj *objPtr, const char *bytes, int numBytes); static void DupStringInternalRep(Tcl_Obj *objPtr, Tcl_Obj *copyPtr); -static int ExtendUniCharStringRepWithUniCharString(Tcl_Obj *objPtr, +static int ExtendStringRepWithUnicode(Tcl_Obj *objPtr, const Tcl_UniChar *unicode, int numChars); static void ExtendUnicodeRepWithString(Tcl_Obj *objPtr, const char *bytes, int numBytes, int numAppendChars); static void FillUnicodeRep(Tcl_Obj *objPtr); static void FreeStringInternalRep(Tcl_Obj *objPtr); -static void GrowUniCharStringBuffer(Tcl_Obj *objPtr, int needed, int flag); +static void GrowStringBuffer(Tcl_Obj *objPtr, int needed, int flag); static void GrowUnicodeBuffer(Tcl_Obj *objPtr, int needed); static int SetStringFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr); static void SetUnicodeObj(Tcl_Obj *objPtr, @@ -284,7 +284,7 @@ UpdateStringOfUTF16String( #endif static void -GrowUniCharStringBuffer( +GrowStringBuffer( Tcl_Obj *objPtr, int needed, int flag) @@ -638,7 +638,7 @@ TclGetCharLength( */ if (numChars == -1) { - numChars = Tcl_NumUtfChars(objPtr->bytes, objPtr->length); + TclNumUtfCharsM(numChars, objPtr->bytes, objPtr->length); stringPtr->numChars = numChars; } return numChars; @@ -783,7 +783,7 @@ Tcl_GetUniChar( */ if (stringPtr->numChars == -1) { - stringPtr->numChars = Tcl_NumUtfChars(objPtr->bytes, objPtr->length); + TclNumUtfCharsM(stringPtr->numChars, objPtr->bytes, objPtr->length); } if (stringPtr->numChars == objPtr->length) { return (unsigned char) objPtr->bytes[index]; @@ -928,7 +928,7 @@ TclGetUnicodeFromObj( } return stringPtr->unicode; } - + /* *---------------------------------------------------------------------- * @@ -992,7 +992,7 @@ Tcl_GetRange( */ if (stringPtr->numChars == -1) { - stringPtr->numChars = Tcl_NumUtfChars(objPtr->bytes, objPtr->length); + TclNumUtfCharsM(stringPtr->numChars, objPtr->bytes, objPtr->length); } if (stringPtr->numChars == objPtr->length) { if (last < 0 || last >= stringPtr->numChars) { @@ -1884,7 +1884,7 @@ AppendUnicodeToUtfRep( { UniCharString *stringPtr = GET_UNICHAR_STRING(objPtr); - numChars = ExtendUniCharStringRepWithUniCharString(objPtr, unicode, numChars); + numChars = ExtendStringRepWithUnicode(objPtr, unicode, numChars); if (stringPtr->numChars != -1) { stringPtr->numChars += numChars; @@ -1992,7 +1992,7 @@ AppendUtfToUtfRep( * would make test stringObj-8.1 fail. */ - GrowUniCharStringBuffer(objPtr, newLength, 0); + GrowStringBuffer(objPtr, newLength, 0); /* * Relocate bytes if needed; see above. @@ -4448,7 +4448,7 @@ ExtendUnicodeRepWithString( numOrigChars = stringPtr->numChars; } if (numAppendChars == -1) { - numAppendChars = Tcl_NumUtfChars(bytes, numBytes); + TclNumUtfCharsM(numAppendChars, bytes, numBytes); } needed = numOrigChars + numAppendChars; uniCharStringCheckLimits(needed); @@ -4643,13 +4643,13 @@ UpdateStringOfString( if (stringPtr->numChars == 0) { TclInitStringRep(objPtr, NULL, 0); } else { - (void) ExtendUniCharStringRepWithUniCharString(objPtr, stringPtr->unicode, + (void) ExtendStringRepWithUnicode(objPtr, stringPtr->unicode, stringPtr->numChars); } } static int -ExtendUniCharStringRepWithUniCharString( +ExtendStringRepWithUnicode( Tcl_Obj *objPtr, const Tcl_UniChar *unicode, int numChars) @@ -4696,7 +4696,7 @@ ExtendUniCharStringRepWithUniCharString( */ if (size > stringPtr->allocated) { - GrowUniCharStringBuffer(objPtr, size, 1); + GrowStringBuffer(objPtr, size, 1); } copyBytes: -- cgit v0.12 From 66cbd6ac71e01082f9e8b0e088cd829defdf9886 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 23 Mar 2022 16:33:41 +0000 Subject: Fix for UpdateStringOfUTF16String() --- generic/tclStringObj.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/generic/tclStringObj.c b/generic/tclStringObj.c index 784ed44..17c7067 100644 --- a/generic/tclStringObj.c +++ b/generic/tclStringObj.c @@ -239,9 +239,9 @@ UpdateStringOfUTF16String( char *bytes = (char *)ckalloc(Tcl_DStringLength(&ds) + 1U); memcpy(bytes, string, Tcl_DStringLength(&ds)); bytes[Tcl_DStringLength(&ds)] = 0; - Tcl_DStringFree(&ds); objPtr->bytes = bytes; objPtr->length = Tcl_DStringLength(&ds); + Tcl_DStringFree(&ds); } #endif -- cgit v0.12 From 71640ac39f283c3c6d7357ad47c296427bf1b156 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 23 Mar 2022 17:22:52 +0000 Subject: More progress --- generic/regc_cvec.c | 12 ++++++------ generic/regcomp.c | 4 ++-- generic/regguts.h | 18 +++++++++--------- generic/tclCompile.c | 2 +- generic/tclInt.h | 15 ++++++++++----- generic/tclProc.c | 2 +- 6 files changed, 29 insertions(+), 24 deletions(-) diff --git a/generic/regc_cvec.c b/generic/regc_cvec.c index 3b4f1e4..468b1a1 100644 --- a/generic/regc_cvec.c +++ b/generic/regc_cvec.c @@ -36,14 +36,14 @@ /* - newcvec - allocate a new cvec - ^ static struct cvec *newcvec(int, int); + ^ static struct cvec *newcvec(size_t, size_t); */ static struct cvec * newcvec( - int nchrs, /* to hold this many chrs... */ - int nranges) /* ... and this many ranges... */ + size_t nchrs, /* to hold this many chrs... */ + size_t nranges) /* ... and this many ranges... */ { - size_t nc = (size_t)nchrs + (size_t)nranges*2; + size_t nc = nchrs + nranges*2; size_t n = sizeof(struct cvec) + nc*sizeof(chr); struct cvec *cv = (struct cvec *) MALLOC(n); @@ -108,8 +108,8 @@ addrange( static struct cvec * getcvec( struct vars *v, /* context */ - int nchrs, /* to hold this many chrs... */ - int nranges) /* ... and this many ranges... */ + size_t nchrs, /* to hold this many chrs... */ + size_t nranges) /* ... and this many ranges... */ { if ((v->cv != NULL) && (nchrs <= v->cv->chrspace) && (nranges <= v->cv->rangespace)) { diff --git a/generic/regcomp.c b/generic/regcomp.c index 4a107a8..e09bae9 100644 --- a/generic/regcomp.c +++ b/generic/regcomp.c @@ -179,8 +179,8 @@ static void dumpcstate(int, struct cnfa *, FILE *); static struct cvec *clearcvec(struct cvec *); static void addchr(struct cvec *, pchr); static void addrange(struct cvec *, pchr, pchr); -static struct cvec *newcvec(int, int); -static struct cvec *getcvec(struct vars *, int, int); +static struct cvec *newcvec(size_t, size_t); +static struct cvec *getcvec(struct vars *, size_t, size_t); static void freecvec(struct cvec *); /* === regc_locale.c === */ static celt element(struct vars *, const chr *, const chr *); diff --git a/generic/regguts.h b/generic/regguts.h index de5d18e..fd74e7a 100644 --- a/generic/regguts.h +++ b/generic/regguts.h @@ -203,11 +203,11 @@ struct colormap { /* Representation of a set of characters. */ struct cvec { - int nchrs; /* number of chrs */ - int chrspace; /* number of chrs possible */ + size_t nchrs; /* number of chrs */ + size_t chrspace; /* number of chrs possible */ chr *chrs; /* pointer to vector of chrs */ - int nranges; /* number of ranges (chr pairs) */ - int rangespace; /* number of chrs possible */ + size_t nranges; /* number of ranges (chr pairs) */ + size_t rangespace; /* number of chrs possible */ chr *ranges; /* pointer to vector of chr pairs */ }; @@ -245,16 +245,16 @@ struct state { int no; #define FREESTATE (-1) char flag; /* marks special states */ - int nins; /* number of inarcs */ + size_t nins; /* number of inarcs */ struct arc *ins; /* chain of inarcs */ - int nouts; /* number of outarcs */ + size_t nouts; /* number of outarcs */ struct arc *outs; /* chain of outarcs */ struct arc *free; /* chain of free arcs */ struct state *tmp; /* temporary for traversal algorithms */ struct state *next; /* chain for traversing all */ struct state *prev; /* back chain */ struct arcbatch oas; /* first arcbatch, avoid malloc in easy case */ - int noas; /* number of arcs used in first arcbatch */ + size_t noas; /* number of arcs used in first arcbatch */ }; struct nfa { @@ -396,11 +396,11 @@ struct guts { size_t nsub; /* copy of re_nsub */ struct subre *tree; struct cnfa search; /* for fast preliminary search */ - int ntree; /* number of subre's, plus one */ + size_t ntree; /* number of subre's, plus one */ struct colormap cmap; int (*compare) (const chr *, const chr *, size_t); struct subre *lacons; /* lookahead-constraint vector */ - int nlacons; /* size of lacons */ + size_t nlacons; /* size of lacons */ }; /* diff --git a/generic/tclCompile.c b/generic/tclCompile.c index e23b0e6..4eb1a15 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -2990,7 +2990,7 @@ TclFindCompiledLocal( CompileEnv *envPtr) /* Points to the current compile environment*/ { CompiledLocal *localPtr; - int localVar = -1; + size_t localVar = TCL_INDEX_NONE; size_t i; Proc *procPtr; diff --git a/generic/tclInt.h b/generic/tclInt.h index 964822a..874d9c8 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -940,12 +940,11 @@ typedef struct CompiledLocal { * local. */ size_t nameLength; /* The number of bytes in local variable's name. * Among others used to speed up var lookups. */ - int frameIndex; /* Index in the array of compiler-assigned + size_t frameIndex; /* Index in the array of compiler-assigned * variables in the procedure call frame. */ - int flags; /* Flag bits for the local variable. Same as - * the flags for the Var structure above, - * although only VAR_ARGUMENT, VAR_TEMPORARY, - * and VAR_RESOLVED make sense. */ +#if TCL_UTF_MAX < 9 + int flags; +#endif Tcl_Obj *defValuePtr; /* Pointer to the default value of an * argument, if any. NULL if not an argument * or, if an argument, no default value. */ @@ -956,6 +955,12 @@ typedef struct CompiledLocal { * is marked by a unique tag during * compilation, and that same tag is used to * find the variable at runtime. */ +#if TCL_UTF_MAX > 8 + int flags; /* Flag bits for the local variable. Same as + * the flags for the Var structure above, + * although only VAR_ARGUMENT, VAR_TEMPORARY, + * and VAR_RESOLVED make sense. */ +#endif char name[TCLFLEXARRAY]; /* Name of the local variable starts here. If * the name is NULL, this will just be '\0'. * The actual size of this field will be large diff --git a/generic/tclProc.c b/generic/tclProc.c index 74e6310..925c4ef 100644 --- a/generic/tclProc.c +++ b/generic/tclProc.c @@ -582,7 +582,7 @@ TclCreateProc( if ((localPtr->nameLength != nameLength) || (memcmp(localPtr->name, argname, nameLength) != 0) - || ((size_t)localPtr->frameIndex != i) + || (localPtr->frameIndex != i) || !(localPtr->flags & VAR_ARGUMENT) || (localPtr->defValuePtr == NULL && fieldCount == 2) || (localPtr->defValuePtr != NULL && fieldCount != 2)) { -- cgit v0.12 From f2bd7c2ea6b1194568bdbd57562800579679b61b Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 23 Mar 2022 20:10:15 +0000 Subject: Make varIndexes a size_t[] --- generic/tclAssembly.c | 32 ++++++++++++++++---------------- generic/tclCompCmds.c | 14 +++++++------- generic/tclCompile.c | 11 ++++++----- generic/tclCompile.h | 2 +- 4 files changed, 30 insertions(+), 29 deletions(-) diff --git a/generic/tclAssembly.c b/generic/tclAssembly.c index efe3d97..8560843 100644 --- a/generic/tclAssembly.c +++ b/generic/tclAssembly.c @@ -277,7 +277,7 @@ static void DeleteMirrorJumpTable(JumptableInfo* jtPtr); static void FillInJumpOffsets(AssemblyEnv*); static int CreateMirrorJumpTable(AssemblyEnv* assemEnvPtr, Tcl_Obj* jumpTable); -static int FindLocalVar(AssemblyEnv* envPtr, +static size_t FindLocalVar(AssemblyEnv* envPtr, Tcl_Token** tokenPtrPtr); static int FinishAssembly(AssemblyEnv*); static void FreeAssemblyEnv(AssemblyEnv*); @@ -1271,7 +1271,7 @@ AssembleOneLine( size_t operand1Len; /* String length of the operand */ int opnd; /* Integer representation of an operand */ int litIndex; /* Literal pool index of a constant */ - int localVar; /* LVT index of a local variable */ + size_t localVar; /* LVT index of a local variable */ int flags; /* Flags for a basic block */ JumptableInfo* jtPtr; /* Pointer to a jumptable */ int infoIndex; /* Index of the jumptable in auxdata */ @@ -1366,7 +1366,7 @@ AssembleOneLine( goto cleanup; } localVar = FindLocalVar(assemEnvPtr, &tokenPtr); - if (localVar < 0) { + if (localVar == TCL_INDEX_NONE) { goto cleanup; } BBEmitInstInt1(assemEnvPtr, tblIdx, opnd, 0); @@ -1426,7 +1426,7 @@ AssembleOneLine( goto cleanup; } localVar = FindLocalVar(assemEnvPtr, &tokenPtr); - if (localVar < 0) { + if (localVar == TCL_INDEX_NONE) { goto cleanup; } BBEmitInstInt4(assemEnvPtr, tblIdx, opnd, opnd+1); @@ -1443,7 +1443,7 @@ AssembleOneLine( goto cleanup; } localVar = FindLocalVar(assemEnvPtr, &tokenPtr); - if (localVar < 0) { + if (localVar == TCL_INDEX_NONE) { goto cleanup; } BBEmitInstInt4(assemEnvPtr, tblIdx, opnd, opnd); @@ -1638,7 +1638,7 @@ AssembleOneLine( goto cleanup; } localVar = FindLocalVar(assemEnvPtr, &tokenPtr); - if (localVar < 0) { + if (localVar == TCL_INDEX_NONE) { goto cleanup; } BBEmitInst1or4(assemEnvPtr, tblIdx, localVar, 0); @@ -1650,7 +1650,7 @@ AssembleOneLine( goto cleanup; } localVar = FindLocalVar(assemEnvPtr, &tokenPtr); - if (localVar < 0 || CheckOneByte(interp, localVar)) { + if (localVar == TCL_INDEX_NONE || CheckOneByte(interp, localVar)) { goto cleanup; } BBEmitInstInt1(assemEnvPtr, tblIdx, localVar, 0); @@ -1662,7 +1662,7 @@ AssembleOneLine( goto cleanup; } localVar = FindLocalVar(assemEnvPtr, &tokenPtr); - if (localVar < 0 || CheckOneByte(interp, localVar) + if (localVar == TCL_INDEX_NONE || CheckOneByte(interp, localVar) || GetIntegerOperand(assemEnvPtr, &tokenPtr, &opnd) != TCL_OK || CheckSignedOneByte(interp, opnd)) { goto cleanup; @@ -1677,7 +1677,7 @@ AssembleOneLine( goto cleanup; } localVar = FindLocalVar(assemEnvPtr, &tokenPtr); - if (localVar < 0) { + if (localVar == TCL_INDEX_NONE) { goto cleanup; } BBEmitInstInt4(assemEnvPtr, tblIdx, localVar, 0); @@ -1741,7 +1741,7 @@ AssembleOneLine( goto cleanup; } localVar = FindLocalVar(assemEnvPtr, &tokenPtr); - if (localVar < 0) { + if (localVar == TCL_INDEX