From 0cdb762ff0a1aa77e68dd137315bcd46861505da Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 2 Jul 2013 12:05:51 +0000 Subject: First experimental implementation of RFE [854941], built on top of [http://tip.tcl.tk/414|TIP #414]. --- generic/tclStubLibDl.c | 91 ++++++++++++++++++++++++++++++++++++++++++++++++++ unix/Makefile.in | 6 +++- win/Makefile.in | 4 +++ win/makefile.bc | 4 +++ win/makefile.vc | 4 +++ win/tcl.dsp | 4 +++ 6 files changed, 112 insertions(+), 1 deletion(-) create mode 100644 generic/tclStubLibDl.c diff --git a/generic/tclStubLibDl.c b/generic/tclStubLibDl.c new file mode 100644 index 0000000..1b12698 --- /dev/null +++ b/generic/tclStubLibDl.c @@ -0,0 +1,91 @@ +/* + * 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 *)LoadLibraryA(a) +# define dlsym(a,b) (void *)GetProcAddress((HANDLE)(a),b) +#endif + +/* + *---------------------------------------------------------------------- + * + * Tcl_InitSubsystems -- + * + * Initialize the stub table, using the structure pointed at + * by the "version" argument. + * + * Results: + * Outputs the value of the "version" argument. + * + * Side effects: + * Sets the stub table pointers. + * + *---------------------------------------------------------------------- + */ + +static TclStubInfoType info; + +MODULE_SCOPE const char * +Tcl_InitSubsystems( + Tcl_PanicProc *panicProc) +{ + void *handle = dlopen(TCL_LIB_FILE, RTLD_NOW|RTLD_LOCAL); + const char *(*initSubsystems)(Tcl_PanicProc *); + const char *(*setPanicProc)(Tcl_PanicProc *); + Tcl_Interp *interp, *(*createInterp)(void); + int a,b,c,d; + + if (!handle) { + if (panicProc) { + panicProc("Cannot find Tcl core"); + } else { + fprintf(stderr, "Cannot find Tcl core"); + abort(); + } + return NULL; + } + initSubsystems = dlsym(handle, "Tcl_InitSubsystems"); + if (!initSubsystems) { + initSubsystems = dlsym(handle, "_Tcl_InitSubsystems"); + } + if (initSubsystems) { + return initSubsystems(panicProc); + } + setPanicProc = dlsym(handle, "Tcl_SetPanicProc"); + if (!setPanicProc) { + setPanicProc = dlsym(handle, "_Tcl_SetPanicProc"); + } + createInterp = dlsym(handle, "Tcl_CreateInterp"); + if (!createInterp) { + createInterp = dlsym(handle, "_Tcl_CreateInterp"); + } + + setPanicProc(panicProc); + interp = createInterp(); + info.stubs = ((Interp *) interp)->stubTable; + info.stubs->tcl_DeleteInterp(interp); + info.stubs->tcl_GetVersion(&a, &b, &c, &d); + sprintf(info.version, "%d.%d.%d", a, b, c); + return info.version; +} + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ diff --git a/unix/Makefile.in b/unix/Makefile.in index 5295a45..3f44748 100644 --- a/unix/Makefile.in +++ b/unix/Makefile.in @@ -335,7 +335,7 @@ TOMMATH_OBJS = bncore.o bn_reverse.o bn_fast_s_mp_mul_digs.o \ bn_mp_unsigned_bin_size.o bn_mp_xor.o bn_mp_zero.o bn_s_mp_add.o \ bn_s_mp_mul_digs.o bn_s_mp_sqr.o bn_s_mp_sub.o -STUB_LIB_OBJS = tclStubLib.o tclStubLibTbl.o tclTomMathStubLib.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 7c54b6f6fd2a99998ce0daa0b32c8940d1ed5eea Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 24 Oct 2019 10:53:58 +0000 Subject: tclAppInit.c should be built without BUILD_tcl/USE_TCL_STUBS always. All build files should be adapted now to assure that. --- generic/tclDecls.h | 9 --------- unix/tclAppInit.c | 11 ++++++----- win/tclAppInit.c | 7 +++++-- 3 files changed, 11 insertions(+), 16 deletions(-) diff --git a/generic/tclDecls.h b/generic/tclDecls.h index b37491a..6ab227f 100644 --- a/generic/tclDecls.h +++ b/generic/tclDecls.h @@ -3931,19 +3931,10 @@ extern const TclStubs *tclStubsPtr; /* !END!: Do not edit above this line. */ #if defined(USE_TCL_STUBS) -# undef Tcl_CreateInterp # undef Tcl_FindExecutable -# undef Tcl_GetStringResult -# undef Tcl_Init # undef Tcl_SetPanicProc # undef Tcl_SetExitProc -# undef Tcl_ObjSetVar2 # undef Tcl_StaticPackage -# define Tcl_CreateInterp() (tclStubsPtr->tcl_CreateInterp()) -# define Tcl_GetStringResult(interp) (tclStubsPtr->tcl_GetStringResult(interp)) -# 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) diff --git a/unix/tclAppInit.c b/unix/tclAppInit.c index 3587f35..aa060ab 100644 --- a/unix/tclAppInit.c +++ b/unix/tclAppInit.c @@ -12,8 +12,9 @@ * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ -#undef BUILD_tcl -#undef STATIC_BUILD +#if defined(BUILD_tcl) || defined(USE_TCL_STUBS) +#error "Don't build with BUILD_tcl/USE_TCL_STUBS!" +#endif #include "tcl.h" #ifdef TCL_TEST @@ -110,7 +111,7 @@ int Tcl_AppInit( Tcl_Interp *interp) /* Interpreter for application. */ { - if ((Tcl_Init)(interp) == TCL_ERROR) { + if (Tcl_Init(interp) == TCL_ERROR) { return TCL_ERROR; } @@ -152,10 +153,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/tclAppInit.c b/win/tclAppInit.c index fa27756..348b32c 100644 --- a/win/tclAppInit.c +++ b/win/tclAppInit.c @@ -14,6 +14,9 @@ * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ +#if defined(BUILD_tcl) || defined(USE_TCL_STUBS) +#error "Don't build with BUILD_tcl/USE_TCL_STUBS!" +#endif #include "tcl.h" #define WIN32_LEAN_AND_MEAN #define STRICT /* See MSDN Article Q83456 */ @@ -158,7 +161,7 @@ int Tcl_AppInit( Tcl_Interp *interp) /* Interpreter for application. */ { - if ((Tcl_Init)(interp) == TCL_ERROR) { + if (Tcl_Init(interp) == TCL_ERROR) { return TCL_ERROR; } @@ -205,7 +208,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 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 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 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 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 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 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 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 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 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 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 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 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 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 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 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 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 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 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 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 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 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 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 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 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 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 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 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 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 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 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 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 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 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 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 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 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 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 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 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_NONE) { goto cleanup; } BBEmitInstInt4(assemEnvPtr, tblIdx, opnd, 0); @@ -2295,7 +2295,7 @@ GetListIndexOperand( *----------------------------------------------------------------------------- */ -static int +static size_t FindLocalVar( AssemblyEnv* assemEnvPtr, /* Assembly environment */ Tcl_Token** tokenPtrPtr) @@ -2310,26 +2310,26 @@ FindLocalVar( Tcl_Obj* varNameObj; /* Name of the variable */ const char* varNameStr; size_t varNameLen; - int localVar; /* Index of the variable in the LVT */ + size_t localVar; /* Index of the variable in the LVT */ if (GetNextOperand(assemEnvPtr, tokenPtrPtr, &varNameObj) != TCL_OK) { - return -1; + return TCL_INDEX_NONE; } varNameStr = Tcl_GetStringFromObj(varNameObj, &varNameLen); if (CheckNamespaceQualifiers(interp, varNameStr, varNameLen)) { Tcl_DecrRefCount(varNameObj); - return -1; + return TCL_INDEX_NONE; } localVar = TclFindCompiledLocal(varNameStr, varNameLen, 1, envPtr); Tcl_DecrRefCount(varNameObj); - if (localVar == -1) { + if (localVar == TCL_INDEX_NONE) { if (assemEnvPtr->flags & TCL_EVAL_DIRECT) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "cannot use this instruction to create a variable" " in a non-proc context", -1)); Tcl_SetErrorCode(interp, "TCL", "ASSEM", "LVT", NULL); } - return -1; + return TCL_INDEX_NONE; } *tokenPtrPtr = TokenAfter(tokenPtr); return localVar; diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c index dba05bf..6522640 100644 --- a/generic/tclCompCmds.c +++ b/generic/tclCompCmds.c @@ -393,7 +393,7 @@ TclCompileArraySetCmd( infoPtr = (ForeachInfo *)Tcl_Alloc(offsetof(ForeachInfo, varLists) + sizeof(ForeachVarList *)); infoPtr->numLists = 1; - infoPtr->varLists[0] = (ForeachVarList *)Tcl_Alloc(offsetof(ForeachVarList, varIndexes) + 2 * sizeof(int)); + infoPtr->varLists[0] = (ForeachVarList *)Tcl_Alloc(offsetof(ForeachVarList, varIndexes) + 2 * sizeof(size_t)); infoPtr->varLists[0]->numVars = 2; infoPtr->varLists[0]->varIndexes[0] = keyVar; infoPtr->varLists[0]->varIndexes[1] = valVar; @@ -2762,7 +2762,7 @@ CompileEachloopCmd( } varListPtr = (ForeachVarList *)Tcl_Alloc(offsetof(ForeachVarList, varIndexes) - + numVars * sizeof(int)); + + numVars * sizeof(size_t)); varListPtr->numVars = numVars; infoPtr->varLists[i/2] = varListPtr; infoPtr->numLists++; @@ -2909,7 +2909,7 @@ DupForeachInfo( srcListPtr = srcPtr->varLists[i]; numVars = srcListPtr->numVars; dupListPtr = (ForeachVarList *)Tcl_Alloc(offsetof(ForeachVarList, varIndexes) - + numVars * sizeof(int)); + + numVars * sizeof(size_t)); dupListPtr->numVars = numVars; for (j = 0; j < numVars; j++) { dupListPtr->varIndexes[j] = srcListPtr->varIndexes[j]; @@ -3004,8 +3004,8 @@ PrintForeachInfo( if (j) { Tcl_AppendToObj(appendObj, ", ", -1); } - Tcl_AppendPrintfToObj(appendObj, "%%v%u", - (unsigned) varsPtr->varIndexes[j]); + Tcl_AppendPrintfToObj(appendObj, "%%v%" TCL_Z_MODIFIER "u", + varsPtr->varIndexes[j]); } Tcl_AppendToObj(appendObj, "]", -1); } @@ -3034,8 +3034,8 @@ PrintNewForeachInfo( if (j) { Tcl_AppendToObj(appendObj, ",", -1); } - Tcl_AppendPrintfToObj(appendObj, "%%v%u", - (unsigned) varsPtr->varIndexes[j]); + Tcl_AppendPrintfToObj(appendObj, "%%v%" TCL_Z_MODIFIER "u", + varsPtr->varIndexes[j]); } Tcl_AppendToObj(appendObj, "]", -1); } diff --git a/generic/tclCompile.c b/generic/tclCompile.c index 4eb1a15..0a5518d 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -2315,7 +2315,8 @@ TclCompileVarSubst( { const char *p, *name = tokenPtr[1].start; size_t i, nameBytes = tokenPtr[1].size; - int localVar, localVarName = 1; + size_t localVar; + int localVarName = 1; /* * Determine how the variable name should be handled: if it contains any @@ -2342,11 +2343,11 @@ TclCompileVarSubst( * of local variables in a procedure frame. */ - localVar = -1; + localVar = TCL_INDEX_NONE; if (localVarName != -1) { localVar = TclFindCompiledLocal(name, nameBytes, localVarName, envPtr); } - if (localVar < 0) { + if (localVar == TCL_INDEX_NONE) { PushLiteral(envPtr, name, nameBytes); } @@ -2358,7 +2359,7 @@ TclCompileVarSubst( tokenPtr[1].start + tokenPtr[1].size); if (tokenPtr->numComponents == 1) { - if (localVar < 0) { + if (localVar == TCL_INDEX_NONE) { TclEmitOpcode(INST_LOAD_STK, envPtr); } else if (localVar <= 255) { TclEmitInstInt1(INST_LOAD_SCALAR1, localVar, envPtr); @@ -2367,7 +2368,7 @@ TclCompileVarSubst( } } else { TclCompileTokens(interp, tokenPtr+2, tokenPtr->numComponents-1, envPtr); - if (localVar < 0) { + if (localVar == TCL_INDEX_NONE) { TclEmitOpcode(INST_LOAD_ARRAY_STK, envPtr); } else if (localVar <= 255) { TclEmitInstInt1(INST_LOAD_ARRAY1, localVar, envPtr); diff --git a/generic/tclCompile.h b/generic/tclCompile.h index 669e11d..dc366c5 100644 --- a/generic/tclCompile.h +++ b/generic/tclCompile.h @@ -980,7 +980,7 @@ typedef struct JumpFixupArray { typedef struct ForeachVarList { size_t numVars; /* The number of variables in the list. */ - int varIndexes[TCLFLEXARRAY];/* An array of the indexes ("slot numbers") + size_t varIndexes[TCLFLEXARRAY];/* An array of the indexes ("slot numbers") * for each variable in the procedure's array * of local variables. Only scalar variables * are supported. The actual size of this -- cgit v0.12 From 4e3426067cddf752f0c15e8a2ce29f5f9052341f Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 24 Mar 2022 10:48:44 +0000 Subject: When compiled with TCL_NO_DEPRECATED, remove the UTF16 compatibility layer. So, we make sure that it is never used internally for the Core. This means that extensions using the compatibility layer won't work any more in this mode; extensions should be compiled using TCL_UTF_MAX=4 then they work again. --- generic/tclExecute.c | 4 ++-- generic/tclInt.h | 2 ++ generic/tclObj.c | 2 ++ generic/tclStringObj.c | 45 ++++++++++++++++++++++++++------------------- generic/tclStubInit.c | 9 +++++++++ generic/tclTestObj.c | 24 ++++++++++++++++-------- generic/tclUtf.c | 4 ++-- generic/tclUtil.c | 2 +- tests/stringObj.test | 26 +++++++++++++------------- 9 files changed, 73 insertions(+), 45 deletions(-) diff --git a/generic/tclExecute.c b/generic/tclExecute.c index f09f75c..0456146 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -5592,8 +5592,8 @@ TEBCresume( * both. */ - if (TclHasInternalRep(valuePtr, &tclStringType) - || TclHasInternalRep(value2Ptr, &tclStringType)) { + if (TclHasInternalRep(valuePtr, &tclUniCharStringType) + || TclHasInternalRep(value2Ptr, &tclUniCharStringType)) { Tcl_UniChar *ustring1, *ustring2; ustring1 = TclGetUnicodeFromObj_(valuePtr, &length); diff --git a/generic/tclInt.h b/generic/tclInt.h index 3aa2626..6804996 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -2768,6 +2768,7 @@ MODULE_SCOPE const Tcl_ObjType tclListType; MODULE_SCOPE const Tcl_ObjType tclDictType; MODULE_SCOPE const Tcl_ObjType tclProcBodyType; MODULE_SCOPE const Tcl_ObjType tclStringType; +MODULE_SCOPE const Tcl_ObjType tclUniCharStringType; MODULE_SCOPE const Tcl_ObjType tclEnsembleCmdType; MODULE_SCOPE const Tcl_ObjType tclRegexpType; MODULE_SCOPE Tcl_ObjType tclCmdNameType; @@ -3333,6 +3334,7 @@ MODULE_SCOPE int TclZipfs_Init(Tcl_Interp *interp); # undef Tcl_UtfAtIndex # define Tcl_UtfAtIndex TclUtfAtIndex #else +# define tclUniCharStringType tclStringType # define TclGetUnicodeFromObj_ Tcl_GetUnicodeFromObj # define TclNewUnicodeObj Tcl_NewUnicodeObj # define TclAppendUnicodeToObj Tcl_AppendUnicodeToObj diff --git a/generic/tclObj.c b/generic/tclObj.c index a06b8fd..7596880 100644 --- a/generic/tclObj.c +++ b/generic/tclObj.c @@ -387,7 +387,9 @@ TclInitObjSubsystem(void) Tcl_RegisterObjType(&tclByteArrayType); Tcl_RegisterObjType(&tclDoubleType); +#if (TCL_UTF_MAX) > 3 && !defined(TCL_NO_DEPRECATED) Tcl_RegisterObjType(&tclStringType); +#endif Tcl_RegisterObjType(&tclListType); Tcl_RegisterObjType(&tclDictType); Tcl_RegisterObjType(&tclByteCodeType); diff --git a/generic/tclStringObj.c b/generic/tclStringObj.c index 17c7067..627fadc 100644 --- a/generic/tclStringObj.c +++ b/generic/tclStringObj.c @@ -69,7 +69,7 @@ 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 > 3 +#if (TCL_UTF_MAX) > 3 && !defined(TCL_NO_DEPRECATED) static void DupUTF16StringInternalRep(Tcl_Obj *objPtr, Tcl_Obj *copyPtr); static int SetUTF16StringFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr); @@ -88,7 +88,7 @@ static void UpdateStringOfUTF16String(Tcl_Obj *objPtr); #if TCL_UTF_MAX < 4 -#define uniCharStringType tclStringType +#define tclUniCharStringType tclStringType #define GET_UNICHAR_STRING GET_STRING #define UniCharString String #define UNICHAR_STRING_MAXCHARS STRING_MAXCHARS @@ -110,6 +110,8 @@ const Tcl_ObjType tclStringType = { #else +#define tclStringType xxx +#ifndef TCL_NO_DEPRECATED const Tcl_ObjType tclStringType = { "string", /* name */ FreeStringInternalRep, /* freeIntRepPro */ @@ -117,8 +119,9 @@ const Tcl_ObjType tclStringType = { UpdateStringOfUTF16String, /* updateStringProc */ SetUTF16StringFromAny /* setFromAnyProc */ }; +#endif -static const Tcl_ObjType uniCharStringType = { +const Tcl_ObjType tclUniCharStringType = { "utf32string", /* name */ FreeStringInternalRep, /* freeIntRepPro */ DupStringInternalRep, /* dupIntRepProc */ @@ -170,6 +173,7 @@ typedef struct { ((objPtr)->internalRep.twoPtrValue.ptr1 = (void *) (stringPtr)) +#ifndef TCL_NO_DEPRECATED static void DupUTF16StringInternalRep( Tcl_Obj *srcPtr, /* Object with internal rep to copy. Must have @@ -243,6 +247,7 @@ UpdateStringOfUTF16String( objPtr->length = Tcl_DStringLength(&ds); Tcl_DStringFree(&ds); } +#endif #endif @@ -545,7 +550,7 @@ TclNewUnicodeObj( return objPtr; } -#if TCL_UTF_MAX > 3 +#if (TCL_UTF_MAX > 3) && !defined(TCL_NO_DEPRECATED) Tcl_Obj * Tcl_NewUnicodeObj( const unsigned short *unicode, /* The unicode string used to initialize the @@ -644,7 +649,7 @@ TclGetCharLength( return numChars; } -#if TCL_UTF_MAX > 3 +#if (TCL_UTF_MAX > 3) && !defined(TCL_NO_DEPRECATED) #undef Tcl_GetCharLength int Tcl_GetCharLength( @@ -889,7 +894,7 @@ TclGetUnicodeFromObj_( return stringPtr->unicode; } -#if TCL_UTF_MAX > 3 +#if TCL_UTF_MAX > 3 && !defined(TCL_NO_DEPRECATED) unsigned short * Tcl_GetUnicodeFromObj( Tcl_Obj *objPtr, /* The object to find the unicode string @@ -1327,6 +1332,7 @@ Tcl_AttemptSetObjLength( *--------------------------------------------------------------------------- */ +#if !defined(TCL_NO_DEPRECATED) void Tcl_SetUnicodeObj( Tcl_Obj *objPtr, /* The object to set the string of. */ @@ -1366,6 +1372,7 @@ Tcl_SetUnicodeObj( TclInvalidateStringRep(objPtr); stringPtr->allocated = numChars; } +#endif static int UnicodeLength( @@ -1403,7 +1410,7 @@ SetUnicodeObj( uniCharStringCheckLimits(numChars); stringPtr = uniCharStringAlloc(numChars); SET_UNICHAR_STRING(objPtr, stringPtr); - objPtr->typePtr = &uniCharStringType; + objPtr->typePtr = &tclUniCharStringType; stringPtr->maxChars = numChars; memcpy(stringPtr->unicode, unicode, numChars * sizeof(Tcl_UniChar)); @@ -1591,7 +1598,7 @@ TclAppendUnicodeToObj( } } -#if TCL_UTF_MAX > 3 +#if TCL_UTF_MAX > 3 && !defined(TCL_NO_DEPRECATED) void Tcl_AppendUnicodeToObj( Tcl_Obj *objPtr, /* Points to the object to append to. */ @@ -1736,7 +1743,7 @@ Tcl_AppendObjToObj( * If appendObjPtr is not of the "String" type, don't convert it. */ - if (TclHasInternalRep(appendObjPtr, &uniCharStringType)) { + if (TclHasInternalRep(appendObjPtr, &tclUniCharStringType)) { Tcl_UniChar *unicode = TclGetUnicodeFromObj_(appendObjPtr, &numChars); @@ -1757,7 +1764,7 @@ Tcl_AppendObjToObj( bytes = TclGetStringFromObj(appendObjPtr, &length); numChars = stringPtr->numChars; - if ((numChars >= 0) && TclHasInternalRep(appendObjPtr, &uniCharStringType)) { + if ((numChars >= 0) && TclHasInternalRep(appendObjPtr, &tclUniCharStringType)) { UniCharString *appendStringPtr = GET_UNICHAR_STRING(appendObjPtr); appendNumChars = appendStringPtr->numChars; @@ -3166,7 +3173,7 @@ TclGetStringStorage( { UniCharString *stringPtr; - if (!TclHasInternalRep(objPtr, &uniCharStringType) || objPtr->bytes == NULL) { + if (!TclHasInternalRep(objPtr, &tclUniCharStringType) || objPtr->bytes == NULL) { return TclGetStringFromObj(objPtr, (int *)sizePtr); } @@ -3214,7 +3221,7 @@ TclStringRepeat( */ if (!binary) { - if (TclHasInternalRep(objPtr, &uniCharStringType)) { + if (TclHasInternalRep(objPtr, &tclUniCharStringType)) { UniCharString *stringPtr = GET_UNICHAR_STRING(objPtr); if (stringPtr->hasUnicode) { unichar = 1; @@ -3385,7 +3392,7 @@ TclStringCat( binary = 0; if (ov > objv+1 && ISCONTINUATION(TclGetString(objPtr))) { forceUniChar = 1; - } else if ((objPtr->typePtr) && (objPtr->typePtr != &uniCharStringType)) { + } else if ((objPtr->typePtr) && (objPtr->typePtr != &tclUniCharStringType)) { /* Prevent shimmer of non-string types. */ allowUniChar = 0; } @@ -3393,7 +3400,7 @@ TclStringCat( } else { /* assert (objPtr->typePtr != NULL) -- stork! */ binary = 0; - if (TclHasInternalRep(objPtr, &uniCharStringType)) { + if (TclHasInternalRep(objPtr, &tclUniCharStringType)) { /* Have a pure Unicode value; ask to preserve it */ requestUniChar = 1; } else { @@ -3746,8 +3753,8 @@ TclStringCmp( s1 = (char *) Tcl_GetByteArrayFromObj(value1Ptr, &s1len); s2 = (char *) Tcl_GetByteArrayFromObj(value2Ptr, &s2len); memCmpFn = memcmp; - } else if (TclHasInternalRep(value1Ptr, &uniCharStringType) - && TclHasInternalRep(value2Ptr, &uniCharStringType)) { + } else if (TclHasInternalRep(value1Ptr, &tclUniCharStringType) + && TclHasInternalRep(value2Ptr, &tclUniCharStringType)) { /* * Do a unicode-specific comparison if both of the args are of * String type. If the char length == byte length, we can do a @@ -4556,7 +4563,7 @@ DupStringInternalRep( copyStringPtr->allocated = copyPtr->bytes ? copyPtr->length : 0; SET_UNICHAR_STRING(copyPtr, copyStringPtr); - copyPtr->typePtr = &uniCharStringType; + copyPtr->typePtr = &tclUniCharStringType; } /* @@ -4581,7 +4588,7 @@ SetStringFromAny( TCL_UNUSED(Tcl_Interp *), Tcl_Obj *objPtr) /* The object to convert. */ { - if (!TclHasInternalRep(objPtr, &uniCharStringType)) { + if (!TclHasInternalRep(objPtr, &tclUniCharStringType)) { UniCharString *stringPtr = uniCharStringAlloc(0); /* @@ -4601,7 +4608,7 @@ SetStringFromAny( stringPtr->maxChars = 0; stringPtr->hasUnicode = 0; SET_UNICHAR_STRING(objPtr, stringPtr); - objPtr->typePtr = &uniCharStringType; + objPtr->typePtr = &tclUniCharStringType; } return TCL_OK; } diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c index 9757ad2..7c8c219 100644 --- a/generic/tclStubInit.c +++ b/generic/tclStubInit.c @@ -87,6 +87,15 @@ #define TclUtfNext UtfNext #define TclUtfPrev UtfPrev +#if TCL_UTF_MAX > 3 && defined(TCL_NO_DEPRECATED) +#define Tcl_GetUnicodeFromObj 0 +#define Tcl_AppendUnicodeToObj 0 +#define Tcl_NewUnicodeObj 0 +#define Tcl_SetUnicodeObj 0 +#define Tcl_UtfAtIndex 0 +#define Tcl_GetCharLength 0 +#endif + static int TclUtfCharComplete(const char *src, int length) { if ((unsigned)((unsigned char)*(src) - 0xF0) < 5) { return length < 3; diff --git a/generic/tclTestObj.c b/generic/tclTestObj.c index 9884a9a..223eb98 100644 --- a/generic/tclTestObj.c +++ b/generic/tclTestObj.c @@ -1264,10 +1264,14 @@ TeststringobjCmd( goto wrongNumArgs; } if (varPtr[varIndex] != NULL) { - Tcl_ConvertToType(NULL, varPtr[varIndex], - Tcl_GetObjType("string")); - strPtr = (String *)varPtr[varIndex]->internalRep.twoPtrValue.ptr1; - length = (int) strPtr->allocated; + const Tcl_ObjType *objType = Tcl_GetObjType("string"); + if (objType != NULL) { + Tcl_ConvertToType(NULL, varPtr[varIndex], objType); + strPtr = (String *)varPtr[varIndex]->internalRep.twoPtrValue.ptr1; + length = (int) strPtr->allocated; + } else { + length = -1; + } } else { length = -1; } @@ -1318,10 +1322,14 @@ TeststringobjCmd( goto wrongNumArgs; } if (varPtr[varIndex] != NULL) { - Tcl_ConvertToType(NULL, varPtr[varIndex], - Tcl_GetObjType("string")); - strPtr = (String *)varPtr[varIndex]->internalRep.twoPtrValue.ptr1; - length = strPtr->maxChars; + const Tcl_ObjType *objType = Tcl_GetObjType("string"); + if (objType != NULL) { + Tcl_ConvertToType(NULL, varPtr[varIndex],objType); + strPtr = (String *)varPtr[varIndex]->internalRep.twoPtrValue.ptr1; + length = strPtr->maxChars; + } else { + length = -1; + } } else { length = -1; } diff --git a/generic/tclUtf.c b/generic/tclUtf.c index cfd9915..2a335d7 100644 --- a/generic/tclUtf.c +++ b/generic/tclUtf.c @@ -850,7 +850,7 @@ TclNumUtfChars( return i; } -#if TCL_UTF_MAX > 3 +#if (TCL_UTF_MAX > 3) && !defined(TCL_NO_DEPRECATED) #undef Tcl_NumUtfChars int Tcl_NumUtfChars( @@ -1245,7 +1245,7 @@ TclUtfAtIndex( return src; } -#if TCL_UTF_MAX > 3 +#if (TCL_UTF_MAX > 3) && !defined(TCL_NO_DEPRECATED) #undef Tcl_UtfAtIndex const char * Tcl_UtfAtIndex( diff --git a/generic/tclUtil.c b/generic/tclUtil.c index 9cc82cb..3537ecc 100644 --- a/generic/tclUtil.c +++ b/generic/tclUtil.c @@ -2591,7 +2591,7 @@ TclStringMatchObj( trivial = nocase ? 0 : TclMatchIsTrivial(TclGetString(ptnObj)); */ - if (TclHasInternalRep(strObj, &tclStringType) || (strObj->typePtr == NULL)) { + if (TclHasInternalRep(strObj, &tclUniCharStringType) || (strObj->typePtr == NULL)) { Tcl_UniChar *udata, *uptn; udata = TclGetUnicodeFromObj_(strObj, &length); diff --git a/tests/stringObj.test b/tests/stringObj.test index c11bf7f..0aa9a47 100644 --- a/tests/stringObj.test +++ b/tests/stringObj.test @@ -27,7 +27,7 @@ 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 { +test stringObj-1.1 {string type registration} {testobj deprecated} { set t [testobj types] set first [string first "string" $t] set result [expr {$first >= 0}] @@ -58,27 +58,27 @@ 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 utf32} { +test stringObj-4.1 {Tcl_SetObjLength procedure, string gets shorter} {testobj utf32 deprecated} { testobj freeallvars teststringobj set 1 test teststringobj setlength 1 3 list [teststringobj length 1] [teststringobj length2 1] \ [teststringobj get 1] } {3 3 tes} -test stringObj-4.2 {Tcl_SetObjLength procedure, string gets longer} testobj { +test stringObj-4.2 {Tcl_SetObjLength procedure, string gets longer} {testobj deprecated} { testobj freeallvars teststringobj set 1 abcdef teststringobj setlength 1 10 list [teststringobj length 1] [teststringobj length2 1] } {10 10} -test stringObj-4.3 {Tcl_SetObjLength procedure, string gets longer} {testobj utf32} { +test stringObj-4.3 {Tcl_SetObjLength procedure, string gets longer} {testobj utf32 deprecated} { testobj freeallvars teststringobj set 1 abcdef teststringobj append 1 xyzq -1 list [teststringobj length 1] [teststringobj length2 1] \ [teststringobj get 1] } {10 10 abcdefxyzq} -test stringObj-4.4 {Tcl_SetObjLength procedure, "expty string", length 0} testobj { +test stringObj-4.4 {Tcl_SetObjLength procedure, "expty string", length 0} {testobj deprecated} { testobj freeallvars testobj newobj 1 teststringobj setlength 1 0 @@ -98,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 utf32} { +test stringObj-5.3 {Tcl_AppendToObj procedure, reallocating space} {testobj utf32 deprecated} { testobj freeallvars teststringobj set 1 xyz teststringobj setlength 1 15 @@ -136,13 +136,13 @@ 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 utf32} { +test stringObj-6.5 {Tcl_AppendStringsToObj procedure, don't double space if initial string empty} {testobj utf32 deprecated} { testobj freeallvars testobj newobj 1 teststringobj appendstrings 1 123 abcdefg list [teststringobj length 1] [teststringobj length2 1] [teststringobj get 1] } {10 10 123abcdefg} -test stringObj-6.6 {Tcl_AppendStringsToObj procedure, space reallocation} testobj { +test stringObj-6.6 {Tcl_AppendStringsToObj procedure, space reallocation} {testobj deprecated} { testobj freeallvars teststringobj set 1 abc teststringobj setlength 1 10 @@ -151,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 utf32} { +test stringObj-6.7 {Tcl_AppendStringsToObj procedure, space reallocation} {testobj utf32 deprecated} { testobj freeallvars teststringobj set 1 abc teststringobj setlength 1 10 @@ -160,7 +160,7 @@ test stringObj-6.7 {Tcl_AppendStringsToObj procedure, space reallocation} {testo list [teststringobj length 1] [teststringobj length2 1] \ [teststringobj get 1] } {11 11 ab34567890x} -test stringObj-6.8 {Tcl_AppendStringsToObj procedure, object totally empty} testobj { +test stringObj-6.8 {Tcl_AppendStringsToObj procedure, object totally empty} {testobj deprecated} { testobj freeallvars testobj newobj 1 teststringobj appendstrings 1 {} @@ -173,14 +173,14 @@ test stringObj-6.9 {Tcl_AppendStringToObj, pure unicode} testobj { teststringobj get 1 } adcfoobarsoom -test stringObj-7.1 {SetStringFromAny procedure} {testobj utf32} { +test stringObj-7.1 {SetStringFromAny procedure} {testobj utf32 deprecated} { testobj freeallvars teststringobj set2 1 [list a b] teststringobj append 1 x -1 list [teststringobj length 1] [teststringobj length2 1] \ [teststringobj get 1] } {4 4 {a bx}} -test stringObj-7.2 {SetStringFromAny procedure, null object} testobj { +test stringObj-7.2 {SetStringFromAny procedure, null object} {testobj deprecated} { testobj freeallvars testobj newobj 1 teststringobj appendstrings 1 {} @@ -198,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 utf32} { +test stringObj-8.1 {DupStringInternalRep procedure} {testobj utf32 deprecated} { testobj freeallvars teststringobj set 1 {} teststringobj append 1 abcde -1 -- cgit v0.12 From 0febd13af2d2275d3b63ef191462fc4fea18db99 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 24 Mar 2022 11:34:39 +0000 Subject: Implement PANIC when the UTF16 compatibility layer is used in combination with -DTCL_NO_DEPRECATED --- generic/tclStubInit.c | 28 ++++++++++++++++++---------- generic/tclUtf.c | 6 +++--- 2 files changed, 21 insertions(+), 13 deletions(-) diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c index 7c8c219..131053a 100644 --- a/generic/tclStubInit.c +++ b/generic/tclStubInit.c @@ -83,19 +83,27 @@ #define TclWinConvertError (void (*)(DWORD))(void *)Tcl_WinConvertError #endif -#define TclUtfCharComplete UtfCharComplete -#define TclUtfNext UtfNext -#define TclUtfPrev UtfPrev #if TCL_UTF_MAX > 3 && defined(TCL_NO_DEPRECATED) -#define Tcl_GetUnicodeFromObj 0 -#define Tcl_AppendUnicodeToObj 0 -#define Tcl_NewUnicodeObj 0 -#define Tcl_SetUnicodeObj 0 -#define Tcl_UtfAtIndex 0 -#define Tcl_GetCharLength 0 +static void uniCodePanic(void) { + Tcl_Panic("Tcl is compiled without the the UTF16 compatibility layer (-DTCL_NO_DEPRECATED)"); +} +# define Tcl_GetUnicode (unsigned short *(*)(Tcl_Obj *))(void *)uniCodePanic +# define Tcl_GetUnicodeFromObj (unsigned short *(*)(Tcl_Obj *, int *))(void *)uniCodePanic +# define Tcl_NewUnicodeObj (Tcl_Obj *(*)(const unsigned short *, int))(void *)uniCodePanic +# define Tcl_SetUnicodeObj (void(*)(Tcl_Obj *, const unsigned short *, int))(void *)uniCodePanic +# define Tcl_AppendUnicodeToObj (void(*)(Tcl_Obj *, const unsigned short *, int))(void *)uniCodePanic +# define Tcl_UtfAtIndex (const char *(*)(const char *, int))(void *)uniCodePanic +# define Tcl_GetCharLength (int(*)(Tcl_Obj *))(void *)uniCodePanic +# define Tcl_UniCharNcmp (int(*)(const unsigned short *, const unsigned short *, unsigned long))(void *)uniCodePanic +# define Tcl_UniCharNcasecmp (int(*)(const unsigned short *, const unsigned short *, unsigned long))(void *)uniCodePanic +# define Tcl_UniCharCaseMatch (int(*)(const unsigned short *, const unsigned short *, int))(void *)uniCodePanic #endif +#define TclUtfCharComplete UtfCharComplete +#define TclUtfNext UtfNext +#define TclUtfPrev UtfPrev + static int TclUtfCharComplete(const char *src, int length) { if ((unsigned)((unsigned char)*(src) - 0xF0) < 5) { return length < 3; @@ -679,8 +687,8 @@ static int utfNcasecmp(const char *s1, const char *s2, unsigned int n){ # define Tcl_SetExitProc 0 # define Tcl_SetPanicProc 0 # define Tcl_FindExecutable 0 -# define Tcl_GetUnicode 0 #if TCL_UTF_MAX < 4 +# define Tcl_GetUnicode 0 # define Tcl_AppendUnicodeToObj 0 # define Tcl_UniCharCaseMatch 0 # define Tcl_UniCharNcasecmp 0 diff --git a/generic/tclUtf.c b/generic/tclUtf.c index 2a335d7..82adf65 100644 --- a/generic/tclUtf.c +++ b/generic/tclUtf.c @@ -1957,7 +1957,7 @@ TclUniCharNcmp( #endif /* WORDS_BIGENDIAN */ } -#if TCL_UTF_MAX > 3 +#if (TCL_UTF_MAX > 3) && !defined(TCL_NO_DEPRECATED) int Tcl_UniCharNcmp( const unsigned short *ucs, /* Unicode string to compare to uct. */ @@ -2028,7 +2028,7 @@ TclUniCharNcasecmp( return 0; } -#if TCL_UTF_MAX > 3 +#if (TCL_UTF_MAX > 3) && !defined(TCL_NO_DEPRECATED) int Tcl_UniCharNcasecmp( const unsigned short *ucs, /* Unicode string to compare to uct. */ @@ -2584,7 +2584,7 @@ TclUniCharCaseMatch( } } -#if TCL_UTF_MAX > 3 +#if (TCL_UTF_MAX > 3) && !defined(TCL_NO_DEPRECATED) int Tcl_UniCharCaseMatch( const unsigned short *uniStr, /* Unicode String. */ -- cgit v0.12 From bab10ccf5c152dec04a0eed4fac248b749af4fd9 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 24 Mar 2022 12:43:05 +0000 Subject: Add TclGetRange() to the compatibility set --- generic/tcl.decls | 3 +++ generic/tclDecls.h | 5 ++++ generic/tclInt.h | 6 +++-- generic/tclStringObj.c | 63 +++++++++++++++++++++++++++++++++++++++++++++++++- generic/tclStubInit.c | 3 +++ 5 files changed, 77 insertions(+), 3 deletions(-) diff --git a/generic/tcl.decls b/generic/tcl.decls index cb6e282..f6a4c05 100644 --- a/generic/tcl.decls +++ b/generic/tcl.decls @@ -2463,6 +2463,9 @@ declare 670 { declare 671 { const char *TclUtfAtIndex(const char *src, int index) } +declare 672 { + Tcl_Obj *TclGetRange(Tcl_Obj *objPtr, int first, int last) +} # ----- BASELINE -- FOR -- 8.7.0 ----- # diff --git a/generic/tclDecls.h b/generic/tclDecls.h index 06ee797..fdf8673 100644 --- a/generic/tclDecls.h +++ b/generic/tclDecls.h @@ -1969,6 +1969,8 @@ EXTERN int TclNumUtfChars(const char *src, int length); EXTERN int TclGetCharLength(Tcl_Obj *objPtr); /* 671 */ EXTERN const char * TclUtfAtIndex(const char *src, int index); +/* 672 */ +EXTERN Tcl_Obj * TclGetRange(Tcl_Obj *objPtr, int first, int last); typedef struct { const struct TclPlatStubs *tclPlatStubs; @@ -2676,6 +2678,7 @@ typedef struct TclStubs { int (*tclNumUtfChars) (const char *src, int length); /* 669 */ int (*tclGetCharLength) (Tcl_Obj *objPtr); /* 670 */ const char * (*tclUtfAtIndex) (const char *src, int index); /* 671 */ + Tcl_Obj * (*tclGetRange) (Tcl_Obj *objPtr, int first, int last); /* 672 */ } TclStubs; extern const TclStubs *tclStubsPtr; @@ -4043,6 +4046,8 @@ extern const TclStubs *tclStubsPtr; (tclStubsPtr->tclGetCharLength) /* 670 */ #define TclUtfAtIndex \ (tclStubsPtr->tclUtfAtIndex) /* 671 */ +#define TclGetRange \ + (tclStubsPtr->tclGetRange) /* 672 */ #endif /* defined(USE_TCL_STUBS) */ diff --git a/generic/tclInt.h b/generic/tclInt.h index 6804996..7486d60 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -3333,6 +3333,8 @@ MODULE_SCOPE int TclZipfs_Init(Tcl_Interp *interp); # define Tcl_GetCharLength TclGetCharLength # undef Tcl_UtfAtIndex # define Tcl_UtfAtIndex TclUtfAtIndex +# undef Tcl_GetRange +# define Tcl_GetRange TclGetRange #else # define tclUniCharStringType tclStringType # define TclGetUnicodeFromObj_ Tcl_GetUnicodeFromObj @@ -3345,8 +3347,8 @@ MODULE_SCOPE int TclZipfs_Init(Tcl_Interp *interp); # define TclNumUtfChars Tcl_NumUtfChars # undef TclGetCharLength # define TclGetCharLength Tcl_GetCharLength -# undef TclUtfAtIndex -# define TclUtfAtIndex Tcl_UtfAtIndex +# undef TclGetRange +# define TclGetRange Tcl_GetRange #endif diff --git a/generic/tclStringObj.c b/generic/tclStringObj.c index 627fadc..332d1d2 100644 --- a/generic/tclStringObj.c +++ b/generic/tclStringObj.c @@ -110,7 +110,6 @@ const Tcl_ObjType tclStringType = { #else -#define tclStringType xxx #ifndef TCL_NO_DEPRECATED const Tcl_ObjType tclStringType = { "string", /* name */ @@ -952,6 +951,8 @@ TclGetUnicodeFromObj( *---------------------------------------------------------------------- */ +#if TCL_UTF_MAX > 3 && !defined(TCL_NO_DEPRECATED) +#undef Tcl_GetRange Tcl_Obj * Tcl_GetRange( Tcl_Obj *objPtr, /* The Tcl object to find the range of. */ @@ -959,6 +960,66 @@ Tcl_GetRange( int last) /* Last index of the range. */ { Tcl_Obj *newObjPtr; /* The Tcl object to find the range of. */ + String *stringPtr; + int length; + + if (first < 0) { + first = 0; + } + + /* + * Optimize the case where we're really dealing with a bytearray object + * we don't need to convert to a string to perform the substring operation. + */ + + if (TclIsPureByteArray(objPtr)) { + unsigned char *bytes = Tcl_GetByteArrayFromObj(objPtr, &length); + + if (last < 0 || last >= length) { + last = length - 1; + } + if (last < first) { + TclNewObj(newObjPtr); + return newObjPtr; + } + return Tcl_NewByteArrayObj(bytes + first, last - first + 1); + } + + /* + * OK, need to work with the object as a utf16 string. + */ + + SetUTF16StringFromAny(NULL, objPtr); + stringPtr = GET_STRING(objPtr); + + if (last < 0 || last >= stringPtr->numChars) { + last = stringPtr->numChars - 1; + } + if (last < first) { + TclNewObj(newObjPtr); + return newObjPtr; + } + /* See: bug [11ae2be95dac9417] */ + if ((first > 0) && ((stringPtr->unicode[first] & 0xFC00) == 0xDC00) + && ((stringPtr->unicode[first-1] & 0xFC00) == 0xD800)) { + ++first; + } + if ((last + 1 < stringPtr->numChars) + && ((stringPtr->unicode[last+1] & 0xFC00) == 0xDC00) + && ((stringPtr->unicode[last] & 0xFC00) == 0xD800)) { + ++last; + } + return Tcl_NewUnicodeObj(stringPtr->unicode + first, last - first + 1); +} +#endif + +Tcl_Obj * +TclGetRange( + Tcl_Obj *objPtr, /* The Tcl object to find the range of. */ + int first, /* First index of the range. */ + int last) /* Last index of the range. */ +{ + Tcl_Obj *newObjPtr; /* The Tcl object to find the range of. */ UniCharString *stringPtr; int length; diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c index 131053a..2046938 100644 --- a/generic/tclStubInit.c +++ b/generic/tclStubInit.c @@ -48,6 +48,7 @@ #undef Tcl_UniCharCaseMatch #undef Tcl_UniCharLen #undef Tcl_UniCharNcmp +#undef Tcl_GetRange #undef Tcl_DumpActiveMemory #undef Tcl_ValidateAllMemory #undef Tcl_FindHashEntry @@ -98,6 +99,7 @@ static void uniCodePanic(void) { # define Tcl_UniCharNcmp (int(*)(const unsigned short *, const unsigned short *, unsigned long))(void *)uniCodePanic # define Tcl_UniCharNcasecmp (int(*)(const unsigned short *, const unsigned short *, unsigned long))(void *)uniCodePanic # define Tcl_UniCharCaseMatch (int(*)(const unsigned short *, const unsigned short *, int))(void *)uniCodePanic +# define Tcl_GetRange (Tcl_Obj *(*)(Tcl_Obj *, int, int))(void *)uniCodePanic #endif #define TclUtfCharComplete UtfCharComplete @@ -1957,6 +1959,7 @@ const TclStubs tclStubs = { TclNumUtfChars, /* 669 */ TclGetCharLength, /* 670 */ TclUtfAtIndex, /* 671 */ + TclGetRange, /* 672 */ }; /* !END!: Do not edit above this line. */ -- cgit v0.12 From 53f15cc67318ebe942c270c60268b0396688befc Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 24 Mar 2022 13:18:33 +0000 Subject: Fix internal usage of Tcl_GetRange/Tcl_UtfAtIndex --- generic/tclCmdMZ.c | 6 +++--- generic/tclExecute.c | 4 ++-- generic/tclInt.h | 2 ++ generic/tclStringObj.c | 2 +- 4 files changed, 8 insertions(+), 6 deletions(-) diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c index bd5745b..1beb732 100644 --- a/generic/tclCmdMZ.c +++ b/generic/tclCmdMZ.c @@ -395,7 +395,7 @@ Tcl_RegexpObjCmd( newPtr = Tcl_NewListObj(2, objs); } else { if ((i <= info.nsubs) && (info.matches[i].end > 0)) { - newPtr = Tcl_GetRange(objPtr, + newPtr = TclGetRange(objPtr, offset + info.matches[i].start, offset + info.matches[i].end - 1); } else { @@ -2301,7 +2301,7 @@ StringRangeCmd( } if (last >= 0) { - Tcl_SetObjResult(interp, Tcl_GetRange(objv[1], first, last)); + Tcl_SetObjResult(interp, TclGetRange(objv[1], first, last)); } return TCL_OK; } @@ -3790,7 +3790,7 @@ TclNRSwitchObjCmd( if (matchVarObj != NULL) { Tcl_Obj *substringObj; - substringObj = Tcl_GetRange(stringObj, + substringObj = TclGetRange(stringObj, info.matches[j].start, info.matches[j].end-1); /* diff --git a/generic/tclExecute.c b/generic/tclExecute.c index 0456146..965d821 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -5373,7 +5373,7 @@ TEBCresume( if (toIdx < 0) { TclNewObj(objResultPtr); } else { - objResultPtr = Tcl_GetRange(OBJ_AT_DEPTH(2), fromIdx, toIdx); + objResultPtr = TclGetRange(OBJ_AT_DEPTH(2), fromIdx, toIdx); } TRACE_APPEND(("\"%.30s\"\n", O2S(objResultPtr))); NEXT_INST_V(1, 3, 1); @@ -5414,7 +5414,7 @@ TEBCresume( if (toIdx < 0) { TclNewObj(objResultPtr); } else { - objResultPtr = Tcl_GetRange(valuePtr, fromIdx, toIdx); + objResultPtr = TclGetRange(valuePtr, fromIdx, toIdx); } } TRACE_APPEND(("%.30s\n", O2S(objResultPtr))); diff --git a/generic/tclInt.h b/generic/tclInt.h index 7486d60..b6cf3b4 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -3347,6 +3347,8 @@ MODULE_SCOPE int TclZipfs_Init(Tcl_Interp *interp); # define TclNumUtfChars Tcl_NumUtfChars # undef TclGetCharLength # define TclGetCharLength Tcl_GetCharLength +# undef TclUtfAtIndex +# define TclUtfAtIndex Tcl_UtfAtIndex # undef TclGetRange # define TclGetRange Tcl_GetRange #endif diff --git a/generic/tclStringObj.c b/generic/tclStringObj.c index 332d1d2..6032dbb 100644 --- a/generic/tclStringObj.c +++ b/generic/tclStringObj.c @@ -2449,7 +2449,7 @@ Tcl_AppendFormatToObj( if (precision < 1) { TclNewObj(segment); } else { - segment = Tcl_GetRange(segment, 0, precision - 1); + segment = TclGetRange(segment, 0, precision - 1); } numChars = precision; Tcl_IncrRefCount(segment); -- cgit v0.12 From 4576277c9931b6267da5083fb250652d077bb819 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 24 Mar 2022 13:58:06 +0000 Subject: Add TclGetUniChar() to the compatibility set --- generic/tcl.decls | 3 +++ generic/tclCmdMZ.c | 4 ++-- generic/tclDecls.h | 5 +++++ generic/tclExecute.c | 2 +- generic/tclInt.h | 4 ++++ generic/tclStringObj.c | 58 ++++++++++++++++++++++++++++++++++++++++++++++++++ generic/tclStubInit.c | 7 ++++++ 7 files changed, 80 insertions(+), 3 deletions(-) diff --git a/generic/tcl.decls b/generic/tcl.decls index f6a4c05..3b5c8a9 100644 --- a/generic/tcl.decls +++ b/generic/tcl.decls @@ -2466,6 +2466,9 @@ declare 671 { declare 672 { Tcl_Obj *TclGetRange(Tcl_Obj *objPtr, int first, int last) } +declare 673 { + int TclGetUniChar(Tcl_Obj *objPtr, int index) +} # ----- BASELINE -- FOR -- 8.7.0 ----- # diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c index 1beb732..29a73cf 100644 --- a/generic/tclCmdMZ.c +++ b/generic/tclCmdMZ.c @@ -310,7 +310,7 @@ Tcl_RegexpObjCmd( eflags = 0; } else if (offset > stringLength) { eflags = TCL_REG_NOTBOL; - } else if (Tcl_GetUniChar(objPtr, offset-1) == '\n') { + } else if (TclGetUniChar(objPtr, offset-1) == '\n') { eflags = 0; } else { eflags = TCL_REG_NOTBOL; @@ -1412,7 +1412,7 @@ StringIndexCmd( } if ((index >= 0) && (index < length)) { - int ch = Tcl_GetUniChar(objv[1], index); + int ch = TclGetUniChar(objv[1], index); if (ch == -1) { return TCL_OK; diff --git a/generic/tclDecls.h b/generic/tclDecls.h index fdf8673..ac90006 100644 --- a/generic/tclDecls.h +++ b/generic/tclDecls.h @@ -1971,6 +1971,8 @@ EXTERN int TclGetCharLength(Tcl_Obj *objPtr); EXTERN const char * TclUtfAtIndex(const char *src, int index); /* 672 */ EXTERN Tcl_Obj * TclGetRange(Tcl_Obj *objPtr, int first, int last); +/* 673 */ +EXTERN int TclGetUniChar(Tcl_Obj *objPtr, int index); typedef struct { const struct TclPlatStubs *tclPlatStubs; @@ -2679,6 +2681,7 @@ typedef struct TclStubs { int (*tclGetCharLength) (Tcl_Obj *objPtr); /* 670 */ const char * (*tclUtfAtIndex) (const char *src, int index); /* 671 */ Tcl_Obj * (*tclGetRange) (Tcl_Obj *objPtr, int first, int last); /* 672 */ + int (*tclGetUniChar) (Tcl_Obj *objPtr, int index); /* 673 */ } TclStubs; extern const TclStubs *tclStubsPtr; @@ -4048,6 +4051,8 @@ extern const TclStubs *tclStubsPtr; (tclStubsPtr->tclUtfAtIndex) /* 671 */ #define TclGetRange \ (tclStubsPtr->tclGetRange) /* 672 */ +#define TclGetUniChar \ + (tclStubsPtr->tclGetUniChar) /* 673 */ #endif /* defined(USE_TCL_STUBS) */ diff --git a/generic/tclExecute.c b/generic/tclExecute.c index 965d821..1f72d63 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -5329,7 +5329,7 @@ TEBCresume( valuePtr->bytes+index, 1); } else { char buf[4] = ""; - int ch = Tcl_GetUniChar(valuePtr, index); + int ch = TclGetUniChar(valuePtr, index); /* * This could be: Tcl_NewUnicodeObj((const Tcl_UniChar *)&ch, 1) diff --git a/generic/tclInt.h b/generic/tclInt.h index b6cf3b4..cc13c61 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -3335,6 +3335,8 @@ MODULE_SCOPE int TclZipfs_Init(Tcl_Interp *interp); # define Tcl_UtfAtIndex TclUtfAtIndex # undef Tcl_GetRange # define Tcl_GetRange TclGetRange +# undef Tcl_GetUniChar +# define Tcl_GetUniChar TclGetUniChar #else # define tclUniCharStringType tclStringType # define TclGetUnicodeFromObj_ Tcl_GetUnicodeFromObj @@ -3351,6 +3353,8 @@ MODULE_SCOPE int TclZipfs_Init(Tcl_Interp *interp); # define TclUtfAtIndex Tcl_UtfAtIndex # undef TclGetRange # define TclGetRange Tcl_GetRange +# undef TclGetUniChar +# define TclGetUniChar Tcl_GetUniChar #endif diff --git a/generic/tclStringObj.c b/generic/tclStringObj.c index 6032dbb..e8777cd 100644 --- a/generic/tclStringObj.c +++ b/generic/tclStringObj.c @@ -747,12 +747,70 @@ TclCheckEmptyString( *---------------------------------------------------------------------- */ +#if (TCL_UTF_MAX > 3) && !defined(TCL_NO_DEPRECATED) +#undef Tcl_GetUniChar int Tcl_GetUniChar( Tcl_Obj *objPtr, /* The object to get the Unicode charater * from. */ int index) /* Get the index'th Unicode character. */ { + String *stringPtr; + int ch, length; + + if (index < 0) { + return -1; + } + + /* + * Optimize the case where we're really dealing with a bytearray object + * we don't need to convert to a string to perform the indexing operation. + */ + + if (TclIsPureByteArray(objPtr)) { + unsigned char *bytes = Tcl_GetByteArrayFromObj(objPtr, &length); + if (index >= length) { + return -1; + } + + return (int) bytes[index]; + } + + /* + * OK, need to work with the object as a string. + */ + + SetUTF16StringFromAny(NULL, objPtr); + stringPtr = GET_STRING(objPtr); + + if (index >= stringPtr->numChars) { + return -1; + } + ch = stringPtr->unicode[index]; + /* See: bug [11ae2be95dac9417] */ + if ((ch & 0xF800) == 0xD800) { + if (ch & 0x400) { + if ((index > 0) + && ((stringPtr->unicode[index-1] & 0xFC00) == 0xD800)) { + ch = -1; /* low surrogate preceded by high surrogate */ + } + } else if ((++index < stringPtr->numChars) + && ((stringPtr->unicode[index] & 0xFC00) == 0xDC00)) { + /* high surrogate followed by low surrogate */ + ch = (((ch & 0x3FF) << 10) | + (stringPtr->unicode[index] & 0x3FF)) + 0x10000; + } + } + return ch; +} +#endif + +int +TclGetUniChar( + Tcl_Obj *objPtr, /* The object to get the Unicode charater + * from. */ + int index) /* Get the index'th Unicode character. */ +{ UniCharString *stringPtr; int ch, length; diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c index 2046938..fc78f74 100644 --- a/generic/tclStubInit.c +++ b/generic/tclStubInit.c @@ -49,6 +49,7 @@ #undef Tcl_UniCharLen #undef Tcl_UniCharNcmp #undef Tcl_GetRange +#undef Tcl_GetUniChar #undef Tcl_DumpActiveMemory #undef Tcl_ValidateAllMemory #undef Tcl_FindHashEntry @@ -79,6 +80,10 @@ #undef TclWinConvertError #undef Tcl_GetCharLength #undef Tcl_UtfAtIndex +#undef TclNumUtfChars +#undef TclGetCharLength +#undef TclUtfAtIndex +#undef TclGetUniChar #if defined(_WIN32) || defined(__CYGWIN__) #define TclWinConvertWSAError (void (*)(DWORD))(void *)Tcl_WinConvertError #define TclWinConvertError (void (*)(DWORD))(void *)Tcl_WinConvertError @@ -100,6 +105,7 @@ static void uniCodePanic(void) { # define Tcl_UniCharNcasecmp (int(*)(const unsigned short *, const unsigned short *, unsigned long))(void *)uniCodePanic # define Tcl_UniCharCaseMatch (int(*)(const unsigned short *, const unsigned short *, int))(void *)uniCodePanic # define Tcl_GetRange (Tcl_Obj *(*)(Tcl_Obj *, int, int))(void *)uniCodePanic +# define Tcl_GetUniChar (int(*)(Tcl_Obj *, int))(void *)uniCodePanic #endif #define TclUtfCharComplete UtfCharComplete @@ -1960,6 +1966,7 @@ const TclStubs tclStubs = { TclGetCharLength, /* 670 */ TclUtfAtIndex, /* 671 */ TclGetRange, /* 672 */ + TclGetUniChar, /* 673 */ }; /* !END!: Do not edit above this line. */ -- cgit v0.12 From db3553f6b2e985ce55fa6c42cb0bf268a06cdc70 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 24 Mar 2022 14:28:10 +0000 Subject: Add UTF-16 versions of Tcl_GetRange/Tcl_GetUniChar --- generic/tcl.decls | 10 ++++-- generic/tclDecls.h | 31 ++++++++++++++----- generic/tclStringObj.c | 83 ++++++++++++++++++++++++++++++++++++++++++++++++++ generic/tclStubInit.c | 6 ++-- 4 files changed, 118 insertions(+), 12 deletions(-) diff --git a/generic/tcl.decls b/generic/tcl.decls index 98419d6..d4f1c59 100644 --- a/generic/tcl.decls +++ b/generic/tcl.decls @@ -1399,14 +1399,14 @@ declare 380 { size_t TclGetCharLength(Tcl_Obj *objPtr) } declare 381 { - int Tcl_GetUniChar(Tcl_Obj *objPtr, size_t index) + int TclGetUniChar(Tcl_Obj *objPtr, size_t index) } # Removed in 9.0, replaced by macro. #declare 382 { # Tcl_UniChar *Tcl_GetUnicode(Tcl_Obj *objPtr) #} declare 383 { - Tcl_Obj *Tcl_GetRange(Tcl_Obj *objPtr, size_t first, size_t last) + Tcl_Obj *TclGetRange(Tcl_Obj *objPtr, size_t first, size_t last) } # Removed in 9.0 #declare 384 { @@ -2525,6 +2525,12 @@ declare 670 { declare 671 { const char *Tcl_UtfAtIndex(const char *src, size_t index) } +declare 672 { + Tcl_Obj *Tcl_GetRange(Tcl_Obj *objPtr, size_t first, size_t last) +} +declare 673 { + int Tcl_GetUniChar(Tcl_Obj *objPtr, size_t index) +} # ----- BASELINE -- FOR -- 8.7.0 ----- # diff --git a/generic/tclDecls.h b/generic/tclDecls.h index 81ce6f8..1345c6c 100644 --- a/generic/tclDecls.h +++ b/generic/tclDecls.h @@ -998,10 +998,10 @@ EXTERN void Tcl_SetUnicodeObj(Tcl_Obj *objPtr, /* 380 */ EXTERN size_t TclGetCharLength(Tcl_Obj *objPtr); /* 381 */ -EXTERN int Tcl_GetUniChar(Tcl_Obj *objPtr, size_t index); +EXTERN int TclGetUniChar(Tcl_Obj *objPtr, size_t index); /* Slot 382 is reserved */ /* 383 */ -EXTERN Tcl_Obj * Tcl_GetRange(Tcl_Obj *objPtr, size_t first, +EXTERN Tcl_Obj * TclGetRange(Tcl_Obj *objPtr, size_t first, size_t last); /* Slot 384 is reserved */ /* 385 */ @@ -1780,6 +1780,11 @@ EXTERN size_t Tcl_NumUtfChars(const char *src, size_t length); EXTERN size_t Tcl_GetCharLength(Tcl_Obj *objPtr); /* 671 */ EXTERN const char * Tcl_UtfAtIndex(const char *src, size_t index); +/* 672 */ +EXTERN Tcl_Obj * Tcl_GetRange(Tcl_Obj *objPtr, size_t first, + size_t last); +/* 673 */ +EXTERN int Tcl_GetUniChar(Tcl_Obj *objPtr, size_t index); typedef struct { const struct TclPlatStubs *tclPlatStubs; @@ -2172,9 +2177,9 @@ typedef struct TclStubs { 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 (*tclGetCharLength) (Tcl_Obj *objPtr); /* 380 */ - int (*tcl_GetUniChar) (Tcl_Obj *objPtr, size_t index); /* 381 */ + int (*tclGetUniChar) (Tcl_Obj *objPtr, size_t index); /* 381 */ void (*reserved382)(void); - Tcl_Obj * (*tcl_GetRange) (Tcl_Obj *objPtr, size_t first, size_t last); /* 383 */ + Tcl_Obj * (*tclGetRange) (Tcl_Obj *objPtr, size_t first, size_t last); /* 383 */ void (*reserved384)(void); int (*tcl_RegExpMatchObj) (Tcl_Interp *interp, Tcl_Obj *textObj, Tcl_Obj *patternObj); /* 385 */ void (*tcl_SetNotifier) (const Tcl_NotifierProcs *notifierProcPtr); /* 386 */ @@ -2463,6 +2468,8 @@ typedef struct TclStubs { 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 */ + Tcl_Obj * (*tcl_GetRange) (Tcl_Obj *objPtr, size_t first, size_t last); /* 672 */ + int (*tcl_GetUniChar) (Tcl_Obj *objPtr, size_t index); /* 673 */ } TclStubs; extern const TclStubs *tclStubsPtr; @@ -3187,11 +3194,11 @@ extern const TclStubs *tclStubsPtr; (tclStubsPtr->tcl_SetUnicodeObj) /* 379 */ #define TclGetCharLength \ (tclStubsPtr->tclGetCharLength) /* 380 */ -#define Tcl_GetUniChar \ - (tclStubsPtr->tcl_GetUniChar) /* 381 */ +#define TclGetUniChar \ + (tclStubsPtr->tclGetUniChar) /* 381 */ /* Slot 382 is reserved */ -#define Tcl_GetRange \ - (tclStubsPtr->tcl_GetRange) /* 383 */ +#define TclGetRange \ + (tclStubsPtr->tclGetRange) /* 383 */ /* Slot 384 is reserved */ #define Tcl_RegExpMatchObj \ (tclStubsPtr->tcl_RegExpMatchObj) /* 385 */ @@ -3751,6 +3758,10 @@ extern const TclStubs *tclStubsPtr; (tclStubsPtr->tcl_GetCharLength) /* 670 */ #define Tcl_UtfAtIndex \ (tclStubsPtr->tcl_UtfAtIndex) /* 671 */ +#define Tcl_GetRange \ + (tclStubsPtr->tcl_GetRange) /* 672 */ +#define Tcl_GetUniChar \ + (tclStubsPtr->tcl_GetUniChar) /* 673 */ #endif /* defined(USE_TCL_STUBS) */ @@ -3959,6 +3970,10 @@ extern const TclStubs *tclStubsPtr; # define Tcl_GetCharLength TclGetCharLength # undef Tcl_UtfAtIndex # define Tcl_UtfAtIndex TclUtfAtIndex +# undef Tcl_GetRange +# define Tcl_GetRange TclGetRange +# undef Tcl_GetUniChar +# define Tcl_GetUniChar TclGetUniChar #endif #endif #if defined(USE_TCL_STUBS) diff --git a/generic/tclStringObj.c b/generic/tclStringObj.c index 7e65ef1..dc64fcd 100644 --- a/generic/tclStringObj.c +++ b/generic/tclStringObj.c @@ -612,6 +612,40 @@ Tcl_GetUniChar( #endif return ch; } + +int +TclGetUniChar( + Tcl_Obj *objPtr, /* The object to get the Unicode charater + * from. */ + size_t index) /* Get the index'th Unicode character. */ +{ + int ch = 0; + + /* + * Optimize the case where we're really dealing with a bytearray object + * we don't need to convert to a string to perform the indexing operation. + */ + + if (TclIsPureByteArray(objPtr)) { + size_t length = 0; + unsigned char *bytes = Tcl_GetByteArrayFromObj(objPtr, &length); + if (index >= length) { + return -1; + } + + return bytes[index]; + } + + size_t numChars = TclNumUtfChars(objPtr->bytes, objPtr->length); + + if (index >= numChars) { + return -1; + } + const char *begin = TclUtfAtIndex(objPtr->bytes, index); + Tcl_UtfToUniChar(begin, &ch); + return ch; +} + /* *---------------------------------------------------------------------- @@ -792,6 +826,55 @@ Tcl_GetRange( #endif return Tcl_NewUnicodeObj(stringPtr->unicode + first, last - first + 1); } + +Tcl_Obj * +TclGetRange( + Tcl_Obj *objPtr, /* The Tcl object to find the range of. */ + size_t first, /* First index of the range. */ + size_t last) /* Last index of the range. */ +{ + Tcl_Obj *newObjPtr; /* The Tcl object to find the range of. */ + size_t length = 0; + + if (first == TCL_INDEX_NONE) { + first = TCL_INDEX_START; + } + if (last + 2 <= first + 1) { + return Tcl_NewObj(); + } + + /* + * Optimize the case where we're really dealing with a bytearray object + * we don't need to convert to a string to perform the substring operation. + */ + + if (TclIsPureByteArray(objPtr)) { + unsigned char *bytes = Tcl_GetByteArrayFromObj(objPtr, &length); + + if (last >= length) { + last = length - 1; + } + if (last < first) { + TclNewObj(newObjPtr); + return newObjPtr; + } + return Tcl_NewByteArrayObj(bytes + first, last - first + 1); + } + + size_t numChars = TclNumUtfChars(objPtr->bytes, objPtr->length); + + if (last >= numChars) { + last = numChars - 1; + } + if (last < first) { + TclNewObj(newObjPtr); + return newObjPtr; + } + const char *begin = TclUtfAtIndex(objPtr->bytes, first); + const char *end = TclUtfAtIndex(objPtr->bytes, last + 1); + return Tcl_NewStringObj(begin, end - begin); +} + /* *---------------------------------------------------------------------- diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c index 6704df8..704c51a 100644 --- a/generic/tclStubInit.c +++ b/generic/tclStubInit.c @@ -1074,9 +1074,9 @@ const TclStubs tclStubs = { Tcl_NewUnicodeObj, /* 378 */ Tcl_SetUnicodeObj, /* 379 */ TclGetCharLength, /* 380 */ - Tcl_GetUniChar, /* 381 */ + TclGetUniChar, /* 381 */ 0, /* 382 */ - Tcl_GetRange, /* 383 */ + TclGetRange, /* 383 */ 0, /* 384 */ Tcl_RegExpMatchObj, /* 385 */ Tcl_SetNotifier, /* 386 */ @@ -1365,6 +1365,8 @@ const TclStubs tclStubs = { Tcl_NumUtfChars, /* 669 */ Tcl_GetCharLength, /* 670 */ Tcl_UtfAtIndex, /* 671 */ + Tcl_GetRange, /* 672 */ + Tcl_GetUniChar, /* 673 */ }; /* !END!: Do not edit above this line. */ -- cgit v0.12 From 86d928056639a8d39313f7c4ddf273e3522ff70c Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 24 Mar 2022 21:24:26 +0000 Subject: More size_t --- generic/tclCompile.h | 10 +++++----- generic/tclDisassemble.c | 30 +++++++++++++++--------------- generic/tclExecute.c | 33 ++++++++++++++++----------------- generic/tclInt.h | 6 +++--- 4 files changed, 39 insertions(+), 40 deletions(-) diff --git a/generic/tclCompile.h b/generic/tclCompile.h index dc366c5..8ef81e8 100644 --- a/generic/tclCompile.h +++ b/generic/tclCompile.h @@ -461,11 +461,11 @@ typedef struct ByteCode { * by AuxData entries. */ 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. */ - int numAuxDataItems; /* Number of AuxData items. */ - int numCmdLocBytes; /* Number of bytes needed for encoded command + size_t numCodeBytes; /* Number of code bytes. */ + size_t numLitObjects; /* Number of objects in literal array. */ + size_t numExceptRanges; /* Number of ExceptionRange array elems. */ + size_t numAuxDataItems; /* Number of AuxData items. */ + size_t numCmdLocBytes; /* Number of bytes needed for encoded command * location information. */ int maxExceptDepth; /* Maximum nesting level of ExceptionRanges; * -1 if no ranges were compiled. */ diff --git a/generic/tclDisassemble.c b/generic/tclDisassemble.c index a8a9606..05eee35 100644 --- a/generic/tclDisassemble.c +++ b/generic/tclDisassemble.c @@ -288,25 +288,25 @@ DisassembleByteCodeObj( TclGetString(fileObj), line); } Tcl_AppendPrintfToObj(bufferObj, - "\n Cmds %d, src %d, inst %d, litObjs %u, aux %d, stkDepth %u, code/src %.2f\n", - numCmds, (int)codePtr->numSrcBytes, codePtr->numCodeBytes, + "\n Cmds %d, src %" TCL_Z_MODIFIER "u, inst %" TCL_Z_MODIFIER "u, litObjs %" TCL_Z_MODIFIER "u, aux %" TCL_Z_MODIFIER "u, stkDepth %u, code/src %.2f\n", + numCmds, codePtr->numSrcBytes, codePtr->numCodeBytes, codePtr->numLitObjects, codePtr->numAuxDataItems, codePtr->maxStackDepth, #ifdef TCL_COMPILE_STATS - (int)codePtr->numSrcBytes? + codePtr->numSrcBytes? codePtr->structureSize/(float)(int)codePtr->numSrcBytes : #endif 0.0); #ifdef TCL_COMPILE_STATS Tcl_AppendPrintfToObj(bufferObj, - " Code %lu = header %lu+inst %d+litObj %lu+exc %lu+aux %lu+cmdMap %d\n", - (unsigned long) codePtr->structureSize, - (unsigned long) (sizeof(ByteCode) - sizeof(size_t) - sizeof(Tcl_Time)), + " Code %" TCL_Z_MODIFIER "u = header %" TCL_Z_MODIFIER "u+inst %" TCL_Z_MODIFIER "u+litObj %" TCL_Z_MODIFIER "u+exc %" TCL_Z_MODIFIER "u+aux %" TCL_Z_MODIFIER "u+cmdMap %" TCL_Z_MODIFIER "u\n", + codePtr->structureSize, + sizeof(ByteCode) - sizeof(size_t) - sizeof(Tcl_Time), codePtr->numCodeBytes, - (unsigned long) (codePtr->numLitObjects * sizeof(Tcl_Obj *)), - (unsigned long) (codePtr->numExceptRanges*sizeof(ExceptionRange)), - (unsigned long) (codePtr->numAuxDataItems * sizeof(AuxData)), + codePtr->numLitObjects * sizeof(Tcl_Obj *), + codePtr->numExceptRanges*sizeof(ExceptionRange), + codePtr->numAuxDataItems * sizeof(AuxData), codePtr->numCmdLocBytes); #endif /* TCL_COMPILE_STATS */ @@ -351,10 +351,10 @@ DisassembleByteCodeObj( * Print the ExceptionRange array. */ - if (codePtr->numExceptRanges > 0) { - Tcl_AppendPrintfToObj(bufferObj, " Exception ranges %d, depth %d:\n", + if ((int)codePtr->numExceptRanges > 0) { + Tcl_AppendPrintfToObj(bufferObj, " Exception ranges %" TCL_Z_MODIFIER "u, depth %d:\n", codePtr->numExceptRanges, codePtr->maxExceptDepth); - for (i = 0; i < codePtr->numExceptRanges; i++) { + for (i = 0; i < (int)codePtr->numExceptRanges; i++) { ExceptionRange *rangePtr = &codePtr->exceptArrayPtr[i]; Tcl_AppendPrintfToObj(bufferObj, @@ -951,7 +951,7 @@ DisassembleByteCodeAsDicts( */ TclNewObj(literals); - for (i=0 ; inumLitObjects ; i++) { + for (i=0 ; i<(int)codePtr->numLitObjects ; i++) { Tcl_ListObjAppendElement(NULL, literals, codePtr->objArrayPtr[i]); } @@ -1111,7 +1111,7 @@ DisassembleByteCodeAsDicts( */ TclNewObj(aux); - for (i=0 ; inumAuxDataItems ; i++) { + for (i=0 ; i<(int)codePtr->numAuxDataItems ; i++) { AuxData *auxData = &codePtr->auxDataArrayPtr[i]; Tcl_Obj *auxDesc = Tcl_NewStringObj(auxData->type->name, -1); @@ -1138,7 +1138,7 @@ DisassembleByteCodeAsDicts( */ TclNewObj(exn); - for (i=0 ; inumExceptRanges ; i++) { + for (i=0 ; i<(int)codePtr->numExceptRanges ; i++) { ExceptionRange *rangePtr = &codePtr->exceptArrayPtr[i]; switch (rangePtr->type) { diff --git a/generic/tclExecute.c b/generic/tclExecute.c index 56dbc0d..af1ba69 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -8681,8 +8681,8 @@ 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", - (int)codePtr->numCommands, (int)codePtr->numSrcBytes, + fprintf(stdout, "\n Cmds %" TCL_Z_MODIFIER "u, src %" TCL_Z_MODIFIER "u, inst %" TCL_Z_MODIFIER "u, litObjs %" TCL_Z_MODIFIER "u, aux %" TCL_Z_MODIFIER "u, stkDepth %d, code/src %.2f\n", + codePtr->numCommands, codePtr->numSrcBytes, codePtr->numCodeBytes, codePtr->numLitObjects, codePtr->numAuxDataItems, codePtr->maxStackDepth, #ifdef TCL_COMPILE_STATS @@ -8692,13 +8692,13 @@ PrintByteCodeInfo( 0.0); #ifdef TCL_COMPILE_STATS - fprintf(stdout, " Code %lu = header %lu+inst %d+litObj %lu+exc %lu+aux %lu+cmdMap %d\n", - (unsigned long) codePtr->structureSize, - (unsigned long) (sizeof(ByteCode)-sizeof(size_t)-sizeof(Tcl_Time)), + fprintf(stdout, " Code %" TCL_Z_MODIFIER "u = header %" TCL_Z_MODIFIER "u+inst %" TCL_Z_MODIFIER "u+litObj %" TCL_Z_MODIFIER "u+exc %" TCL_Z_MODIFIER "u+aux %" TCL_Z_MODIFIER "u+cmdMap %" TCL_Z_MODIFIER "u\n", + codePtr->structureSize, + sizeof(ByteCode)-sizeof(size_t)-sizeof(Tcl_Time), codePtr->numCodeBytes, - (unsigned long) (codePtr->numLitObjects * sizeof(Tcl_Obj *)), - (unsigned long) (codePtr->numExceptRanges*sizeof(ExceptionRange)), - (unsigned long) (codePtr->numAuxDataItems * sizeof(AuxData)), + codePtr->numLitObjects * sizeof(Tcl_Obj *), + codePtr->numExceptRanges*sizeof(ExceptionRange), + codePtr->numAuxDataItems * sizeof(AuxData), codePtr->numCmdLocBytes); #endif /* TCL_COMPILE_STATS */ if (procPtr != NULL) { @@ -8744,20 +8744,19 @@ ValidatePcAndStackTop( { int stackUpperBound = codePtr->maxStackDepth; /* Greatest legal value for stackTop. */ - size_t relativePc = (size_t) (pc - codePtr->codeStart); - size_t codeStart = (size_t) codePtr->codeStart; - size_t codeEnd = (size_t) - (codePtr->codeStart + codePtr->numCodeBytes); + size_t relativePc = pc - codePtr->codeStart; + const unsigned char *codeStart = codePtr->codeStart; + const unsigned char *codeEnd = codePtr->codeStart + codePtr->numCodeBytes; unsigned char opCode = *pc; - if (((size_t) pc < codeStart) || ((size_t) pc > codeEnd)) { + if ((pc < codeStart) || (pc > codeEnd)) { fprintf(stderr, "\nBad instruction pc 0x%p in TclNRExecuteByteCode\n", pc); Tcl_Panic("TclNRExecuteByteCode execution failure: bad pc"); } - if ((unsigned) opCode >= LAST_INST_OPCODE) { - fprintf(stderr, "\nBad opcode %d at pc %" TCL_Z_MODIFIER "u in TclNRExecuteByteCode\n", - (unsigned) opCode, relativePc); + if (opCode >= LAST_INST_OPCODE) { + fprintf(stderr, "\nBad opcode %u at pc %" TCL_Z_MODIFIER "u in TclNRExecuteByteCode\n", + opCode, relativePc); Tcl_Panic("TclNRExecuteByteCode execution failure: bad opcode"); } if (checkStack && @@ -8979,7 +8978,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 diff --git a/generic/tclInt.h b/generic/tclInt.h index 874d9c8..10d5913 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -1259,7 +1259,7 @@ typedef struct CmdFrame { typedef struct CFWord { CmdFrame *framePtr; /* CmdFrame to access. */ - int word; /* Index of the word in the command. */ + size_t word; /* Index of the word in the command. */ size_t refCount; /* Number of times the word is on the * stack. */ } CFWord; @@ -1268,7 +1268,7 @@ typedef struct CFWordBC { CmdFrame *framePtr; /* CmdFrame to access. */ size_t pc; /* Instruction pointer of a command in * ExtCmdLoc.loc[.] */ - int word; /* Index of word in + size_t word; /* Index of word in * ExtCmdLoc.loc[cmd]->line[.] */ struct CFWordBC *prevPtr; /* Previous entry in stack for same Tcl_Obj. */ struct CFWordBC *nextPtr; /* Next entry for same command call. See @@ -1947,7 +1947,7 @@ typedef struct Interp { /* First in list of active traces for interp, * or NULL if no active traces. */ - int tracesForbiddingInline; /* Count of traces (in the list headed by + size_t tracesForbiddingInline; /* Count of traces (in the list headed by * tracePtr) that forbid inline bytecode * compilation. */ -- cgit v0.12 From 75fffb6cb1f7ecccb2e0ab2a471bfb0628aea709 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 24 Mar 2022 22:18:04 +0000 Subject: size_t continued --- generic/tclBasic.c | 2 +- generic/tclCompCmds.c | 8 ++++---- generic/tclCompile.h | 8 ++++---- generic/tclEnsemble.c | 2 +- generic/tclExecute.c | 2 +- 5 files changed, 11 insertions(+), 11 deletions(-) diff --git a/generic/tclBasic.c b/generic/tclBasic.c index 5cf15ce..ae89552 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -2006,7 +2006,7 @@ DeleteInterpProc( if (eclPtr->type == TCL_LOCATION_SOURCE) { Tcl_DecrRefCount(eclPtr->path); } - for (i=0; i< eclPtr->nuloc; i++) { + for (i=0; i< (int)eclPtr->nuloc; i++) { Tcl_Free(eclPtr->loc[i].line); } diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c index 6522640..7d1fbb9 100644 --- a/generic/tclCompCmds.c +++ b/generic/tclCompCmds.c @@ -1793,7 +1793,7 @@ TclCompileDictUpdateCmd( * that are to be used. */ - duiPtr = (DictUpdateInfo *)Tcl_Alloc(offsetof(DictUpdateInfo, varIndices) + sizeof(int) * numVars); + duiPtr = (DictUpdateInfo *)Tcl_Alloc(offsetof(DictUpdateInfo, varIndices) + sizeof(size_t) * numVars); duiPtr->length = numVars; keyTokenPtrs = (Tcl_Token **)TclStackAlloc(interp, sizeof(Tcl_Token *) * numVars); tokenPtr = TokenAfter(dictVarTokenPtr); @@ -1812,7 +1812,7 @@ TclCompileDictUpdateCmd( */ duiPtr->varIndices[i] = LocalScalarFromToken(tokenPtr, envPtr); - if (duiPtr->varIndices[i] < 0) { + if (duiPtr->varIndices[i] == TCL_INDEX_NONE) { goto failedUpdateInfoAssembly; } tokenPtr = TokenAfter(tokenPtr); @@ -2275,7 +2275,7 @@ DupDictUpdateInfo( size_t len; dui1Ptr = (DictUpdateInfo *)clientData; - len = offsetof(DictUpdateInfo, varIndices) + sizeof(int) * dui1Ptr->length; + len = offsetof(DictUpdateInfo, varIndices) + sizeof(size_t) * dui1Ptr->length; dui2Ptr = (DictUpdateInfo *)Tcl_Alloc(len); memcpy(dui2Ptr, dui1Ptr, len); return dui2Ptr; @@ -2302,7 +2302,7 @@ PrintDictUpdateInfo( if (i) { Tcl_AppendToObj(appendObj, ", ", -1); } - Tcl_AppendPrintfToObj(appendObj, "%%v%u", duiPtr->varIndices[i]); + Tcl_AppendPrintfToObj(appendObj, "%%v%" TCL_Z_MODIFIER "u", duiPtr->varIndices[i]); } } diff --git a/generic/tclCompile.h b/generic/tclCompile.h index 8ef81e8..fc5b498 100644 --- a/generic/tclCompile.h +++ b/generic/tclCompile.h @@ -198,8 +198,8 @@ typedef struct { Tcl_Obj *path; /* Path of the sourced file the command is * in. */ ECL *loc; /* Command word locations (lines). */ - int nloc; /* Number of allocated entries in 'loc'. */ - int nuloc; /* Number of used entries in 'loc'. */ + size_t nloc; /* Number of allocated entries in 'loc'. */ + size_t nuloc; /* Number of used entries in 'loc'. */ } ExtCmdLoc; /* @@ -1035,7 +1035,7 @@ MODULE_SCOPE const AuxDataType tclJumptableInfoType; typedef struct { size_t length; /* Size of array */ - int varIndices[TCLFLEXARRAY]; /* Array of variable indices to manage when + size_t varIndices[TCLFLEXARRAY]; /* Array of variable indices to manage when * processing the start and end of a [dict * update]. There is really more than one * entry, and the structure is allocated to @@ -1637,7 +1637,7 @@ MODULE_SCOPE int TclPushProcCallFrame(void *clientData, #define DefineLineInformation \ ExtCmdLoc *mapPtr = envPtr->extCmdMapPtr; \ - int eclIndex = mapPtr->nuloc - 1 + size_t eclIndex = mapPtr->nuloc - 1 #define SetLineInformation(word) \ envPtr->line = mapPtr->loc[eclIndex].line[(word)]; \ diff --git a/generic/tclEnsemble.c b/generic/tclEnsemble.c index 59961d9..873ba78 100644 --- a/generic/tclEnsemble.c +++ b/generic/tclEnsemble.c @@ -3180,7 +3180,7 @@ TclCompileEnsemble( * Throw out any line information generated by the failed compile attempt. */ - while (mapPtr->nuloc - 1 > eclIndex) { + while (mapPtr->nuloc > eclIndex + 1) { mapPtr->nuloc--; Tcl_Free(mapPtr->loc[mapPtr->nuloc].line); mapPtr->loc[mapPtr->nuloc].line = NULL; diff --git a/generic/tclExecute.c b/generic/tclExecute.c index af1ba69..5628167 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -8923,7 +8923,7 @@ TclGetSrcInfoForPc( srcOffset = cfPtr->cmd - codePtr->source; eclPtr = (ExtCmdLoc *)Tcl_GetHashValue(hePtr); - for (i=0; i < eclPtr->nuloc; i++) { + for (i=0; i < (int)eclPtr->nuloc; i++) { if (eclPtr->loc[i].srcOffset == srcOffset) { locPtr = eclPtr->loc+i; break; -- cgit v0.12 From 0dba465244f6e7cc0396e739ead01dd2575aaf2b Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 24 Mar 2022 22:55:32 +0000 Subject: Bugfix for TclGetCharLength(): Make sure objPtr->bytes is filled --- generic/tclStringObj.c | 1 + 1 file changed, 1 insertion(+) diff --git a/generic/tclStringObj.c b/generic/tclStringObj.c index dc64fcd..7cee05d 100644 --- a/generic/tclStringObj.c +++ b/generic/tclStringObj.c @@ -477,6 +477,7 @@ TclGetCharLength( if (TclIsPureByteArray(objPtr)) { (void) Tcl_GetByteArrayFromObj(objPtr, &numChars); } else { + Tcl_GetString(objPtr); numChars = TclNumUtfChars(objPtr->bytes, objPtr->length); } -- cgit v0.12 From 5438d045182b2bc669f663a22728d7306c459112 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 24 Mar 2022 23:29:50 +0000 Subject: bugfix: Handle NULL characters in Tcl_GetCharLength() --- generic/tclStringObj.c | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/generic/tclStringObj.c b/generic/tclStringObj.c index e8777cd..988c6e5 100644 --- a/generic/tclStringObj.c +++ b/generic/tclStringObj.c @@ -681,7 +681,8 @@ Tcl_GetCharLength( (void) Tcl_GetByteArrayFromObj(objPtr, &numChars); } else { - numChars = Tcl_NumUtfChars(Tcl_GetString(objPtr), -1); + Tcl_GetString(objPtr); + numChars = Tcl_NumUtfChars(objPtr->bytes, objPtr->length); } return numChars; } -- cgit v0.12 From f768cd1df73e1d1801bef8b03e89609d1bb6f885 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 25 Mar 2022 08:20:31 +0000 Subject: Put back Tcl_AppendUnicodeToObj() --- ChangeLog.1999 | 2 +- generic/tcl.decls | 9 ++++----- generic/tclCmdMZ.c | 38 +++++++++++++++++++------------------- generic/tclDecls.h | 9 ++++++--- generic/tclExecute.c | 6 +++--- generic/tclInt.decls | 5 ----- generic/tclIntDecls.h | 9 +++------ generic/tclStringObj.c | 10 +++++----- generic/tclStubInit.c | 6 +++--- generic/tclTestObj.c | 2 +- 10 files changed, 45 insertions(+), 51 deletions(-) diff --git a/ChangeLog.1999 b/ChangeLog.1999 index 3bf4e9a..4d88b61 100644 --- a/ChangeLog.1999 +++ b/ChangeLog.1999 @@ -1226,7 +1226,7 @@ 1999-06-09 Scott Stanton * generic/tclUnicodeObj.c: Lots of cleanup and simplification. Fixed - several memory bugs. Added TclAppendUnicodeToObj. + several memory bugs. Added Tcl_AppendUnicodeToObj. * generic/tclInt.h: Added declarations for various Unicode string functions. diff --git a/generic/tcl.decls b/generic/tcl.decls index d4f1c59..731baa8 100644 --- a/generic/tcl.decls +++ b/generic/tcl.decls @@ -1408,11 +1408,10 @@ declare 381 { declare 383 { Tcl_Obj *TclGetRange(Tcl_Obj *objPtr, size_t first, size_t last) } -# Removed in 9.0 -#declare 384 { -# void Tcl_AppendUnicodeToObj(Tcl_Obj *objPtr, const Tcl_UniChar *unicode, -# int length) -#} +declare 384 { + void Tcl_AppendUnicodeToObj(Tcl_Obj *objPtr, const Tcl_UniChar *unicode, + size_t length) +} declare 385 { int Tcl_RegExpMatchObj(Tcl_Interp *interp, Tcl_Obj *textObj, Tcl_Obj *patternObj) diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c index 85174ec..534a5ae 100644 --- a/generic/tclCmdMZ.c +++ b/generic/tclCmdMZ.c @@ -624,8 +624,8 @@ Tcl_RegsubObjCmd( resultPtr = Tcl_NewUnicodeObj(wstring, 0); Tcl_IncrRefCount(resultPtr); for (; wstring < wend; wstring++) { - TclAppendUnicodeToObj(resultPtr, wsubspec, wsublen); - TclAppendUnicodeToObj(resultPtr, wstring, 1); + Tcl_AppendUnicodeToObj(resultPtr, wsubspec, wsublen); + Tcl_AppendUnicodeToObj(resultPtr, wstring, 1); numMatches++; } wlen = 0; @@ -641,14 +641,14 @@ Tcl_RegsubObjCmd( Tcl_IncrRefCount(resultPtr); } if (p != wstring) { - TclAppendUnicodeToObj(resultPtr, p, wstring - p); + Tcl_AppendUnicodeToObj(resultPtr, p, wstring - p); p = wstring + slen; } else { p += slen; } wstring = p - 1; - TclAppendUnicodeToObj(resultPtr, wsubspec, wsublen); + Tcl_AppendUnicodeToObj(resultPtr, wsubspec, wsublen); numMatches++; } } @@ -751,7 +751,7 @@ Tcl_RegsubObjCmd( * specified. */ - TclAppendUnicodeToObj(resultPtr, wstring, offset); + Tcl_AppendUnicodeToObj(resultPtr, wstring, offset); } } numMatches++; @@ -764,7 +764,7 @@ Tcl_RegsubObjCmd( Tcl_RegExpGetInfo(regExpr, &info); start = info.matches[0].start; end = info.matches[0].end; - TclAppendUnicodeToObj(resultPtr, wstring + offset, start); + Tcl_AppendUnicodeToObj(resultPtr, wstring + offset, start); /* * In command-prefix mode, the substitutions are added as quoted @@ -839,7 +839,7 @@ Tcl_RegsubObjCmd( */ if (offset < wlen) { - TclAppendUnicodeToObj(resultPtr, wstring + offset, 1); + Tcl_AppendUnicodeToObj(resultPtr, wstring + offset, 1); } offset++; } @@ -868,7 +868,7 @@ Tcl_RegsubObjCmd( idx = ch - '0'; } else if ((ch == '\\') || (ch == '&')) { *wsrc = ch; - TclAppendUnicodeToObj(resultPtr, wfirstChar, + Tcl_AppendUnicodeToObj(resultPtr, wfirstChar, wsrc - wfirstChar + 1); *wsrc = '\\'; wfirstChar = wsrc + 2; @@ -882,7 +882,7 @@ Tcl_RegsubObjCmd( } if (wfirstChar != wsrc) { - TclAppendUnicodeToObj(resultPtr, wfirstChar, + Tcl_AppendUnicodeToObj(resultPtr, wfirstChar, wsrc - wfirstChar); } @@ -890,7 +890,7 @@ Tcl_RegsubObjCmd( subStart = info.matches[idx].start; subEnd = info.matches[idx].end; if ((subStart != TCL_INDEX_NONE) && (subEnd != TCL_INDEX_NONE)) { - TclAppendUnicodeToObj(resultPtr, + Tcl_AppendUnicodeToObj(resultPtr, wstring + offset + subStart, subEnd - subStart); } } @@ -902,7 +902,7 @@ Tcl_RegsubObjCmd( } if (wfirstChar != wsrc) { - TclAppendUnicodeToObj(resultPtr, wfirstChar, wsrc - wfirstChar); + Tcl_AppendUnicodeToObj(resultPtr, wfirstChar, wsrc - wfirstChar); } if (end == 0) { @@ -912,7 +912,7 @@ Tcl_RegsubObjCmd( */ if (offset < wlen) { - TclAppendUnicodeToObj(resultPtr, wstring + offset, 1); + Tcl_AppendUnicodeToObj(resultPtr, wstring + offset, 1); } offset++; } else { @@ -924,7 +924,7 @@ Tcl_RegsubObjCmd( */ if (offset < wlen) { - TclAppendUnicodeToObj(resultPtr, wstring + offset, 1); + Tcl_AppendUnicodeToObj(resultPtr, wstring + offset, 1); } offset++; } @@ -949,7 +949,7 @@ Tcl_RegsubObjCmd( resultPtr = objv[1]; Tcl_IncrRefCount(resultPtr); } else if (offset < wlen) { - TclAppendUnicodeToObj(resultPtr, wstring + offset, wlen - offset); + Tcl_AppendUnicodeToObj(resultPtr, wstring + offset, wlen - offset); } if (objc == 4) { if (Tcl_ObjSetVar2(interp, objv[3], NULL, resultPtr, @@ -2112,14 +2112,14 @@ StringMapCmd( (length2==1 || strCmpFn(ustring1, ustring2, length2) == 0)) { if (p != ustring1) { - TclAppendUnicodeToObj(resultPtr, p, ustring1-p); + Tcl_AppendUnicodeToObj(resultPtr, p, ustring1-p); p = ustring1 + length2; } else { p += length2; } ustring1 = p - 1; - TclAppendUnicodeToObj(resultPtr, mapString, mapLen); + Tcl_AppendUnicodeToObj(resultPtr, mapString, mapLen); } } } @@ -2165,7 +2165,7 @@ StringMapCmd( * Put the skipped chars onto the result first. */ - TclAppendUnicodeToObj(resultPtr, p, ustring1-p); + Tcl_AppendUnicodeToObj(resultPtr, p, ustring1-p); p = ustring1 + length2; } else { p += length2; @@ -2181,7 +2181,7 @@ StringMapCmd( * Append the map value to the unicode string. */ - TclAppendUnicodeToObj(resultPtr, + Tcl_AppendUnicodeToObj(resultPtr, mapStrings[index+1], mapLens[index+1]); break; } @@ -2198,7 +2198,7 @@ StringMapCmd( * Put the rest of the unmapped chars onto result. */ - TclAppendUnicodeToObj(resultPtr, p, ustring1 - p); + Tcl_AppendUnicodeToObj(resultPtr, p, ustring1 - p); } Tcl_SetObjResult(interp, resultPtr); done: diff --git a/generic/tclDecls.h b/generic/tclDecls.h index 1345c6c..d95b965 100644 --- a/generic/tclDecls.h +++ b/generic/tclDecls.h @@ -1003,7 +1003,9 @@ EXTERN int TclGetUniChar(Tcl_Obj *objPtr, size_t index); /* 383 */ EXTERN Tcl_Obj * TclGetRange(Tcl_Obj *objPtr, size_t first, size_t last); -/* Slot 384 is reserved */ +/* 384 */ +EXTERN void Tcl_AppendUnicodeToObj(Tcl_Obj *objPtr, + const Tcl_UniChar *unicode, size_t length); /* 385 */ EXTERN int Tcl_RegExpMatchObj(Tcl_Interp *interp, Tcl_Obj *textObj, Tcl_Obj *patternObj); @@ -2180,7 +2182,7 @@ typedef struct TclStubs { int (*tclGetUniChar) (Tcl_Obj *objPtr, size_t index); /* 381 */ void (*reserved382)(void); Tcl_Obj * (*tclGetRange) (Tcl_Obj *objPtr, size_t first, size_t last); /* 383 */ - void (*reserved384)(void); + void (*tcl_AppendUnicodeToObj) (Tcl_Obj *objPtr, const Tcl_UniChar *unicode, size_t 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 */ @@ -3199,7 +3201,8 @@ extern const TclStubs *tclStubsPtr; /* Slot 382 is reserved */ #define TclGetRange \ (tclStubsPtr->tclGetRange) /* 383 */ -/* Slot 384 is reserved */ +#define Tcl_AppendUnicodeToObj \ + (tclStubsPtr->tcl_AppendUnicodeToObj) /* 384 */ #define Tcl_RegExpMatchObj \ (tclStubsPtr->tcl_RegExpMatchObj) /* 385 */ #define Tcl_SetNotifier \ diff --git a/generic/tclExecute.c b/generic/tclExecute.c index d3b9dac..2c08b7d 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -5297,14 +5297,14 @@ TEBCresume( memcmp(ustring1, ustring2, sizeof(Tcl_UniChar) * length2) == 0)) { if (p != ustring1) { - TclAppendUnicodeToObj(objResultPtr, p, ustring1-p); + Tcl_AppendUnicodeToObj(objResultPtr, p, ustring1-p); p = ustring1 + length2; } else { p += length2; } ustring1 = p - 1; - TclAppendUnicodeToObj(objResultPtr, ustring3, length3); + Tcl_AppendUnicodeToObj(objResultPtr, ustring3, length3); } } if (p != ustring1) { @@ -5312,7 +5312,7 @@ TEBCresume( * Put the rest of the unmapped chars onto result. */ - TclAppendUnicodeToObj(objResultPtr, p, ustring1 - p); + Tcl_AppendUnicodeToObj(objResultPtr, p, ustring1 - p); } doneStringMap: TRACE_WITH_OBJ(("%.20s %.20s %.20s => ", diff --git a/generic/tclInt.decls b/generic/tclInt.decls index 2d91d0a..79694a7 100644 --- a/generic/tclInt.decls +++ b/generic/tclInt.decls @@ -478,11 +478,6 @@ 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 { diff --git a/generic/tclIntDecls.h b/generic/tclIntDecls.h index 48cec3d..bf05a0e 100644 --- a/generic/tclIntDecls.h +++ b/generic/tclIntDecls.h @@ -500,9 +500,7 @@ EXTERN Var * TclVarHashCreateVar(TclVarHashTable *tablePtr, /* 235 */ EXTERN void TclInitVarHashTable(TclVarHashTable *tablePtr, Namespace *nsPtr); -/* 236 */ -EXTERN void TclAppendUnicodeToObj(Tcl_Obj *objPtr, - const Tcl_UniChar *unicode, size_t length); +/* Slot 236 is reserved */ /* 237 */ EXTERN int TclResetCancellation(Tcl_Interp *interp, int force); /* 238 */ @@ -819,7 +817,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 (*tclAppendUnicodeToObj) (Tcl_Obj *objPtr, const Tcl_UniChar *unicode, size_t length); /* 236 */ + void (*reserved236)(void); 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, size_t skip, ProcErrorProc *errorProc); /* 239 */ @@ -1211,8 +1209,7 @@ extern const TclIntStubs *tclIntStubsPtr; (tclIntStubsPtr->tclVarHashCreateVar) /* 234 */ #define TclInitVarHashTable \ (tclIntStubsPtr->tclInitVarHashTable) /* 235 */ -#define TclAppendUnicodeToObj \ - (tclIntStubsPtr->tclAppendUnicodeToObj) /* 236 */ +/* Slot 236 is reserved */ #define TclResetCancellation \ (tclIntStubsPtr->tclResetCancellation) /* 237 */ #define TclNRInterpProc \ diff --git a/generic/tclStringObj.c b/generic/tclStringObj.c index 7cee05d..b5c6520 100644 --- a/generic/tclStringObj.c +++ b/generic/tclStringObj.c @@ -1331,7 +1331,7 @@ Tcl_AppendToObj( /* *---------------------------------------------------------------------- * - * TclAppendUnicodeToObj -- + * Tcl_AppendUnicodeToObj -- * * This function appends a Unicode string to an object in the most * efficient manner possible. Length must be >= 0. @@ -1346,7 +1346,7 @@ Tcl_AppendToObj( */ void -TclAppendUnicodeToObj( +Tcl_AppendUnicodeToObj( Tcl_Obj *objPtr, /* Points to the object to append to. */ const Tcl_UniChar *unicode, /* The unicode string to append to the * object. */ @@ -1355,7 +1355,7 @@ TclAppendUnicodeToObj( String *stringPtr; if (Tcl_IsShared(objPtr)) { - Tcl_Panic("%s called with shared object", "TclAppendUnicodeToObj"); + Tcl_Panic("%s called with shared object", "Tcl_AppendUnicodeToObj"); } if (length == 0) { @@ -3012,7 +3012,7 @@ TclStringRepeat( Tcl_AppendObjToObj(objResultPtr, objResultPtr); done *= 2; } - TclAppendUnicodeToObj(objResultPtr, Tcl_GetUnicode(objResultPtr), + Tcl_AppendUnicodeToObj(objResultPtr, Tcl_GetUnicode(objResultPtr), (count - done) * length); } else { /* @@ -4116,7 +4116,7 @@ TclStringReplace( Tcl_AppendObjToObj(result, insertPtr); } if (first + count < (size_t)numChars) { - TclAppendUnicodeToObj(result, ustring + first + count, + Tcl_AppendUnicodeToObj(result, ustring + first + count, numChars - first - count); } diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c index 704c51a..9f052e3 100644 --- a/generic/tclStubInit.c +++ b/generic/tclStubInit.c @@ -81,7 +81,7 @@ static void uniCodePanic() { # define TclGetUnicodeFromObj (Tcl_UniChar *(*)(Tcl_Obj *, int *))(void *)uniCodePanic # define Tcl_NewUnicodeObj (Tcl_Obj *(*)(const Tcl_UniChar *, size_t))(void *)uniCodePanic # define Tcl_SetUnicodeObj (void(*)(Tcl_Obj *, const Tcl_UniChar *, size_t))(void *)uniCodePanic -# define TclAppendUnicodeToObj (void(*)(Tcl_Obj *, const Tcl_UniChar *, size_t))(void *)uniCodePanic +# define Tcl_AppendUnicodeToObj (void(*)(Tcl_Obj *, const Tcl_UniChar *, size_t))(void *)uniCodePanic #endif #define TclUtfCharComplete Tcl_UtfCharComplete @@ -528,7 +528,7 @@ static const TclIntStubs tclIntStubs = { TclGetSrcInfoForPc, /* 233 */ TclVarHashCreateVar, /* 234 */ TclInitVarHashTable, /* 235 */ - TclAppendUnicodeToObj, /* 236 */ + 0, /* 236 */ TclResetCancellation, /* 237 */ TclNRInterpProc, /* 238 */ TclNRInterpProcCore, /* 239 */ @@ -1077,7 +1077,7 @@ const TclStubs tclStubs = { TclGetUniChar, /* 381 */ 0, /* 382 */ TclGetRange, /* 383 */ - 0, /* 384 */ + Tcl_AppendUnicodeToObj, /* 384 */ Tcl_RegExpMatchObj, /* 385 */ Tcl_SetNotifier, /* 386 */ Tcl_GetAllocMutex, /* 387 */ diff --git a/generic/tclTestObj.c b/generic/tclTestObj.c index 7ea1723..388eae6 100644 --- a/generic/tclTestObj.c +++ b/generic/tclTestObj.c @@ -1377,7 +1377,7 @@ TeststringobjCmd( return TCL_ERROR; } - TclAppendUnicodeToObj(varPtr[varIndex], unicode + length, size - length); + Tcl_AppendUnicodeToObj(varPtr[varIndex], unicode + length, size - length); Tcl_SetObjResult(interp, varPtr[varIndex]); break; } -- cgit v0.12 From 29b5c15de58bfb8f522ebfcde30d4ded5712d4a2 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 25 Mar 2022 12:14:41 +0000 Subject: Unbreak build with-DTCL_UTF_MAX=3 --- generic/tclStubInit.c | 5 +---- 1 file changed, 1 insertion(+), 4 deletions(-) diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c index fc78f74..7d04481 100644 --- a/generic/tclStubInit.c +++ b/generic/tclStubInit.c @@ -80,10 +80,7 @@ #undef TclWinConvertError #undef Tcl_GetCharLength #undef Tcl_UtfAtIndex -#undef TclNumUtfChars -#undef TclGetCharLength -#undef TclUtfAtIndex -#undef TclGetUniChar + #if defined(_WIN32) || defined(__CYGWIN__) #define TclWinConvertWSAError (void (*)(DWORD))(void *)Tcl_WinConvertError #define TclWinConvertError (void (*)(DWORD))(void *)Tcl_WinConvertError -- cgit v0.12 From d4140ec31b18515b482006a2d9cac7e2d281f8db Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Sat, 26 Mar 2022 23:02:29 +0000 Subject: Don't run obj-1.1 test with -DTCL_NO_DEPRECATED --- tests/obj.test | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/tests/obj.test b/tests/obj.test index 4fa8d3a..7563422 100644 --- a/tests/obj.test +++ b/tests/obj.test @@ -19,11 +19,13 @@ if {"::tcltest" ni [namespace children]} { ::tcltest::loadTestedCommands catch [list package require -exact tcl::test [info patchlevel]] +package require tcltests + testConstraint testobj [llength [info commands testobj]] testConstraint longIs32bit [expr {$tcl_platform(wordSize) == 4}] testConstraint wideIs64bit [expr {wide(0x8000000000000000) < 0}] -test obj-1.1 {Tcl_AppendAllObjTypes, and InitTypeTable, Tcl_RegisterObjType} testobj { +test obj-1.1 {Tcl_AppendAllObjTypes, and InitTypeTable, Tcl_RegisterObjType} {testobj deprecated} { set r 1 foreach {t} { bytearray -- cgit v0.12 From 20c62d4e42ddeff9c9cc116bab6dbea372132c38 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 28 Mar 2022 10:07:15 +0000 Subject: Fix some compiler warnings --- generic/tclCompile.c | 2 +- generic/tclIO.c | 104 +++++++++++++++++++++++++-------------------------- generic/tclIO.h | 4 +- 3 files changed, 55 insertions(+), 55 deletions(-) diff --git a/generic/tclCompile.c b/generic/tclCompile.c index 0a5518d..1db793f 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -1382,7 +1382,7 @@ static void ReleaseCmdWordData( ExtCmdLoc *eclPtr) { - int i; + size_t i; if (eclPtr->type == TCL_LOCATION_SOURCE) { Tcl_DecrRefCount(eclPtr->path); diff --git a/generic/tclIO.c b/generic/tclIO.c index ee847ac..5e87d36 100644 --- a/generic/tclIO.c +++ b/generic/tclIO.c @@ -275,21 +275,21 @@ static int WillRead(Channel *chanPtr); * -------------------------------------------------------------------------- */ -#define BytesLeft(bufPtr) (((bufPtr)->nextAdded1 - (bufPtr)->nextRemoved1)) +#define BytesLeft(bufPtr) (((bufPtr)->nextAdded - (bufPtr)->nextRemoved)) -#define SpaceLeft(bufPtr) (((bufPtr)->bufLength - (bufPtr)->nextAdded1)) +#define SpaceLeft(bufPtr) (((bufPtr)->bufLength - (bufPtr)->nextAdded)) -#define IsBufferReady(bufPtr) ((bufPtr)->nextAdded1 > (bufPtr)->nextRemoved1) +#define IsBufferReady(bufPtr) ((bufPtr)->nextAdded > (bufPtr)->nextRemoved) -#define IsBufferEmpty(bufPtr) ((bufPtr)->nextAdded1 == (bufPtr)->nextRemoved1) +#define IsBufferEmpty(bufPtr) ((bufPtr)->nextAdded == (bufPtr)->nextRemoved) -#define IsBufferFull(bufPtr) ((bufPtr) && (bufPtr)->nextAdded1 >= (bufPtr)->bufLength) +#define IsBufferFull(bufPtr) ((bufPtr) && (bufPtr)->nextAdded >= (bufPtr)->bufLength) -#define IsBufferOverflowing(bufPtr) ((bufPtr)->nextAdded1>(bufPtr)->bufLength) +#define IsBufferOverflowing(bufPtr) ((bufPtr)->nextAdded>(bufPtr)->bufLength) -#define InsertPoint(bufPtr) (&(bufPtr)->buf[(bufPtr)->nextAdded1]) +#define InsertPoint(bufPtr) (&(bufPtr)->buf[(bufPtr)->nextAdded]) -#define RemovePoint(bufPtr) (&(bufPtr)->buf[(bufPtr)->nextRemoved1]) +#define RemovePoint(bufPtr) (&(bufPtr)->buf[(bufPtr)->nextRemoved]) /* * For working with channel state flag bits. @@ -2453,8 +2453,8 @@ AllocChannelBuffer( n = length + CHANNELBUFFER_HEADER_SIZE + BUFFER_PADDING + BUFFER_PADDING; bufPtr = (ChannelBuffer *)Tcl_Alloc(n); - bufPtr->nextAdded1 = BUFFER_PADDING; - bufPtr->nextRemoved1 = BUFFER_PADDING; + bufPtr->nextAdded = BUFFER_PADDING; + bufPtr->nextRemoved = BUFFER_PADDING; bufPtr->bufLength = length + BUFFER_PADDING; bufPtr->nextPtr = NULL; bufPtr->refCount = 1; @@ -2572,8 +2572,8 @@ RecycleBuffer( return; keepBuffer: - bufPtr->nextRemoved1 = BUFFER_PADDING; - bufPtr->nextAdded1 = BUFFER_PADDING; + bufPtr->nextRemoved = BUFFER_PADDING; + bufPtr->nextAdded = BUFFER_PADDING; bufPtr->nextPtr = NULL; } @@ -2865,7 +2865,7 @@ FlushChannel( wroteSome = 1; } - bufPtr->nextRemoved1 += written; + bufPtr->nextRemoved += written; /* * If this buffer is now empty, recycle it. @@ -4326,7 +4326,7 @@ Write( */ memcpy(InsertPoint(bufPtr), safe, saved); - bufPtr->nextAdded1 += saved; + bufPtr->nextAdded += saved; saved = 0; } PreserveChannelBuffer(bufPtr); @@ -4357,7 +4357,7 @@ Write( break; } - bufPtr->nextAdded1 += dstWrote; + bufPtr->nextAdded += dstWrote; src += srcRead; srcLen -= srcRead; total += dstWrote; @@ -4393,7 +4393,7 @@ Write( dstLen + BUFFER_PADDING, &srcRead, &dstWrote, NULL); assert(srcRead == nlLen); - bufPtr->nextAdded1 += dstWrote; + bufPtr->nextAdded += dstWrote; src++; srcLen--; total += dstWrote; @@ -4414,7 +4414,7 @@ Write( saved = 1 + ~SpaceLeft(bufPtr); memcpy(safe, dst + dstLen, saved); - bufPtr->nextAdded1 = bufPtr->bufLength; + bufPtr->nextAdded = bufPtr->bufLength; } if ((srcLen + saved == 0) && (result == TCL_OK)) { @@ -4588,7 +4588,7 @@ Tcl_GetsObj( oldState = statePtr->inputEncodingState; oldRemoved = BUFFER_PADDING; if (bufPtr != NULL) { - oldRemoved = bufPtr->nextRemoved1; + oldRemoved = bufPtr->nextRemoved; } /* @@ -4722,7 +4722,7 @@ Tcl_GetsObj( gs.rawRead, statePtr->inputEncodingFlags | TCL_ENCODING_NO_TERMINATE, &gs.state, tmp, sizeof(tmp), &rawRead, NULL, NULL); - bufPtr->nextRemoved1 += rawRead; + bufPtr->nextRemoved += rawRead; gs.rawRead -= rawRead; gs.bytesWrote--; gs.charsWrote--; @@ -4826,7 +4826,7 @@ Tcl_GetsObj( &statePtr->inputEncodingState, dst, eol - dst + skip + TCL_UTF_MAX - 1, &gs.rawRead, NULL, &gs.charsWrote); - bufPtr->nextRemoved1 += gs.rawRead; + bufPtr->nextRemoved += gs.rawRead; /* * Recycle all the emptied buffers. @@ -4856,12 +4856,12 @@ Tcl_GetsObj( } bufPtr = statePtr->inQueueHead; if (bufPtr != NULL) { - bufPtr->nextRemoved1 = oldRemoved; + bufPtr->nextRemoved = oldRemoved; bufPtr = bufPtr->nextPtr; } for ( ; bufPtr != NULL; bufPtr = bufPtr->nextPtr) { - bufPtr->nextRemoved1 = BUFFER_PADDING; + bufPtr->nextRemoved = BUFFER_PADDING; } CommonGetsCleanup(chanPtr); @@ -4971,7 +4971,7 @@ TclGetsObjBinary( oldRemoved = BUFFER_PADDING; oldLength = byteLen; if (bufPtr != NULL) { - oldRemoved = bufPtr->nextRemoved1; + oldRemoved = bufPtr->nextRemoved; } rawLen = 0; @@ -4993,13 +4993,13 @@ TclGetsObjBinary( */ if (bufPtr != NULL) { - bufPtr->nextRemoved1 += rawLen; + bufPtr->nextRemoved += rawLen; if (!IsBufferReady(bufPtr)) { bufPtr = bufPtr->nextPtr; } } - if ((bufPtr == NULL) || (bufPtr->nextAdded1 == BUFFER_PADDING)) { + if ((bufPtr == NULL) || (bufPtr->nextAdded == BUFFER_PADDING)) { /* * All channel buffers were exhausted and the caller still hasn't * seen EOL. Need to read more bytes from the channel device. Side @@ -5115,7 +5115,7 @@ TclGetsObjBinary( byteArray = Tcl_SetByteArrayLength(objPtr, byteLen + rawLen); memcpy(byteArray + byteLen, dst, rawLen); byteLen += rawLen; - bufPtr->nextRemoved1 += rawLen + skip; + bufPtr->nextRemoved += rawLen + skip; /* * Convert the buffer if there was an encoding. @@ -5143,12 +5143,12 @@ TclGetsObjBinary( restore: bufPtr = statePtr->inQueueHead; if (bufPtr) { - bufPtr->nextRemoved1 = oldRemoved; + bufPtr->nextRemoved = oldRemoved; bufPtr = bufPtr->nextPtr; } for ( ; bufPtr != NULL; bufPtr = bufPtr->nextPtr) { - bufPtr->nextRemoved1 = BUFFER_PADDING; + bufPtr->nextRemoved = BUFFER_PADDING; } CommonGetsCleanup(chanPtr); @@ -5277,14 +5277,14 @@ FilterInputBytes( bufPtr = gsPtr->bufPtr; if (bufPtr != NULL) { - bufPtr->nextRemoved1 += gsPtr->rawRead; + bufPtr->nextRemoved += gsPtr->rawRead; if (!IsBufferReady(bufPtr)) { bufPtr = bufPtr->nextPtr; } } gsPtr->totalChars += gsPtr->charsWrote; - if ((bufPtr == NULL) || (bufPtr->nextAdded1 == BUFFER_PADDING)) { + if ((bufPtr == NULL) || (bufPtr->nextAdded == BUFFER_PADDING)) { /* * All channel buffers were exhausted and the caller still hasn't seen * EOL. Need to read more bytes from the channel device. Side effect @@ -5392,7 +5392,7 @@ FilterInputBytes( * device. Fall through, returning that nothing was found. */ - bufPtr->nextRemoved1 = bufPtr->nextAdded1; + bufPtr->nextRemoved = bufPtr->nextAdded; } else { /* * There are no more cached raw bytes left. See if we can get @@ -5410,8 +5410,8 @@ FilterInputBytes( extra = rawLen - gsPtr->rawRead; memcpy(nextPtr->buf + (BUFFER_PADDING - extra), raw + gsPtr->rawRead, extra); - nextPtr->nextRemoved1 -= extra; - bufPtr->nextAdded1 -= extra; + nextPtr->nextRemoved -= extra; + bufPtr->nextAdded -= extra; } } @@ -5497,7 +5497,7 @@ PeekAhead( return; cleanup: - bufPtr->nextRemoved1 += gsPtr->rawRead; + bufPtr->nextRemoved += gsPtr->rawRead; gsPtr->rawRead = 0; gsPtr->totalChars += gsPtr->charsWrote; gsPtr->bytesWrote = 0; @@ -5559,8 +5559,8 @@ CommonGetsCleanup( memcpy(InsertPoint(bufPtr), nextPtr->buf + (BUFFER_PADDING - extra), (size_t) extra); - bufPtr->nextAdded1 += extra; - nextPtr->nextRemoved1 = BUFFER_PADDING; + bufPtr->nextAdded += extra; + nextPtr->nextRemoved = BUFFER_PADDING; } bufPtr = nextPtr; } @@ -5665,7 +5665,7 @@ Tcl_ReadRaw( */ memcpy(readBuf, RemovePoint(bufPtr), toCopy); - bufPtr->nextRemoved1 += toCopy; + bufPtr->nextRemoved += toCopy; copied += toCopy; readBuf += toCopy; bytesToRead -= toCopy; @@ -6034,7 +6034,7 @@ ReadBytes( TclAppendBytesToByteArray(objPtr, (unsigned char *) RemovePoint(bufPtr), toRead); - bufPtr->nextRemoved1 += toRead; + bufPtr->nextRemoved += toRead; return toRead; } @@ -6297,10 +6297,10 @@ ReadChars( if (buffer[1] == '\n') { /* \r\n translate to \n */ dst[0] = '\n'; - bufPtr->nextRemoved1 += read; + bufPtr->nextRemoved += read; } else { dst[0] = '\r'; - bufPtr->nextRemoved1 += srcRead; + bufPtr->nextRemoved += srcRead; } statePtr->inputEncodingFlags &= ~TCL_ENCODING_START; @@ -6316,7 +6316,7 @@ ReadChars( */ dst[0] = '\r'; - bufPtr->nextRemoved1 = bufPtr->nextAdded1; + bufPtr->nextRemoved = bufPtr->nextAdded; Tcl_SetObjLength(objPtr, numBytes + 1); return 1; } @@ -6412,11 +6412,11 @@ ReadChars( * precautions. */ - if (nextPtr->nextRemoved1 - srcLen < 0) { + if (nextPtr->nextRemoved < (size_t)srcLen) { Tcl_Panic("Buffer Underflow, BUFFER_PADDING not enough"); } - nextPtr->nextRemoved1 -= srcLen; + nextPtr->nextRemoved -= srcLen; memcpy(RemovePoint(nextPtr), src, srcLen); RecycleBuffer(statePtr, bufPtr, 0); statePtr->inQueueHead = nextPtr; @@ -6427,7 +6427,7 @@ ReadChars( statePtr->inputEncodingFlags &= ~TCL_ENCODING_START; consume: - bufPtr->nextRemoved1 += srcRead; + bufPtr->nextRemoved += srcRead; /* * If this read contained multibyte characters, revise factorPtr so @@ -6681,7 +6681,7 @@ Tcl_Ungets( bufPtr = AllocChannelBuffer(len); memcpy(InsertPoint(bufPtr), str, len); - bufPtr->nextAdded1 += len; + bufPtr->nextAdded += len; if (statePtr->inQueueHead == NULL) { bufPtr->nextPtr = NULL; @@ -6936,7 +6936,7 @@ GetInput( result = Tcl_GetErrno(); } else { result = 0; - bufPtr->nextAdded1 += nread; + bufPtr->nextAdded += nread; } ReleaseChannelBuffer(bufPtr); @@ -9406,9 +9406,9 @@ MBWrite( bufPtr = AllocChannelBuffer(extra); - tail->nextAdded1 -= extra; + tail->nextAdded -= extra; memcpy(InsertPoint(bufPtr), InsertPoint(tail), extra); - bufPtr->nextAdded1 += extra; + bufPtr->nextAdded += extra; bufPtr->nextPtr = tail->nextPtr; tail->nextPtr = NULL; inBytes = csPtr->toRead; @@ -9927,7 +9927,7 @@ DoRead( TranslateInputEOL(statePtr, p, RemovePoint(bufPtr), &bytesWritten, &bytesRead); - bufPtr->nextRemoved1 += bytesRead; + bufPtr->nextRemoved += bytesRead; p += bytesWritten; bytesToRead -= bytesWritten; @@ -9972,7 +9972,7 @@ DoRead( *p++ = '\r'; bytesToRead--; - bufPtr->nextRemoved1++; + bufPtr->nextRemoved++; } else if (statePtr->flags & CHANNEL_BLOCKED) { /* * ...and we cannot get more now. @@ -9996,9 +9996,9 @@ DoRead( ChannelBuffer *nextPtr = bufPtr->nextPtr; - nextPtr->nextRemoved1 -= 1; + nextPtr->nextRemoved -= 1; RemovePoint(nextPtr)[0] = '\r'; - bufPtr->nextRemoved1++; + bufPtr->nextRemoved++; } } diff --git a/generic/tclIO.h b/generic/tclIO.h index 64e8ca5..ca6a0ac 100644 --- a/generic/tclIO.h +++ b/generic/tclIO.h @@ -37,9 +37,9 @@ typedef struct ChannelBuffer { size_t refCount; /* Current uses count */ - size_t nextAdded1; /* The next position into which a character + size_t nextAdded; /* The next position into which a character * will be put in the buffer. */ - size_t nextRemoved1; /* Position of next byte to be removed from + size_t nextRemoved; /* Position of next byte to be removed from * the buffer. */ size_t bufLength; /* How big is the buffer? */ struct ChannelBuffer *nextPtr; -- cgit v0.12 From 432fbdc37562b215a1955ebc8c5af4aadd24315a Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 29 Mar 2022 10:37:35 +0000 Subject: More progress --- generic/tclAssembly.c | 6 +++--- generic/tclBasic.c | 6 +++--- generic/tclCompCmds.c | 8 ++++---- generic/tclCompCmdsGR.c | 10 +++++----- generic/tclCompCmdsSZ.c | 20 ++++++++++---------- generic/tclCompExpr.c | 14 +++++++------- generic/tclCompile.c | 12 ++++++------ generic/tclCompile.h | 8 ++++---- generic/tclDisassemble.c | 4 ++-- generic/tclEnsemble.c | 12 ++++++------ generic/tclExecute.c | 6 +++--- generic/tclOptimize.c | 6 +++--- generic/tclParse.c | 22 +++++++++++----------- generic/tclProc.c | 2 +- 14 files changed, 68 insertions(+), 68 deletions(-) diff --git a/generic/tclAssembly.c b/generic/tclAssembly.c index 8560843..6027741 100644 --- a/generic/tclAssembly.c +++ b/generic/tclAssembly.c @@ -1075,7 +1075,7 @@ TclAssembleCode( */ if ((int)parsePtr->numWords > 0) { - size_t instLen = (int)parsePtr->commandSize; + size_t instLen = parsePtr->commandSize; /* Length in bytes of the current command */ if (parsePtr->term == parsePtr->commandStart + instLen - 1) { @@ -4011,7 +4011,7 @@ UnstackExpiredCatches( --catchDepth; if (catches[catchDepth] != NULL) { range = envPtr->exceptArrayPtr + catchIndices[catchDepth]; - range->numCodeBytes = bbPtr->startOffset - (int)range->codeOffset; + range->numCodeBytes = bbPtr->startOffset - 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 - (int)range->codeOffset; + range->numCodeBytes = bbPtr->startOffset - range->codeOffset; catches[catchDepth] = NULL; catchIndices[catchDepth] = -1; } diff --git a/generic/tclBasic.c b/generic/tclBasic.c index ae89552..7d09caf 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -5302,7 +5302,7 @@ TclEvalEx( eeFramePtr->len = parsePtr->commandSize; if (parsePtr->term == - parsePtr->commandStart + (int)parsePtr->commandSize - 1) { + parsePtr->commandStart + parsePtr->commandSize - 1) { eeFramePtr->len--; } @@ -5353,7 +5353,7 @@ TclEvalEx( * executed command. */ - next = parsePtr->commandStart + (int)parsePtr->commandSize; + next = parsePtr->commandStart + 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 = (int)parsePtr->commandSize; + commandLength = 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 7d1fbb9..4cc6a81 100644 --- a/generic/tclCompCmds.c +++ b/generic/tclCompCmds.c @@ -759,7 +759,7 @@ TclCompileClockClicksCmd( { Tcl_Token* tokenPtr; - switch ((int)parsePtr->numWords) { + switch (parsePtr->numWords) { case 1: /* * No args @@ -1773,7 +1773,7 @@ TclCompileDictUpdateCmd( if (((int)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); /* @@ -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); /* diff --git a/generic/tclCompCmdsGR.c b/generic/tclCompCmdsGR.c index 207b247..8202fa2 100644 --- a/generic/tclCompCmdsGR.c +++ b/generic/tclCompCmdsGR.c @@ -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); } @@ -1714,7 +1714,7 @@ TclCompileLsetCmd( 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); } /* diff --git a/generic/tclCompCmdsSZ.c b/generic/tclCompCmdsSZ.c index 66b72c0..bdbde04 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; @@ -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); @@ -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); @@ -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*/; @@ -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; } @@ -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; @@ -3936,7 +3936,7 @@ 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; } diff --git a/generic/tclCompExpr.c b/generic/tclCompExpr.c index 12a88b7..1ed20b9 100644 --- a/generic/tclCompExpr.c +++ b/generic/tclCompExpr.c @@ -915,7 +915,7 @@ ParseExpr( */ TclGrowParseTokenArray(parsePtr, 2); - wordIndex = (int)parsePtr->numTokens; + wordIndex = 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 + (int)parsePtr->numTokens; + tokenPtr = parsePtr->tokenPtr + 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 = (int)parsePtr->numTokens - wordIndex - 1; + tokenPtr->numComponents = 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 + (int)parsePtr->numTokens; + subExprTokenPtr = parsePtr->tokenPtr + 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 + (int)parsePtr->numTokens; + subExprTokenPtr = parsePtr->tokenPtr + 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 + (int)parsePtr->numTokens; + subExprTokenPtr = parsePtr->tokenPtr + parsePtr->numTokens; *subExprTokenPtr = *tokenPtr; subExprTokenPtr->type = TCL_TOKEN_SUB_EXPR; subExprTokenPtr->numComponents++; @@ -1678,7 +1678,7 @@ ConvertTreeToTokens( */ TclGrowParseTokenArray(parsePtr, 2); - subExprTokenIdx = (int)parsePtr->numTokens; + subExprTokenIdx = parsePtr->numTokens; subExprTokenPtr = parsePtr->tokenPtr + subExprTokenIdx; parsePtr->numTokens += 2; subExprTokenPtr->type = TCL_TOKEN_SUB_EXPR; diff --git a/generic/tclCompile.c b/generic/tclCompile.c index 1db793f..5045aab 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -1036,7 +1036,7 @@ CleanupByteCode( statsPtr = &iPtr->stats; statsPtr->numByteCodesFreed++; - statsPtr->currentSrcBytes -= (double) (int)codePtr->numSrcBytes; + statsPtr->currentSrcBytes -= (double)codePtr->numSrcBytes; statsPtr->currentByteCodeBytes -= (double) codePtr->structureSize; statsPtr->currentInstBytes -= (double) codePtr->numCodeBytes; @@ -3660,12 +3660,12 @@ TclFinalizeLoopExceptionRange( * there is no need to fuss around with updating code offsets. */ - for (i=0 ; inumBreakTargets ; i++) { + for (i=0 ; i<(int)auxPtr->numBreakTargets ; i++) { site = envPtr->codeStart + auxPtr->breakTargets[i]; offset = (int)rangePtr->breakOffset - auxPtr->breakTargets[i]; TclUpdateInstInt4AtPc(INST_JUMP4, offset, site); } - for (i=0 ; inumContinueTargets ; i++) { + for (i=0 ; i<(int)auxPtr->numContinueTargets ; i++) { site = envPtr->codeStart + auxPtr->continueTargets[i]; if (rangePtr->continueOffset == TCL_INDEX_NONE) { int j; @@ -4062,12 +4062,12 @@ TclFixupForwardJump( ExceptionAux *auxPtr = &envPtr->exceptAuxArrayPtr[k]; int i; - for (i=0 ; inumBreakTargets ; i++) { + for (i=0 ; i<(int)auxPtr->numBreakTargets ; i++) { if (jumpFixupPtr->codeOffset < auxPtr->breakTargets[i]) { auxPtr->breakTargets[i] += 3; } } - for (i=0 ; inumContinueTargets ; i++) { + for (i=0 ; i<(int)auxPtr->numContinueTargets ; i++) { if (jumpFixupPtr->codeOffset < auxPtr->continueTargets[i]) { auxPtr->continueTargets[i] += 3; } @@ -4528,7 +4528,7 @@ RecordByteCodeStats( statsPtr = &(iPtr->stats); statsPtr->numCompilations++; - statsPtr->totalSrcBytes += (double) (int)codePtr->numSrcBytes; + statsPtr->totalSrcBytes += (double)codePtr->numSrcBytes; statsPtr->totalByteCodeBytes += (double) codePtr->structureSize; statsPtr->currentSrcBytes += (double) (int)codePtr->numSrcBytes; statsPtr->currentByteCodeBytes += (double) codePtr->structureSize; diff --git a/generic/tclCompile.h b/generic/tclCompile.h index fc5b498..62b6416 100644 --- a/generic/tclCompile.h +++ b/generic/tclCompile.h @@ -132,7 +132,7 @@ typedef struct ExceptionAux { * if there are no open expansions between the * looping level and the point of jump * issue. */ - int numBreakTargets; /* The number of [break]s that want to be + size_t numBreakTargets; /* The number of [break]s that want to be * targeted to the place where this loop * exception will be bound to. */ unsigned int *breakTargets; /* The offsets of the INST_JUMP4 instructions @@ -141,8 +141,8 @@ typedef struct ExceptionAux { * TclFixupForwardJump) can cause the contents * of this array to be updated. When * numBreakTargets==0, this is NULL. */ - int allocBreakTargets; /* The size of the breakTargets array. */ - int numContinueTargets; /* The number of [continue]s that want to be + size_t allocBreakTargets; /* The size of the breakTargets array. */ + size_t numContinueTargets; /* The number of [continue]s that want to be * targeted to the place where this loop * exception will be bound to. */ unsigned int *continueTargets; /* The offsets of the INST_JUMP4 instructions @@ -151,7 +151,7 @@ typedef struct ExceptionAux { * TclFixupForwardJump) can cause the contents * of this array to be updated. When * numContinueTargets==0, this is NULL. */ - int allocContinueTargets; /* The size of the continueTargets array. */ + size_t allocContinueTargets; /* The size of the continueTargets array. */ } ExceptionAux; /* diff --git a/generic/tclDisassemble.c b/generic/tclDisassemble.c index 05eee35..469089a 100644 --- a/generic/tclDisassemble.c +++ b/generic/tclDisassemble.c @@ -270,7 +270,7 @@ DisassembleByteCodeObj( codeStart = codePtr->codeStart; codeLimit = codeStart + codePtr->numCodeBytes; - numCmds = (int)codePtr->numCommands; + numCmds = codePtr->numCommands; /* * Print header lines describing the ByteCode. @@ -294,7 +294,7 @@ DisassembleByteCodeObj( codePtr->maxStackDepth, #ifdef TCL_COMPILE_STATS codePtr->numSrcBytes? - codePtr->structureSize/(float)(int)codePtr->numSrcBytes : + codePtr->structureSize/(float)codePtr->numSrcBytes : #endif 0.0); diff --git a/generic/tclEnsemble.c b/generic/tclEnsemble.c index 873ba78..f3d15f3 100644 --- a/generic/tclEnsemble.c +++ b/generic/tclEnsemble.c @@ -3314,12 +3314,12 @@ TclAttemptCompileProc( ExceptionAux *auxPtr = envPtr->exceptAuxArrayPtr; for (i = 0; i < savedExceptArrayNext; i++) { - while (auxPtr->numBreakTargets > 0 + while ((int)auxPtr->numBreakTargets > 0 && auxPtr->breakTargets[auxPtr->numBreakTargets - 1] >= savedCodeNext) { auxPtr->numBreakTargets--; } - while (auxPtr->numContinueTargets > 0 + while ((int)auxPtr->numContinueTargets > 0 && auxPtr->continueTargets[auxPtr->numContinueTargets - 1] >= savedCodeNext) { auxPtr->numContinueTargets--; @@ -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; } @@ -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 5628167..dc02cff 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -7228,7 +7228,7 @@ TEBCresume( } if (result == TCL_BREAK) { result = TCL_OK; - pc = (codePtr->codeStart + (int)rangePtr->breakOffset); + pc = (codePtr->codeStart + rangePtr->breakOffset); TRACE_APPEND(("%s, range at %" TCL_Z_MODIFIER "u, new pc %" TCL_Z_MODIFIER "u\n", StringForResultCode(result), rangePtr->codeOffset, rangePtr->breakOffset)); @@ -7240,7 +7240,7 @@ TEBCresume( goto checkForCatch; } result = TCL_OK; - pc = (codePtr->codeStart + (int)rangePtr->continueOffset); + pc = (codePtr->codeStart + rangePtr->continueOffset); TRACE_APPEND(("%s, range at %" TCL_Z_MODIFIER "u, new pc %" TCL_Z_MODIFIER "u\n", StringForResultCode(result), rangePtr->codeOffset, rangePtr->continueOffset)); @@ -7419,7 +7419,7 @@ TEBCresume( (long)*catchTop, rangePtr->catchOffset); } #endif - pc = (codePtr->codeStart + (int)rangePtr->catchOffset); + pc = (codePtr->codeStart + rangePtr->catchOffset); NEXT_INST_F(0, 0, 0); /* Restart the execution loop at pc. */ /* diff --git a/generic/tclOptimize.c b/generic/tclOptimize.c index 2fcc8e1..9341336 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 + (int)rangePtr->catchOffset; + targetInstPtr = envPtr->codeStart + rangePtr->catchOffset; DefineTargetAddress(tablePtr, targetInstPtr); } else { - targetInstPtr = envPtr->codeStart + (int)rangePtr->breakOffset; + targetInstPtr = envPtr->codeStart + rangePtr->breakOffset; DefineTargetAddress(tablePtr, targetInstPtr); if (rangePtr->continueOffset != TCL_INDEX_NONE) { - targetInstPtr = envPtr->codeStart + (int)rangePtr->continueOffset; + targetInstPtr = envPtr->codeStart + rangePtr->continueOffset; DefineTargetAddress(tablePtr, targetInstPtr); } } diff --git a/generic/tclParse.c b/generic/tclParse.c index 5b4689f..dc5ecac 100644 --- a/generic/tclParse.c +++ b/generic/tclParse.c @@ -303,7 +303,7 @@ Tcl_ParseCommand( */ TclGrowParseTokenArray(parsePtr, 1); - wordIndex = (int)parsePtr->numTokens; + wordIndex = 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 == (int)parsePtr->numTokens - expIdx) + && (expIdx + 1 == (int)parsePtr->numTokens) /* Only one token */ && (((1 == expPtr->size) /* Same length as prefix */ @@ -1082,10 +1082,10 @@ ParseTokens( * for the parsed variable name. */ - originalTokens = (int)parsePtr->numTokens; + originalTokens = parsePtr->numTokens; while (numBytes && !((type = CHAR_TYPE(*src)) & mask)) { TclGrowParseTokenArray(parsePtr, 1); - tokenPtr = &parsePtr->tokenPtr[(int)parsePtr->numTokens]; + tokenPtr = &parsePtr->tokenPtr[parsePtr->numTokens]; tokenPtr->start = src; tokenPtr->numComponents = 0; @@ -1119,7 +1119,7 @@ ParseTokens( * the dirty work of parsing the name. */ - varToken = (int)parsePtr->numTokens; + varToken = parsePtr->numTokens; if (Tcl_ParseVarName(parsePtr->interp, src, numBytes, parsePtr, 1) != TCL_OK) { return TCL_ERROR; @@ -1258,7 +1258,7 @@ ParseTokens( */ TclGrowParseTokenArray(parsePtr, 1); - tokenPtr = &parsePtr->tokenPtr[(int)parsePtr->numTokens]; + tokenPtr = &parsePtr->tokenPtr[parsePtr->numTokens]; tokenPtr->start = src; tokenPtr->numComponents = 0; @@ -1365,10 +1365,10 @@ Tcl_ParseVarName( src = start; TclGrowParseTokenArray(parsePtr, 2); - tokenPtr = &parsePtr->tokenPtr[(int)parsePtr->numTokens]; + tokenPtr = &parsePtr->tokenPtr[parsePtr->numTokens]; tokenPtr->type = TCL_TOKEN_VARIABLE; tokenPtr->start = src; - varIndex = (int)parsePtr->numTokens; + varIndex = parsePtr->numTokens; parsePtr->numTokens++; tokenPtr++; src++; @@ -1480,7 +1480,7 @@ Tcl_ParseVarName( } tokenPtr = &parsePtr->tokenPtr[varIndex]; tokenPtr->size = src - tokenPtr->start; - tokenPtr->numComponents = (int)parsePtr->numTokens - (varIndex + 1); + tokenPtr->numComponents = parsePtr->numTokens - (varIndex + 1); return TCL_OK; /* @@ -1552,7 +1552,7 @@ Tcl_ParseVar( return "$"; } - code = TclSubstTokens(interp, parsePtr->tokenPtr, (int)parsePtr->numTokens, + code = TclSubstTokens(interp, parsePtr->tokenPtr, parsePtr->numTokens, NULL, 1, NULL, NULL); Tcl_FreeParse(parsePtr); TclStackFree(interp, parsePtr); @@ -1641,7 +1641,7 @@ Tcl_ParseBraces( } src = start; - startIndex = (int)parsePtr->numTokens; + startIndex = parsePtr->numTokens; TclGrowParseTokenArray(parsePtr, 1); tokenPtr = &parsePtr->tokenPtr[startIndex]; diff --git a/generic/tclProc.c b/generic/tclProc.c index 925c4ef..13f16e8 100644 --- a/generic/tclProc.c +++ b/generic/tclProc.c @@ -1946,7 +1946,7 @@ TclProcCompileProc( iPtr->compiledProcPtr = procPtr; - if ((int)procPtr->numCompiledLocals > (int)procPtr->numArgs) { + if (procPtr->numCompiledLocals > procPtr->numArgs) { CompiledLocal *clPtr = procPtr->firstLocalPtr; CompiledLocal *lastPtr = NULL; int i, numArgs = procPtr->numArgs; -- cgit v0.12 From b0b75a50838fb17c643dad2d633c7240d207db96 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 29 Mar 2022 13:17:10 +0000 Subject: More progress --- generic/regexec.c | 12 ++++++------ generic/tclBinary.c | 36 ++++++++++++++++++------------------ generic/tclCmdIL.c | 4 ++-- generic/tclCompile.c | 48 ++++++++++++++++++++++++------------------------ generic/tclCompile.h | 14 +++++++------- generic/tclDisassemble.c | 4 ++-- generic/tclEnsemble.c | 8 ++++---- generic/tclExecute.c | 12 ++++++------ generic/tclInt.h | 13 ++++++++----- generic/tclPathObj.c | 2 -- generic/tclRegexp.c | 4 ++-- generic/tclThreadTest.c | 10 +++++----- generic/tclVar.c | 12 ++++++------ 13 files changed, 90 insertions(+), 89 deletions(-) diff --git a/generic/regexec.c b/generic/regexec.c index fdbdef0..b9091ab 100644 --- a/generic/regexec.c +++ b/generic/regexec.c @@ -545,8 +545,8 @@ zapallsubs( size_t i; for (i = n-1; i > 0; i--) { - p[i].rm_so = -1; - p[i].rm_eo = -1; + p[i].rm_so = TCL_INDEX_NONE; + p[i].rm_eo = TCL_INDEX_NONE; } } @@ -560,11 +560,11 @@ zaptreesubs( struct subre *const t) { if (t->op == '(') { - int n = t->subno; + size_t n = t->subno; assert(n > 0); - if ((size_t) n < v->nmatch) { - v->pmatch[n].rm_so = -1; - v->pmatch[n].rm_eo = -1; + if (n < v->nmatch) { + v->pmatch[n].rm_so = TCL_INDEX_NONE; + v->pmatch[n].rm_eo = TCL_INDEX_NONE; } } diff --git a/generic/tclBinary.c b/generic/tclBinary.c index 65e9f6c..ebc0ffb 100644 --- a/generic/tclBinary.c +++ b/generic/tclBinary.c @@ -909,7 +909,7 @@ BinaryFormatCmd( * cursor has visited.*/ const char *errorString; const char *errorValue, *str; - int offset, size; + size_t offset, size; size_t length; if (objc < 2) { @@ -1047,16 +1047,16 @@ BinaryFormatCmd( if (count == BINARY_NOCOUNT) { count = 1; } - if ((count > (size_t)offset) || (count == BINARY_ALL)) { + if ((count > offset) || (count == BINARY_ALL)) { count = offset; } - if (offset > (int)length) { + if (offset > length) { length = offset; } offset -= count; break; case '@': - if (offset > (int)length) { + if (offset > length) { length = offset; } if (count == BINARY_ALL) { @@ -1072,7 +1072,7 @@ BinaryFormatCmd( goto badField; } } - if (offset > (int)length) { + if (offset > length) { length = offset; } if (length == 0) { @@ -1151,7 +1151,7 @@ BinaryFormatCmd( value = 0; errorString = "binary"; if (cmd == 'B') { - for (offset = 0; (size_t)offset < count; offset++) { + for (offset = 0; offset < count; offset++) { value <<= 1; if (str[offset] == '1') { value |= 1; @@ -1166,7 +1166,7 @@ BinaryFormatCmd( } } } else { - for (offset = 0; (size_t)offset < count; offset++) { + for (offset = 0; offset < count; offset++) { value >>= 1; if (str[offset] == '1') { value |= 128; @@ -1213,7 +1213,7 @@ BinaryFormatCmd( value = 0; errorString = "hexadecimal"; if (cmd == 'H') { - for (offset = 0; (size_t)offset < count; offset++) { + for (offset = 0; offset < count; offset++) { value <<= 4; if (!isxdigit(UCHAR(str[offset]))) { /* INTL: digit */ errorValue = str; @@ -1234,7 +1234,7 @@ BinaryFormatCmd( } } } else { - for (offset = 0; (size_t)offset < count; offset++) { + for (offset = 0; offset < count; offset++) { value >>= 4; if (!isxdigit(UCHAR(str[offset]))) { /* INTL: digit */ @@ -1305,7 +1305,7 @@ BinaryFormatCmd( } } arg++; - for (i = 0; (size_t)i < count; i++) { + for (i = 0; i < count; i++) { if (FormatNumber(interp, cmd, listv[i], &cursor) != TCL_OK) { Tcl_DecrRefCount(resultPtr); return TCL_ERROR; @@ -1416,7 +1416,7 @@ BinaryScanCmd( unsigned char *buffer; /* Start of result buffer. */ const char *errorString; const char *str; - int offset, size, i; + size_t offset, size, i; size_t length = 0; Tcl_Obj *valuePtr, *elementPtr; @@ -1536,7 +1536,7 @@ BinaryScanCmd( dest = TclGetString(valuePtr); if (cmd == 'b') { - for (i = 0; (size_t)i < count; i++) { + for (i = 0; i < count; i++) { if (i % 8) { value >>= 1; } else { @@ -1545,7 +1545,7 @@ BinaryScanCmd( *dest++ = (char) ((value & 1) ? '1' : '0'); } } else { - for (i = 0; (size_t)i < count; i++) { + for (i = 0; i < count; i++) { if (i % 8) { value <<= 1; } else { @@ -1591,7 +1591,7 @@ BinaryScanCmd( dest = TclGetString(valuePtr); if (cmd == 'h') { - for (i = 0; (size_t)i < count; i++) { + for (i = 0; i < count; i++) { if (i % 2) { value >>= 4; } else { @@ -1600,7 +1600,7 @@ BinaryScanCmd( *dest++ = hexdigit[value & 0xF]; } } else { - for (i = 0; (size_t)i < count; i++) { + for (i = 0; i < count; i++) { if (i % 2) { value <<= 4; } else { @@ -1657,7 +1657,7 @@ BinaryScanCmd( goto badIndex; } if (count == BINARY_NOCOUNT) { - if ((length - offset) < (size_t)size) { + if (length < (size_t)size + offset) { goto done; } valuePtr = ScanNumber(buffer+offset, cmd, flags, @@ -1672,7 +1672,7 @@ BinaryScanCmd( } TclNewObj(valuePtr); src = buffer + offset; - for (i = 0; (size_t)i < count; i++) { + for (i = 0; i < count; i++) { elementPtr = ScanNumber(src, cmd, flags, &numberCachePtr); src += size; Tcl_ListObjAppendElement(NULL, valuePtr, elementPtr); @@ -1703,7 +1703,7 @@ BinaryScanCmd( if (count == BINARY_NOCOUNT) { count = 1; } - if ((count == BINARY_ALL) || (count > (size_t)offset)) { + if ((count == BINARY_ALL) || (count > offset)) { offset = 0; } else { offset -= count; diff --git a/generic/tclCmdIL.c b/generic/tclCmdIL.c index 004cdb2..e73bce4 100644 --- a/generic/tclCmdIL.c +++ b/generic/tclCmdIL.c @@ -3694,7 +3694,7 @@ Tcl_LsearchObjCmd( if (allMatches) { listPtr = Tcl_NewListObj(0, NULL); } - for (i = start; i < (size_t)listc; i += groupSize) { + for (i = start; i < listc; i += groupSize) { match = 0; if (sortInfo.indexc != 0) { itemPtr = SelectObjFromSublist(listv[i+groupOffset], &sortInfo); @@ -4188,7 +4188,7 @@ Tcl_LsortObjCmd( allocatedIndexVector = 1; /* Cannot use indexc field, as it * might be decreased by 1 later. */ } - for (j=0 ; j<(size_t)sortInfo.indexc ; j++) { + for (j=0 ; j= envPtr->numCommands) { - Tcl_Panic("EnterCmdStartData: bad command index %d", cmdIndex); + if (cmdIndex >= envPtr->numCommands) { + Tcl_Panic("EnterCmdStartData: bad command index %" TCL_Z_MODIFIER "u", cmdIndex); } if (cmdIndex >= envPtr->cmdMapEnd) { @@ -3207,8 +3207,8 @@ EnterCmdStartData( cmdLocPtr = &envPtr->cmdMapPtr[cmdIndex]; cmdLocPtr->codeOffset = codeOffset; cmdLocPtr->srcOffset = srcOffset; - cmdLocPtr->numSrcBytes = -1; - cmdLocPtr->numCodeBytes = -1; + cmdLocPtr->numSrcBytes = TCL_INDEX_NONE; + cmdLocPtr->numCodeBytes = TCL_INDEX_NONE; } /* @@ -3237,19 +3237,19 @@ EnterCmdExtentData( CompileEnv *envPtr, /* Points to the compilation environment * structure in which to enter command * location information. */ - int cmdIndex, /* Index of the command whose source and code + size_t cmdIndex, /* Index of the command whose source and code * length data is being set. */ - int numSrcBytes, /* Number of command source chars. */ - int numCodeBytes) /* Offset of last byte of command code. */ + size_t numSrcBytes, /* Number of command source chars. */ + size_t numCodeBytes) /* Offset of last byte of command code. */ { CmdLocation *cmdLocPtr; - if ((size_t)cmdIndex >= envPtr->numCommands) { - Tcl_Panic("EnterCmdExtentData: bad command index %d", cmdIndex); + if (cmdIndex >= envPtr->numCommands) { + Tcl_Panic("EnterCmdExtentData: bad command index %" TCL_Z_MODIFIER "u", cmdIndex); } if (cmdIndex > envPtr->cmdMapEnd) { - Tcl_Panic("EnterCmdExtentData: missing start data for command %d", + Tcl_Panic("EnterCmdExtentData: missing start data for command %" TCL_Z_MODIFIER "u", cmdIndex); } @@ -3720,7 +3720,7 @@ TclFinalizeLoopExceptionRange( *---------------------------------------------------------------------- */ -int +size_t TclCreateAuxData( ClientData clientData, /* The compilation auxiliary data to store in * the new aux data record. */ @@ -3729,7 +3729,7 @@ TclCreateAuxData( CompileEnv *envPtr)/* Points to the CompileEnv for which a new * aux data structure is to be allocated. */ { - int index; /* Index for the new AuxData structure. */ + size_t index; /* Index for the new AuxData structure. */ AuxData *auxDataPtr; /* Points to the new AuxData structure */ @@ -3742,7 +3742,7 @@ TclCreateAuxData( */ size_t currBytes = envPtr->auxDataArrayNext * sizeof(AuxData); - int newElems = 2*envPtr->auxDataArrayEnd; + size_t newElems = 2*envPtr->auxDataArrayEnd; size_t newBytes = newElems * sizeof(AuxData); if (envPtr->mallocedAuxDataArray) { @@ -4402,10 +4402,10 @@ EncodeCmdLocMap( * is to be stored. */ { CmdLocation *mapPtr = envPtr->cmdMapPtr; - int numCmds = envPtr->numCommands; + size_t i, codeDelta, codeLen, srcLen, prevOffset; + size_t numCmds = envPtr->numCommands; unsigned char *p = startPtr; - int codeDelta, codeLen, srcDelta, srcLen, prevOffset; - int i; + int srcDelta; /* * Encode the code offset for each command as a sequence of deltas. @@ -4415,7 +4415,7 @@ EncodeCmdLocMap( prevOffset = 0; for (i = 0; i < numCmds; i++) { codeDelta = mapPtr[i].codeOffset - prevOffset; - if (codeDelta < 0) { + if (codeDelta == TCL_INDEX_NONE) { Tcl_Panic("EncodeCmdLocMap: bad code offset"); } else if (codeDelta <= 127) { TclStoreInt1AtPtr(codeDelta, p); @@ -4436,7 +4436,7 @@ EncodeCmdLocMap( codePtr->codeLengthStart = p; for (i = 0; i < numCmds; i++) { codeLen = mapPtr[i].numCodeBytes; - if (codeLen < 0) { + if (codeLen == TCL_INDEX_NONE) { Tcl_Panic("EncodeCmdLocMap: bad code length"); } else if (codeLen <= 127) { TclStoreInt1AtPtr(codeLen, p); @@ -4476,7 +4476,7 @@ EncodeCmdLocMap( codePtr->srcLengthStart = p; for (i = 0; i < numCmds; i++) { srcLen = mapPtr[i].numSrcBytes; - if (srcLen < 0) { + if (srcLen == TCL_INDEX_NONE) { Tcl_Panic("EncodeCmdLocMap: bad source length"); } else if (srcLen <= 127) { TclStoreInt1AtPtr(srcLen, p); diff --git a/generic/tclCompile.h b/generic/tclCompile.h index 62b6416..6a719ea 100644 --- a/generic/tclCompile.h +++ b/generic/tclCompile.h @@ -163,10 +163,10 @@ typedef struct ExceptionAux { */ typedef struct { - int codeOffset; /* Offset of first byte of command code. */ - int numCodeBytes; /* Number of bytes for command's code. */ - int srcOffset; /* Offset of first char of the command. */ - int numSrcBytes; /* Number of command source chars. */ + size_t codeOffset; /* Offset of first byte of command code. */ + size_t numCodeBytes; /* Number of bytes for command's code. */ + size_t srcOffset; /* Offset of first char of the command. */ + size_t numSrcBytes; /* Number of command source chars. */ } CmdLocation; /* @@ -347,7 +347,7 @@ typedef struct CompileEnv { * numCommands is the index of the next entry * to use; (numCommands-1) is the entry index * for the last command. */ - int cmdMapEnd; /* Index after last CmdLocation entry. */ + size_t 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 @@ -359,7 +359,7 @@ typedef struct CompileEnv { * 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. */ + size_t auxDataArrayEnd; /* Index after last aux data array entry. */ #if TCL_MAJOR_VERSION < 9 int mallocedAuxDataArray; #endif @@ -1106,7 +1106,7 @@ MODULE_SCOPE void TclCompileTokens(Tcl_Interp *interp, CompileEnv *envPtr); MODULE_SCOPE void TclCompileVarSubst(Tcl_Interp *interp, Tcl_Token *tokenPtr, CompileEnv *envPtr); -MODULE_SCOPE int TclCreateAuxData(void *clientData, +MODULE_SCOPE size_t TclCreateAuxData(void *clientData, const AuxDataType *typePtr, CompileEnv *envPtr); MODULE_SCOPE int TclCreateExceptRange(ExceptionRangeType type, CompileEnv *envPtr); diff --git a/generic/tclDisassemble.c b/generic/tclDisassemble.c index 469089a..ec0836a 100644 --- a/generic/tclDisassemble.c +++ b/generic/tclDisassemble.c @@ -56,7 +56,7 @@ static const Tcl_ObjType instNameType = { const Tcl_ObjInternalRep *irPtr; \ irPtr = TclFetchInternalRep((objPtr), &instNameType); \ assert(irPtr != NULL); \ - (inst) = (size_t)irPtr->wideValue; \ + (inst) = irPtr->wideValue; \ } while (0) @@ -833,7 +833,7 @@ UpdateStringOfInstName( if (inst > LAST_INST_OPCODE) { dst = Tcl_InitStringRep(objPtr, NULL, TCL_INTEGER_SPACE + 5); - TclOOM(dst, (size_t)TCL_INTEGER_SPACE + 5); + TclOOM(dst, TCL_INTEGER_SPACE + 5); sprintf(dst, "inst_%" TCL_Z_MODIFIER "u", inst); (void) Tcl_InitStringRep(objPtr, NULL, strlen(dst)); } else { diff --git a/generic/tclEnsemble.c b/generic/tclEnsemble.c index f3d15f3..5fdf7f4 100644 --- a/generic/tclEnsemble.c +++ b/generic/tclEnsemble.c @@ -3384,8 +3384,8 @@ CompileToInvokedCommand( Tcl_Token *tokPtr; Tcl_Obj *objPtr, **words; const char *bytes; - int i, cmdLit, extraLiteralFlags = LITERAL_CMD_NAME; - size_t numWords, length; + int cmdLit, extraLiteralFlags = LITERAL_CMD_NAME; + size_t i, numWords, length; /* * Push the words of the command. Take care; the command words may be @@ -3394,9 +3394,9 @@ CompileToInvokedCommand( */ TclListObjGetElements(NULL, replacements, &numWords, &words); - for (i = 0, tokPtr = parsePtr->tokenPtr; i < (int)parsePtr->numWords; + for (i = 0, tokPtr = parsePtr->tokenPtr; i < parsePtr->numWords; i++, tokPtr = TokenAfter(tokPtr)) { - if (i > 0 && (size_t)i <= numWords) { + if (i > 0 && 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 dc02cff..19cf65f 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -6245,7 +6245,7 @@ TEBCresume( numVars = varListPtr->numVars; listPtr = OBJ_AT_DEPTH(listTmpDepth); if (TclListObjLength(interp, listPtr, &listLen) != TCL_OK) { - TRACE_APPEND(("ERROR converting list %ld, \"%s\": %s", + TRACE_APPEND(("ERROR converting list %" TCL_Z_MODIFIER "d, \"%s\": %s", i, O2S(listPtr), O2S(Tcl_GetObjResult(interp)))); goto gotError; } @@ -8686,8 +8686,8 @@ PrintByteCodeInfo( codePtr->numCodeBytes, codePtr->numLitObjects, codePtr->numAuxDataItems, codePtr->maxStackDepth, #ifdef TCL_COMPILE_STATS - (int)codePtr->numSrcBytes? - ((float)codePtr->structureSize)/(int)codePtr->numSrcBytes : + codePtr->numSrcBytes? + ((float)codePtr->structureSize)/codePtr->numSrcBytes : #endif 0.0); @@ -9580,7 +9580,7 @@ EvalStatsCmd( break; } } - for (i = 31; i != (size_t)-1; i--) { + for (i = 31; i != TCL_INDEX_NONE; i--) { if (statsPtr->srcCount[i] > 0) { break; /* maxSizeDecade to consume 'i' value * below... */ @@ -9604,7 +9604,7 @@ EvalStatsCmd( break; } } - for (i = 31; i != (size_t)-1; i--) { + for (i = 31; i != TCL_INDEX_NONE; i--) { if (statsPtr->byteCodeCount[i] > 0) { break; /* maxSizeDecade to consume 'i' value * below... */ @@ -9628,7 +9628,7 @@ EvalStatsCmd( break; } } - for (i = 31; i != (size_t)-1; i--) { + for (i = 31; i != TCL_INDEX_NONE; i--) { if (statsPtr->lifetimeCount[i] > 0) { break; /* maxSizeDecade to consume 'i' value * below... */ diff --git a/generic/tclInt.h b/generic/tclInt.h index 10d5913..2550493 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -115,21 +115,24 @@ typedef int ptrdiff_t; * to/from pointer from/to integer of different size". */ -#if !defined(INT2PTR) && !defined(PTR2INT) +#if !defined(INT2PTR) # if defined(HAVE_INTPTR_T) || defined(intptr_t) # define INT2PTR(p) ((void *)(intptr_t)(p)) -# define PTR2INT(p) ((intptr_t)(p)) # else # define INT2PTR(p) ((void *)(p)) +# endif +#endif +#if !defined(PTR2INT) +# if defined(HAVE_INTPTR_T) || defined(intptr_t) +# define PTR2INT(p) ((intptr_t)(p)) +# else # define PTR2INT(p) ((long)(p)) # endif #endif -#if !defined(UINT2PTR) && !defined(PTR2UINT) +#if !defined(PTR2UINT) # if defined(HAVE_UINTPTR_T) || defined(uintptr_t) -# define UINT2PTR(p) ((void *)(uintptr_t)(p)) # define PTR2UINT(p) ((uintptr_t)(p)) # else -# define UINT2PTR(p) ((void *)(p)) # define PTR2UINT(p) ((unsigned long)(p)) # endif #endif diff --git a/generic/tclPathObj.c b/generic/tclPathObj.c index 8c81568..a698d6f 100644 --- a/generic/tclPathObj.c +++ b/generic/tclPathObj.c @@ -831,8 +831,6 @@ TclJoinPath( size_t i; const Tcl_Filesystem *fsPtr = NULL; - assert ( elements >= 0 ); - if (elements == 0) { TclNewObj(res); return res; diff --git a/generic/tclRegexp.c b/generic/tclRegexp.c index 5b13dd9..aac47bb 100644 --- a/generic/tclRegexp.c +++ b/generic/tclRegexp.c @@ -918,8 +918,8 @@ CompileRegexp( regexpPtr = (TclRegexp*)Tcl_Alloc(sizeof(TclRegexp)); regexpPtr->objPtr = NULL; regexpPtr->string = NULL; - regexpPtr->details.rm_extend.rm_so = -1; - regexpPtr->details.rm_extend.rm_eo = -1; + regexpPtr->details.rm_extend.rm_so = TCL_INDEX_NONE; + regexpPtr->details.rm_extend.rm_eo = TCL_INDEX_NONE; /* * Get the up-to-date string representation and map to unicode. diff --git a/generic/tclThreadTest.c b/generic/tclThreadTest.c index f440ec0..cfc7ceb 100644 --- a/generic/tclThreadTest.c +++ b/generic/tclThreadTest.c @@ -271,7 +271,7 @@ ThreadObjCmd( } else { result = NULL; } - return ThreadCancel(interp, (Tcl_ThreadId) (size_t) id, result, flags); + return ThreadCancel(interp, (Tcl_ThreadId) INT2PTR(id), result, flags); } case THREAD_CREATE: { const char *script; @@ -335,11 +335,11 @@ ThreadObjCmd( */ if (objc == 2) { - idObj = Tcl_NewWideIntObj((Tcl_WideInt)(size_t)Tcl_GetCurrentThread()); + idObj = Tcl_NewWideIntObj((Tcl_WideInt)INT2PTR(Tcl_GetCurrentThread())); } else if (objc == 3 && strcmp("-main", Tcl_GetString(objv[2])) == 0) { Tcl_MutexLock(&threadMutex); - idObj = Tcl_NewWideIntObj((Tcl_WideInt)(size_t)mainThreadId); + idObj = Tcl_NewWideIntObj((Tcl_WideInt)INT2PTR(mainThreadId)); Tcl_MutexUnlock(&threadMutex); } else { Tcl_WrongNumArgs(interp, 2, objv, NULL); @@ -364,7 +364,7 @@ ThreadObjCmd( return TCL_ERROR; } - result = Tcl_JoinThread((Tcl_ThreadId)(size_t)id, &status); + result = Tcl_JoinThread((Tcl_ThreadId)INT2PTR(id), &status); if (result == TCL_OK) { Tcl_SetIntObj(Tcl_GetObjResult(interp), status); } else { @@ -406,7 +406,7 @@ ThreadObjCmd( } arg++; script = Tcl_GetString(objv[arg]); - return ThreadSend(interp, (Tcl_ThreadId)(size_t)id, script, wait); + return ThreadSend(interp, (Tcl_ThreadId)INT2PTR(id), script, wait); } case THREAD_EVENT: { if (objc > 2) { diff --git a/generic/tclVar.c b/generic/tclVar.c index e403148..2c53bcd 100644 --- a/generic/tclVar.c +++ b/generic/tclVar.c @@ -268,7 +268,7 @@ static const Tcl_ObjType localVarNameType = { const Tcl_ObjInternalRep *irPtr; \ irPtr = TclFetchInternalRep((objPtr), &localVarNameType); \ (name) = irPtr ? (Tcl_Obj *)irPtr->twoPtrValue.ptr1 : NULL; \ - (index) = irPtr ? PTR2INT(irPtr->twoPtrValue.ptr2) : -1; \ + (index) = irPtr ? PTR2UINT(irPtr->twoPtrValue.ptr2) : TCL_INDEX_NONE; \ } while (0) static const Tcl_ObjType parsedVarNameType = { @@ -609,17 +609,17 @@ TclObjLookupVarEx( const char *errMsg = NULL; int index, parsed = 0; - int localIndex; + size_t localIndex; Tcl_Obj *namePtr, *arrayPtr, *elem; *arrayPtrPtr = NULL; restart: LocalGetInternalRep(part1Ptr, localIndex, namePtr); - if (localIndex >= 0) { + if (localIndex != TCL_INDEX_NONE) { if (HasLocalVars(varFramePtr) && !(flags & (TCL_GLOBAL_ONLY | TCL_NAMESPACE_ONLY)) - && (localIndex < (int)varFramePtr->numCompiledLocals)) { + && (localIndex < varFramePtr->numCompiledLocals)) { /* * Use the cached index if the names coincide. */ @@ -5587,7 +5587,7 @@ static void FreeLocalVarName( Tcl_Obj *objPtr) { - int index; + size_t index; Tcl_Obj *namePtr; LocalGetInternalRep(objPtr, index, namePtr); @@ -5603,7 +5603,7 @@ DupLocalVarName( Tcl_Obj *srcPtr, Tcl_Obj *dupPtr) { - int index; + size_t index; Tcl_Obj *namePtr; LocalGetInternalRep(srcPtr, index, namePtr); -- cgit v0.12 From 60e9b38dfbeb8b382fd60528363fe726331ac4db Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 29 Mar 2022 19:40:33 +0000 Subject: Add UTF-16 versions of Tcl_NumUtfChars/Tcl_UtfAtIndex to the stub table. Should have been part of TIP #542. Needed for Tk's "glyph_indexing_2" branch --- generic/tcl.decls | 10 ++++-- generic/tclDecls.h | 35 ++++++++++++++----- generic/tclInt.h | 4 +-- generic/tclStringObj.c | 8 ++--- generic/tclStubInit.c | 7 ++-- generic/tclUtf.c | 91 +++++++++++++++++++++++++++++++++++++++++--------- 6 files changed, 122 insertions(+), 33 deletions(-) diff --git a/generic/tcl.decls b/generic/tcl.decls index 5a03bd2..b943edd 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) @@ -2516,6 +2516,12 @@ declare 660 { declare 668 { size_t Tcl_UniCharLen(const int *uniStr) } +declare 669 { + size_t Tcl_NumUtfChars(const char *src, size_t length) +} +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..3e2b8cb 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 */ @@ -1774,6 +1774,11 @@ 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); +/* Slot 670 is reserved */ +/* 671 */ +EXTERN const char * Tcl_UtfAtIndex(const char *src, size_t index); typedef struct { const struct TclPlatStubs *tclPlatStubs; @@ -2097,7 +2102,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 +2115,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 */ @@ -2454,6 +2459,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 */ + void (*reserved670)(void); + const char * (*tcl_UtfAtIndex) (const char *src, size_t index); /* 671 */ } TclStubs; extern const TclStubs *tclStubsPtr; @@ -3046,8 +3054,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 +3078,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 \ @@ -3736,6 +3744,11 @@ extern const TclStubs *tclStubsPtr; /* Slot 667 is reserved */ #define Tcl_UniCharLen \ (tclStubsPtr->tcl_UniCharLen) /* 668 */ +#define Tcl_NumUtfChars \ + (tclStubsPtr->tcl_NumUtfChars) /* 669 */ +/* Slot 670 is reserved */ +#define Tcl_UtfAtIndex \ + (tclStubsPtr->tcl_UtfAtIndex) /* 671 */ #endif /* defined(USE_TCL_STUBS) */ @@ -3937,6 +3950,12 @@ 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_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 1eb486e..edd0172 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -4666,12 +4666,12 @@ 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 TclNumUtfCharsM(int numChars, const char *bytes, * size_t numBytes); *---------------------------------------------------------------- */ -#define TclNumUtfChars(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 c8d9df7..2755cf6 100644 --- a/generic/tclStringObj.c +++ b/generic/tclStringObj.c @@ -440,7 +440,7 @@ Tcl_GetCharLength( */ if (numChars == TCL_INDEX_NONE) { - TclNumUtfChars(numChars, objPtr->bytes, objPtr->length); + TclNumUtfCharsM(numChars, objPtr->bytes, objPtr->length); stringPtr->numChars = numChars; } return numChars; @@ -543,7 +543,7 @@ Tcl_GetUniChar( */ if (stringPtr->numChars == TCL_INDEX_NONE) { - TclNumUtfChars(stringPtr->numChars, objPtr->bytes, objPtr->length); + TclNumUtfCharsM(stringPtr->numChars, objPtr->bytes, objPtr->length); } if (stringPtr->numChars == objPtr->length) { return (unsigned char) objPtr->bytes[index]; @@ -709,7 +709,7 @@ Tcl_GetRange( */ if (stringPtr->numChars == TCL_INDEX_NONE) { - TclNumUtfChars(stringPtr->numChars, objPtr->bytes, objPtr->length); + TclNumUtfCharsM(stringPtr->numChars, objPtr->bytes, objPtr->length); } if (stringPtr->numChars == objPtr->length) { if (last >= stringPtr->numChars) { @@ -4045,7 +4045,7 @@ ExtendUnicodeRepWithString( numOrigChars = stringPtr->numChars; } if (numAppendChars == TCL_INDEX_NONE) { - TclNumUtfChars(numAppendChars, bytes, numBytes); + TclNumUtfCharsM(numAppendChars, bytes, numBytes); } needed = numOrigChars + numAppendChars; diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c index ea7083f..59036ec 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 */ @@ -1362,6 +1362,9 @@ const TclStubs tclStubs = { 0, /* 666 */ 0, /* 667 */ Tcl_UniCharLen, /* 668 */ + Tcl_NumUtfChars, /* 669 */ + 0, /* 670 */ + Tcl_UtfAtIndex, /* 671 */ }; /* !END!: Do not edit above this line. */ diff --git a/generic/tclUtf.c b/generic/tclUtf.c index e353b7f..09e464f 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,34 +1220,42 @@ Tcl_UniCharAtIndex( *--------------------------------------------------------------------------- */ +#undef Tcl_UtfAtIndex const char * 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; } +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 ec52ceb63b1563cfdeb057731661d0ae92332765 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 29 Mar 2022 21:14:54 +0000 Subject: Undo deprecation for Tcl_AppendUnicodeToObj (as described in the TIP) --- generic/tcl.decls | 2 +- generic/tclDecls.h | 5 ++--- 2 files changed, 3 insertions(+), 4 deletions(-) diff --git a/generic/tcl.decls b/generic/tcl.decls index 3b5c8a9..f0718c1 100644 --- a/generic/tcl.decls +++ b/generic/tcl.decls @@ -1356,7 +1356,7 @@ declare 382 {deprecated {No longer in use, changed to macro}} { declare 383 { Tcl_Obj *Tcl_GetRange(Tcl_Obj *objPtr, int first, int last) } -declare 384 {deprecated {Use Tcl_AppendStringsToObj}} { +declare 384 { void Tcl_AppendUnicodeToObj(Tcl_Obj *objPtr, const unsigned short *unicode, int length) } diff --git a/generic/tclDecls.h b/generic/tclDecls.h index ac90006..020c4bb 100644 --- a/generic/tclDecls.h +++ b/generic/tclDecls.h @@ -1157,8 +1157,7 @@ unsigned short * Tcl_GetUnicode(Tcl_Obj *objPtr); /* 383 */ EXTERN Tcl_Obj * Tcl_GetRange(Tcl_Obj *objPtr, int first, int last); /* 384 */ -TCL_DEPRECATED("Use Tcl_AppendStringsToObj") -void Tcl_AppendUnicodeToObj(Tcl_Obj *objPtr, +EXTERN void Tcl_AppendUnicodeToObj(Tcl_Obj *objPtr, const unsigned short *unicode, int length); /* 385 */ EXTERN int Tcl_RegExpMatchObj(Tcl_Interp *interp, @@ -2392,7 +2391,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 unsigned short *unicode, int length); /* 384 */ + void (*tcl_AppendUnicodeToObj) (Tcl_Obj *objPtr, const unsigned short *unicode, int length); /* 384 */ int (*tcl_RegExpMatchObj) (Tcl_Interp *interp, Tcl_Obj *textObj, Tcl_Obj *patternObj); /* 385 */ void (*tcl_SetNotifier) (const Tcl_NotifierProcs *notifierProcPtr); /* 386 */ Tcl_Mutex * (*tcl_GetAllocMutex) (void); /* 387 */ -- cgit v0.12 From 572557152a0233310ad8df9c1f877cecd65e3406 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 30 Mar 2022 11:56:16 +0000 Subject: Change UTF-16 version of Tcl_GetRange() not to use the tclStringObj type any more --- generic/tclStringObj.c | 55 +++++++++++++++++++------------------------------- generic/tclTest.c | 3 ++- 2 files changed, 23 insertions(+), 35 deletions(-) diff --git a/generic/tclStringObj.c b/generic/tclStringObj.c index 988c6e5..63b833f 100644 --- a/generic/tclStringObj.c +++ b/generic/tclStringObj.c @@ -180,12 +180,12 @@ DupUTF16StringInternalRep( Tcl_Obj *copyPtr) /* Object with internal rep to set. Must not * currently have an internal rep.*/ { - String *srcStringPtr = ((String *) (srcPtr)->internalRep.twoPtrValue.ptr1); + String *srcStringPtr = GET_STRING(srcPtr); size_t size = offsetof(String, unicode) + (((srcStringPtr->allocated) + 1U) * sizeof(unsigned short)); String *copyStringPtr = (String *)ckalloc(size); memcpy(copyStringPtr, srcStringPtr, size); - copyPtr->internalRep.twoPtrValue.ptr1 = copyStringPtr; + SET_STRING(copyPtr, copyStringPtr); copyPtr->typePtr = &tclStringType; } @@ -223,7 +223,7 @@ SetUTF16StringFromAny( stringPtr->allocated = size; stringPtr->maxChars = size; stringPtr->hasUnicode = 1; - objPtr->internalRep.twoPtrValue.ptr1 = stringPtr; + SET_STRING(objPtr, stringPtr); objPtr->typePtr = &tclStringType; } return TCL_OK; @@ -234,7 +234,7 @@ UpdateStringOfUTF16String( Tcl_Obj *objPtr) /* Object with string rep to update. */ { Tcl_DString ds; - String *stringPtr = ((String *) (objPtr)->internalRep.twoPtrValue.ptr1); + String *stringPtr = GET_STRING(objPtr); Tcl_DStringInit(&ds); const char *string = Tcl_Char16ToUtfDString(stringPtr->unicode, stringPtr->numChars, &ds); @@ -560,18 +560,19 @@ Tcl_NewUnicodeObj( Tcl_Obj *objPtr; TclNewObj(objPtr); - TclFreeInternalRep(objPtr); + TclInvalidateStringRep(objPtr); - String *stringPtr = (String *)ckalloc((offsetof(String, unicode) + 2U) + numChars * sizeof(unsigned short)); - memcpy(stringPtr->unicode, unicode, numChars); - stringPtr->unicode[numChars] = 0; + String *stringPtr = (String *)ckalloc((offsetof(String, unicode) + + sizeof(unsigned short)) + numChars * sizeof(unsigned short)); + memcpy(stringPtr->unicode, unicode, numChars); + stringPtr->unicode[numChars] = 0; - stringPtr->numChars = numChars; - stringPtr->allocated = numChars; - stringPtr->maxChars = numChars; - stringPtr->hasUnicode = 1; - objPtr->internalRep.twoPtrValue.ptr1 = stringPtr; - objPtr->typePtr = &tclStringType; + stringPtr->numChars = numChars; + stringPtr->allocated = numChars; + stringPtr->maxChars = numChars; + stringPtr->hasUnicode = 1; + SET_STRING(objPtr, stringPtr); + objPtr->typePtr = &tclStringType; return objPtr; } @@ -1019,7 +1020,6 @@ Tcl_GetRange( int last) /* Last index of the range. */ { Tcl_Obj *newObjPtr; /* The Tcl object to find the range of. */ - String *stringPtr; int length; if (first < 0) { @@ -1044,31 +1044,18 @@ Tcl_GetRange( return Tcl_NewByteArrayObj(bytes + first, last - first + 1); } - /* - * OK, need to work with the object as a utf16 string. - */ - - SetUTF16StringFromAny(NULL, objPtr); - stringPtr = GET_STRING(objPtr); + int numChars = Tcl_NumUtfChars(objPtr->bytes, objPtr->length); - if (last < 0 || last >= stringPtr->numChars) { - last = stringPtr->numChars - 1; + if (last >= numChars) { + last = numChars - 1; } if (last < first) { TclNewObj(newObjPtr); return newObjPtr; } - /* See: bug [11ae2be95dac9417] */ - if ((first > 0) && ((stringPtr->unicode[first] & 0xFC00) == 0xDC00) - && ((stringPtr->unicode[first-1] & 0xFC00) == 0xD800)) { - ++first; - } - if ((last + 1 < stringPtr->numChars) - && ((stringPtr->unicode[last+1] & 0xFC00) == 0xDC00) - && ((stringPtr->unicode[last] & 0xFC00) == 0xD800)) { - ++last; - } - return Tcl_NewUnicodeObj(stringPtr->unicode + first, last - first + 1); + const char *begin = Tcl_UtfAtIndex(objPtr->bytes, first); + const char *end = Tcl_UtfAtIndex(objPtr->bytes, last + 1); + return Tcl_NewStringObj(begin, end - begin); } #endif diff --git a/generic/tclTest.c b/generic/tclTest.c index 30681d9..cbd1f70 100644 --- a/generic/tclTest.c +++ b/generic/tclTest.c @@ -16,6 +16,7 @@ */ #undef STATIC_BUILD +#undef BUILD_tcl #ifndef USE_TCL_STUBS # define USE_TCL_STUBS #endif @@ -6971,7 +6972,7 @@ TestUtfNextCmd( int objc, Tcl_Obj *const objv[]) { - size_t numBytes; + int numBytes; char *bytes; const char *result, *first; char buffer[32]; -- cgit v0.12 From b1a8dc460f2e7f8a7ff436f52729f729ead3b92d Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 30 Mar 2022 12:13:01 +0000 Subject: Fix limit-checking on first/last arguments for Tcl_GetRange(). Was not correctly forward-merged from core-8-branch (there it's correct) --- generic/tclStringObj.c | 9 +++------ 1 file changed, 3 insertions(+), 6 deletions(-) diff --git a/generic/tclStringObj.c b/generic/tclStringObj.c index 2755cf6..da3f8ee 100644 --- a/generic/tclStringObj.c +++ b/generic/tclStringObj.c @@ -674,9 +674,6 @@ Tcl_GetRange( if (first == TCL_INDEX_NONE) { first = TCL_INDEX_START; } - if (last + 2 <= first + 1) { - return Tcl_NewObj(); - } /* * Optimize the case where we're really dealing with a bytearray object @@ -689,7 +686,7 @@ Tcl_GetRange( if (last >= length) { last = length - 1; } - if (last < first) { + if (last + 1 < first + 1) { TclNewObj(newObjPtr); return newObjPtr; } @@ -715,7 +712,7 @@ Tcl_GetRange( if (last >= stringPtr->numChars) { last = stringPtr->numChars - 1; } - if (last < first) { + if (last + 1 < first + 1) { TclNewObj(newObjPtr); return newObjPtr; } @@ -736,7 +733,7 @@ Tcl_GetRange( if (last >= stringPtr->numChars) { last = stringPtr->numChars - 1; } - if (last < first) { + if (last + 1 < first + 1) { TclNewObj(newObjPtr); return newObjPtr; } -- cgit v0.12 From af3676b8c8c9492af51242b319894eb695af86bb Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 30 Mar 2022 14:46:09 +0000 Subject: More progress --- generic/tclAssembly.c | 2 +- generic/tclCompile.c | 30 +++++++++++++++--------------- generic/tclCompile.h | 10 +++++----- generic/tclEnsemble.c | 8 ++++---- generic/tclOptimize.c | 2 +- 5 files changed, 26 insertions(+), 26 deletions(-) diff --git a/generic/tclAssembly.c b/generic/tclAssembly.c index 6027741..4458e59 100644 --- a/generic/tclAssembly.c +++ b/generic/tclAssembly.c @@ -4163,7 +4163,7 @@ RestoreEmbeddedExceptionRanges( BasicBlock* bbPtr; /* Current basic block */ int rangeBase; /* Base of the foreign exception ranges when * they are reinstalled */ - int rangeIndex; /* Index of the current foreign exception + size_t rangeIndex; /* Index of the current foreign exception * range as reinstalled */ ExceptionRange* range; /* Current foreign exception range */ unsigned char opcode; /* Current instruction's opcode */ diff --git a/generic/tclCompile.c b/generic/tclCompile.c index ce7c824..f998aa1 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -3359,7 +3359,7 @@ EnterCmdWordData( *---------------------------------------------------------------------- */ -int +size_t TclCreateExceptRange( ExceptionRangeType type, /* The kind of ExceptionRange desired. */ CompileEnv *envPtr)/* Points to CompileEnv for which to create a @@ -3367,9 +3367,9 @@ TclCreateExceptRange( { ExceptionRange *rangePtr; ExceptionAux *auxPtr; - int index = envPtr->exceptArrayNext; + size_t index = envPtr->exceptArrayNext; - if (index >= envPtr->exceptArrayEnd) { + if (index >= (size_t)envPtr->exceptArrayEnd) { /* * Expand the ExceptionRange array. The currently allocated entries * are stored between elements 0 and (envPtr->exceptArrayNext - 1) @@ -3449,7 +3449,7 @@ TclGetInnermostExceptionRange( int returnCode, ExceptionAux **auxPtrPtr) { - int i = envPtr->exceptArrayNext; + size_t i = envPtr->exceptArrayNext; ExceptionRange *rangePtr = envPtr->exceptArrayPtr + i; while (i > 0) { @@ -3498,11 +3498,11 @@ TclAddLoopBreakFixup( auxPtr->allocBreakTargets *= 2; auxPtr->allocBreakTargets += 2; if (auxPtr->breakTargets) { - auxPtr->breakTargets = (unsigned int *)Tcl_Realloc(auxPtr->breakTargets, - sizeof(int) * auxPtr->allocBreakTargets); + auxPtr->breakTargets = (size_t *)Tcl_Realloc(auxPtr->breakTargets, + sizeof(size_t) * auxPtr->allocBreakTargets); } else { auxPtr->breakTargets = - (unsigned int *)Tcl_Alloc(sizeof(int) * auxPtr->allocBreakTargets); + (size_t *)Tcl_Alloc(sizeof(size_t) * auxPtr->allocBreakTargets); } } auxPtr->breakTargets[auxPtr->numBreakTargets - 1] = CurrentOffset(envPtr); @@ -3524,11 +3524,11 @@ TclAddLoopContinueFixup( auxPtr->allocContinueTargets *= 2; auxPtr->allocContinueTargets += 2; if (auxPtr->continueTargets) { - auxPtr->continueTargets = (unsigned int *)Tcl_Realloc(auxPtr->continueTargets, - sizeof(int) * auxPtr->allocContinueTargets); + auxPtr->continueTargets = (size_t *)Tcl_Realloc(auxPtr->continueTargets, + sizeof(size_t) * auxPtr->allocContinueTargets); } else { auxPtr->continueTargets = - (unsigned int *)Tcl_Alloc(sizeof(int) * auxPtr->allocContinueTargets); + (size_t *)Tcl_Alloc(sizeof(size_t) * auxPtr->allocContinueTargets); } } auxPtr->continueTargets[auxPtr->numContinueTargets - 1] = @@ -3596,7 +3596,7 @@ StartExpanding( * where this expansion started. */ - for (i=0 ; iexceptArrayNext ; i++) { + for (i=0 ; i<(int)envPtr->exceptArrayNext ; i++) { ExceptionRange *rangePtr = &envPtr->exceptArrayPtr[i]; ExceptionAux *auxPtr = &envPtr->exceptAuxArrayPtr[i]; @@ -3662,7 +3662,7 @@ TclFinalizeLoopExceptionRange( for (i=0 ; i<(int)auxPtr->numBreakTargets ; i++) { site = envPtr->codeStart + auxPtr->breakTargets[i]; - offset = (int)rangePtr->breakOffset - auxPtr->breakTargets[i]; + offset = rangePtr->breakOffset - auxPtr->breakTargets[i]; TclUpdateInstInt4AtPc(INST_JUMP4, offset, site); } for (i=0 ; i<(int)auxPtr->numContinueTargets ; i++) { @@ -3680,7 +3680,7 @@ TclFinalizeLoopExceptionRange( *++site = INST_NOP; } } else { - offset = (int)rangePtr->continueOffset - auxPtr->continueTargets[i]; + offset = rangePtr->continueOffset - auxPtr->continueTargets[i]; TclUpdateInstInt4AtPc(INST_JUMP4, offset, site); } } @@ -4029,7 +4029,7 @@ TclFixupForwardJump( */ firstCmd = jumpFixupPtr->cmdIndex; - lastCmd = (int)envPtr->numCommands - 1; + lastCmd = envPtr->numCommands - 1; if (firstCmd < lastCmd) { for (k = firstCmd; k <= lastCmd; k++) { envPtr->cmdMapPtr[k].codeOffset += 3; @@ -4058,7 +4058,7 @@ TclFixupForwardJump( } } - for (k = 0 ; k < envPtr->exceptArrayNext ; k++) { + for (k = 0 ; k < (int)envPtr->exceptArrayNext ; k++) { ExceptionAux *auxPtr = &envPtr->exceptAuxArrayPtr[k]; int i; diff --git a/generic/tclCompile.h b/generic/tclCompile.h index 6a719ea..1dada0e 100644 --- a/generic/tclCompile.h +++ b/generic/tclCompile.h @@ -135,7 +135,7 @@ typedef struct ExceptionAux { size_t numBreakTargets; /* The number of [break]s that want to be * targeted to the place where this loop * exception will be bound to. */ - unsigned int *breakTargets; /* The offsets of the INST_JUMP4 instructions + size_t *breakTargets; /* The offsets of the INST_JUMP4 instructions * issued by the [break]s that we must * update. Note that resizing a jump (via * TclFixupForwardJump) can cause the contents @@ -145,7 +145,7 @@ typedef struct ExceptionAux { size_t numContinueTargets; /* The number of [continue]s that want to be * targeted to the place where this loop * exception will be bound to. */ - unsigned int *continueTargets; /* The offsets of the INST_JUMP4 instructions + size_t *continueTargets; /* The offsets of the INST_JUMP4 instructions * issued by the [continue]s that we must * update. Note that resizing a jump (via * TclFixupForwardJump) can cause the contents @@ -329,7 +329,7 @@ typedef struct CompileEnv { ExceptionRange *exceptArrayPtr; /* Points to start of the ExceptionRange * array. */ - int exceptArrayNext; /* Next free ExceptionRange array index. + size_t exceptArrayNext; /* Next free ExceptionRange array index. * exceptArrayNext is the number of ranges and * (exceptArrayNext-1) is the index of the * current range's array entry. */ @@ -1108,7 +1108,7 @@ MODULE_SCOPE void TclCompileVarSubst(Tcl_Interp *interp, Tcl_Token *tokenPtr, CompileEnv *envPtr); MODULE_SCOPE size_t TclCreateAuxData(void *clientData, const AuxDataType *typePtr, CompileEnv *envPtr); -MODULE_SCOPE int TclCreateExceptRange(ExceptionRangeType type, +MODULE_SCOPE size_t TclCreateExceptRange(ExceptionRangeType type, CompileEnv *envPtr); MODULE_SCOPE ExecEnv * TclCreateExecEnv(Tcl_Interp *interp, size_t size); MODULE_SCOPE Tcl_Obj * TclCreateLiteral(Interp *iPtr, const char *bytes, @@ -1454,7 +1454,7 @@ MODULE_SCOPE int TclPushProcCallFrame(void *clientData, #define TclFixupForwardJumpToHere(envPtr, fixupPtr, threshold) \ TclFixupForwardJump((envPtr), (fixupPtr), \ - (envPtr)->codeNext-(envPtr)->codeStart-(fixupPtr)->codeOffset, \ + (envPtr)->codeNext-(envPtr)->codeStart-(int)(fixupPtr)->codeOffset, \ (threshold)) /* diff --git a/generic/tclEnsemble.c b/generic/tclEnsemble.c index 5fdf7f4..de9ec61 100644 --- a/generic/tclEnsemble.c +++ b/generic/tclEnsemble.c @@ -3242,21 +3242,21 @@ int TclAttemptCompileProc( Tcl_Interp *interp, Tcl_Parse *parsePtr, - size_t depth1, + size_t depth, Command *cmdPtr, CompileEnv *envPtr) /* Holds resulting instructions. */ { DefineLineInformation; - int result, i; + int result; + size_t i; Tcl_Token *saveTokenPtr = parsePtr->tokenPtr; int savedStackDepth = envPtr->currStackDepth; unsigned savedCodeNext = envPtr->codeNext - envPtr->codeStart; int savedAuxDataArrayNext = envPtr->auxDataArrayNext; - int savedExceptArrayNext = envPtr->exceptArrayNext; + size_t savedExceptArrayNext = envPtr->exceptArrayNext; #ifdef TCL_COMPILE_DEBUG int savedExceptDepth = envPtr->exceptDepth; #endif - int depth = depth1; if (cmdPtr->compileProc == NULL) { return TCL_ERROR; diff --git a/generic/tclOptimize.c b/generic/tclOptimize.c index 9341336..7d3bc7b 100644 --- a/generic/tclOptimize.c +++ b/generic/tclOptimize.c @@ -125,7 +125,7 @@ LocateTargetAddresses( * Enter in the targets of exception ranges. */ - for (i=0 ; i<(size_t)envPtr->exceptArrayNext ; i++) { + for (i=0 ; iexceptArrayNext ; i++) { ExceptionRange *rangePtr = &envPtr->exceptArrayPtr[i]; if (rangePtr->type == CATCH_EXCEPTION_RANGE) { -- cgit v0.12 From 284dedf155f2929a52b5ccffbe13c1d55a643cb6 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 30 Mar 2022 15:44:57 +0000 Subject: More progress --- generic/tclAssembly.c | 14 +++++++------- generic/tclCompile.c | 6 +++--- generic/tclCompile.h | 26 +++++++++++++------------- generic/tclDisassemble.c | 6 +++--- generic/tclEnsemble.c | 2 +- generic/tclExecute.c | 11 ++++++----- 6 files changed, 33 insertions(+), 32 deletions(-) diff --git a/generic/tclAssembly.c b/generic/tclAssembly.c index 4458e59..3abd4fa 100644 --- a/generic/tclAssembly.c +++ b/generic/tclAssembly.c @@ -965,7 +965,7 @@ TclCompileAssembleCmd( size_t numCommands = envPtr->numCommands; int offset = envPtr->codeNext - envPtr->codeStart; - int depth = envPtr->currStackDepth; + size_t depth = envPtr->currStackDepth; /* * Make sure that the command has a single arg that is a simple word. */ @@ -1811,8 +1811,8 @@ CompileEmbeddedScript( * code. */ - int savedStackDepth = envPtr->currStackDepth; - int savedMaxStackDepth = envPtr->maxStackDepth; + size_t savedStackDepth = envPtr->currStackDepth; + size_t savedMaxStackDepth = envPtr->maxStackDepth; int savedExceptArrayNext = envPtr->exceptArrayNext; envPtr->currStackDepth = 0; @@ -3334,7 +3334,7 @@ CheckStack( */ maxDepth = assemEnvPtr->maxDepth + envPtr->currStackDepth; - if (maxDepth > envPtr->maxStackDepth) { + if (maxDepth > (int)envPtr->maxStackDepth) { envPtr->maxStackDepth = maxDepth; } @@ -4126,8 +4126,8 @@ StackFreshCatches( TclCreateExceptRange(CATCH_EXCEPTION_RANGE, envPtr); range = envPtr->exceptArrayPtr + catchIndices[catchDepth]; range->nestingLevel = envPtr->exceptDepth + catchDepth; - envPtr->maxExceptDepth = - TclMax(range->nestingLevel + 1, envPtr->maxExceptDepth); + envPtr->maxExceptDepth= + TclMax(range->nestingLevel + 1, (int)envPtr->maxExceptDepth); range->codeOffset = bbPtr->startOffset; entryPtr = Tcl_FindHashEntry(&assemEnvPtr->labelHash, @@ -4190,7 +4190,7 @@ RestoreEmbeddedExceptionRanges( range->nestingLevel += envPtr->exceptDepth + bbPtr->catchDepth; memcpy(envPtr->exceptArrayPtr + rangeIndex, range, sizeof(ExceptionRange)); - if (range->nestingLevel >= envPtr->maxExceptDepth) { + if (range->nestingLevel >= (int)envPtr->maxExceptDepth) { envPtr->maxExceptDepth = range->nestingLevel + 1; } } diff --git a/generic/tclCompile.c b/generic/tclCompile.c index f998aa1..a5af54e 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -3560,7 +3560,7 @@ TclCleanupStackForBreakContinue( while (toPop --> 0) { TclEmitOpcode(INST_EXPAND_DROP, envPtr); } - TclAdjustStackDepth(auxPtr->expandTargetDepth - envPtr->currStackDepth, + TclAdjustStackDepth((int)(auxPtr->expandTargetDepth - envPtr->currStackDepth), envPtr); envPtr->currStackDepth = auxPtr->expandTargetDepth; } @@ -4161,7 +4161,7 @@ TclEmitInvoke( &auxContinuePtr); if (rangePtr == NULL || rangePtr->type != LOOP_EXCEPTION_RANGE) { auxContinuePtr = NULL; - } else if (auxContinuePtr->stackDepth == envPtr->currStackDepth-wordCount + } else if (auxContinuePtr->stackDepth == (int)envPtr->currStackDepth-wordCount && auxContinuePtr->expandTarget == envPtr->expandCount-expandCount) { auxContinuePtr = NULL; } else { @@ -4172,7 +4172,7 @@ TclEmitInvoke( if (rangePtr == NULL || rangePtr->type != LOOP_EXCEPTION_RANGE) { auxBreakPtr = NULL; } else if (auxContinuePtr == NULL - && auxBreakPtr->stackDepth == envPtr->currStackDepth-wordCount + && auxBreakPtr->stackDepth == (int)envPtr->currStackDepth-wordCount && auxBreakPtr->expandTarget == envPtr->expandCount-expandCount) { auxBreakPtr = NULL; } else { diff --git a/generic/tclCompile.h b/generic/tclCompile.h index 1dada0e..5f906ac 100644 --- a/generic/tclCompile.h +++ b/generic/tclCompile.h @@ -297,14 +297,14 @@ 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 + size_t maxExceptDepth; /* Max nesting level of exception ranges; -1 * if no ranges have been compiled. */ - int maxStackDepth; /* Maximum number of stack elements needed to + size_t maxStackDepth; /* Maximum number of stack elements needed to * execute the code. Set by compilation * procedures before returning. */ - int currStackDepth; /* Current stack depth. */ + size_t currStackDepth; /* Current stack depth. */ LiteralTable localLitTable; /* Contains LiteralEntry's describing all Tcl * objects referenced by this compiled code. * Indexed by the string representations of @@ -467,9 +467,9 @@ typedef struct ByteCode { size_t numAuxDataItems; /* Number of AuxData items. */ size_t numCmdLocBytes; /* Number of bytes needed for encoded command * location information. */ - int maxExceptDepth; /* Maximum nesting level of ExceptionRanges; + size_t maxExceptDepth; /* Maximum nesting level of ExceptionRanges; * -1 if no ranges were compiled. */ - int maxStackDepth; /* Maximum number of stack elements needed to + size_t maxStackDepth; /* Maximum number of stack elements needed to * execute the code. */ unsigned char *codeStart; /* Points to the first byte of the code. This * is just after the final ByteCode member @@ -1241,7 +1241,7 @@ MODULE_SCOPE int TclPushProcCallFrame(void *clientData, #define TclAdjustStackDepth(delta, envPtr) \ do { \ if ((delta) < 0) { \ - if ((envPtr)->maxStackDepth < (envPtr)->currStackDepth) { \ + if ((int)(envPtr)->maxStackDepth < (int)(envPtr)->currStackDepth) { \ (envPtr)->maxStackDepth = (envPtr)->currStackDepth; \ } \ } \ @@ -1257,9 +1257,9 @@ MODULE_SCOPE int TclPushProcCallFrame(void *clientData, #define TclCheckStackDepth(depth, envPtr) \ do { \ size_t _dd = (depth); \ - if (_dd != (size_t)(envPtr)->currStackDepth) { \ + if (_dd != (envPtr)->currStackDepth) { \ Tcl_Panic("bad stack depth computations: is %" TCL_Z_MODIFIER "u, should be %" TCL_Z_MODIFIER "u", \ - (size_t)(envPtr)->currStackDepth, _dd); \ + (envPtr)->currStackDepth, _dd); \ } \ } while (0) @@ -1576,15 +1576,15 @@ MODULE_SCOPE int TclPushProcCallFrame(void *clientData, * of LOOP ranges is an interesting datum for debugging purposes, and that is * what we compute now. * - * static int ExceptionRangeStarts(CompileEnv *envPtr, int index); - * static void ExceptionRangeEnds(CompileEnv *envPtr, int index); - * static void ExceptionRangeTarget(CompileEnv *envPtr, int index, LABEL); + * static int ExceptionRangeStarts(CompileEnv *envPtr, size_t index); + * static void ExceptionRangeEnds(CompileEnv *envPtr, size_t index); + * static void ExceptionRangeTarget(CompileEnv *envPtr, size_t index, LABEL); */ #define ExceptionRangeStarts(envPtr, index) \ (((envPtr)->exceptDepth++), \ ((envPtr)->maxExceptDepth = \ - TclMax((envPtr)->exceptDepth, (envPtr)->maxExceptDepth)), \ + TclMax((int)(envPtr)->exceptDepth, (int)(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 ec0836a..cf8a154 100644 --- a/generic/tclDisassemble.c +++ b/generic/tclDisassemble.c @@ -288,7 +288,7 @@ DisassembleByteCodeObj( TclGetString(fileObj), line); } Tcl_AppendPrintfToObj(bufferObj, - "\n Cmds %d, src %" TCL_Z_MODIFIER "u, inst %" TCL_Z_MODIFIER "u, litObjs %" TCL_Z_MODIFIER "u, aux %" TCL_Z_MODIFIER "u, stkDepth %u, code/src %.2f\n", + "\n Cmds %d, src %" TCL_Z_MODIFIER "u, inst %" TCL_Z_MODIFIER "u, litObjs %" TCL_Z_MODIFIER "u, aux %" TCL_Z_MODIFIER "u, stkDepth %" TCL_Z_MODIFIER "u, code/src %.2f\n", numCmds, codePtr->numSrcBytes, codePtr->numCodeBytes, codePtr->numLitObjects, codePtr->numAuxDataItems, codePtr->maxStackDepth, @@ -352,7 +352,7 @@ DisassembleByteCodeObj( */ if ((int)codePtr->numExceptRanges > 0) { - Tcl_AppendPrintfToObj(bufferObj, " Exception ranges %" TCL_Z_MODIFIER "u, depth %d:\n", + Tcl_AppendPrintfToObj(bufferObj, " Exception ranges %" TCL_Z_MODIFIER "u, depth %" TCL_Z_MODIFIER "u:\n", codePtr->numExceptRanges, codePtr->maxExceptDepth); for (i = 0; i < (int)codePtr->numExceptRanges; i++) { ExceptionRange *rangePtr = &codePtr->exceptArrayPtr[i]; @@ -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, (int)codePtr->numSrcBytes)); + Tcl_NewStringObj(codePtr->source, 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/tclEnsemble.c b/generic/tclEnsemble.c index de9ec61..3c6af3f 100644 --- a/generic/tclEnsemble.c +++ b/generic/tclEnsemble.c @@ -3255,7 +3255,7 @@ TclAttemptCompileProc( int savedAuxDataArrayNext = envPtr->auxDataArrayNext; size_t savedExceptArrayNext = envPtr->exceptArrayNext; #ifdef TCL_COMPILE_DEBUG - int savedExceptDepth = envPtr->exceptDepth; + size_t savedExceptDepth = envPtr->exceptDepth; #endif if (cmdPtr->compileProc == NULL) { diff --git a/generic/tclExecute.c b/generic/tclExecute.c index 19cf65f..d920f2d 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -638,7 +638,7 @@ static ExceptionRange * GetExceptRangeForPc(const unsigned char *pc, static const char * GetSrcInfoForPc(const unsigned char *pc, ByteCode *codePtr, size_t *lengthPtr, const unsigned char **pcBeg, int *cmdIdxPtr); -static Tcl_Obj ** GrowEvaluationStack(ExecEnv *eePtr, int growth, +static Tcl_Obj ** GrowEvaluationStack(ExecEnv *eePtr, size_t growth, int move); static void IllegalExprOperandType(Tcl_Interp *interp, const unsigned char *pc, Tcl_Obj *opndPtr); @@ -975,12 +975,13 @@ static Tcl_Obj ** GrowEvaluationStack( ExecEnv *eePtr, /* Points to the ExecEnv with an evaluation * stack to enlarge. */ - int growth, /* How much larger than the current used + size_t growth1, /* How much larger than the current used * size. */ int move) /* 1 if move words since last marker. */ { ExecStack *esPtr = eePtr->execStackPtr, *oldPtr = NULL; size_t newBytes; + int growth = growth1; int newElems, currElems, needed = growth - (esPtr->endPtr - esPtr->tosPtr); Tcl_Obj **markerPtr = esPtr->markerPtr, **memStart; int moveWords = 0; @@ -1888,10 +1889,10 @@ TclNRExecuteByteCode( { Interp *iPtr = (Interp *) interp; TEBCdata *TD; - int size = sizeof(TEBCdata) - 1 + size_t size = sizeof(TEBCdata) - 1 + (codePtr->maxStackDepth + codePtr->maxExceptDepth) * sizeof(void *); - int numWords = (size + sizeof(Tcl_Obj *) - 1) / sizeof(Tcl_Obj *); + size_t numWords = (size + sizeof(Tcl_Obj *) - 1) / sizeof(Tcl_Obj *); TclPreserveByteCode(codePtr); @@ -8681,7 +8682,7 @@ PrintByteCodeInfo( fprintf(stdout, " Source: "); TclPrintSource(stdout, codePtr->source, 60); - fprintf(stdout, "\n Cmds %" TCL_Z_MODIFIER "u, src %" TCL_Z_MODIFIER "u, inst %" TCL_Z_MODIFIER "u, litObjs %" TCL_Z_MODIFIER "u, aux %" TCL_Z_MODIFIER "u, stkDepth %d, code/src %.2f\n", + fprintf(stdout, "\n Cmds %" TCL_Z_MODIFIER "u, src %" TCL_Z_MODIFIER "u, inst %" TCL_Z_MODIFIER "u, litObjs %" TCL_Z_MODIFIER "u, aux %" TCL_Z_MODIFIER "u, stkDepth %" TCL_Z_MODIFIER "u, code/src %.2f\n", codePtr->numCommands, codePtr->numSrcBytes, codePtr->numCodeBytes, codePtr->numLitObjects, codePtr->numAuxDataItems, codePtr->maxStackDepth, -- cgit v0.12 From de17b47b9cdeeda185381fe6ccab416af3954253 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 31 Mar 2022 15:59:11 +0000 Subject: more progress --- generic/tclCompile.c | 16 ++++++++-------- generic/tclCompile.h | 8 ++++---- generic/tclEnsemble.c | 2 +- 3 files changed, 13 insertions(+), 13 deletions(-) diff --git a/generic/tclCompile.c b/generic/tclCompile.c index a5af54e..1c440e3 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -3419,7 +3419,7 @@ TclCreateExceptRange( auxPtr->supportsContinue = 1; auxPtr->stackDepth = envPtr->currStackDepth; auxPtr->expandTarget = envPtr->expandCount; - auxPtr->expandTargetDepth = -1; + auxPtr->expandTargetDepth = TCL_INDEX_NONE; auxPtr->numBreakTargets = 0; auxPtr->breakTargets = NULL; auxPtr->allocBreakTargets = 0; @@ -3553,7 +3553,7 @@ TclCleanupStackForBreakContinue( CompileEnv *envPtr, ExceptionAux *auxPtr) { - int savedStackDepth = envPtr->currStackDepth; + size_t savedStackDepth = envPtr->currStackDepth; int toPop = envPtr->expandCount - auxPtr->expandTarget; if (toPop > 0) { @@ -4161,8 +4161,8 @@ TclEmitInvoke( &auxContinuePtr); if (rangePtr == NULL || rangePtr->type != LOOP_EXCEPTION_RANGE) { auxContinuePtr = NULL; - } else if (auxContinuePtr->stackDepth == (int)envPtr->currStackDepth-wordCount - && auxContinuePtr->expandTarget == envPtr->expandCount-expandCount) { + } else if (auxContinuePtr->stackDepth == envPtr->currStackDepth-wordCount + && (auxContinuePtr->expandTarget+expandCount == envPtr->expandCount)) { auxContinuePtr = NULL; } else { continueRange = auxContinuePtr - envPtr->exceptAuxArrayPtr; @@ -4172,8 +4172,8 @@ TclEmitInvoke( if (rangePtr == NULL || rangePtr->type != LOOP_EXCEPTION_RANGE) { auxBreakPtr = NULL; } else if (auxContinuePtr == NULL - && auxBreakPtr->stackDepth == (int)envPtr->currStackDepth-wordCount - && auxBreakPtr->expandTarget == envPtr->expandCount-expandCount) { + && auxBreakPtr->stackDepth+wordCount == envPtr->currStackDepth + && auxBreakPtr->expandTarget+expandCount == envPtr->expandCount) { auxBreakPtr = NULL; } else { breakRange = auxBreakPtr - envPtr->exceptAuxArrayPtr; @@ -4219,8 +4219,8 @@ TclEmitInvoke( */ if (auxBreakPtr != NULL || auxContinuePtr != NULL) { - int savedStackDepth = envPtr->currStackDepth; - int savedExpandCount = envPtr->expandCount; + size_t savedStackDepth = envPtr->currStackDepth; + size_t savedExpandCount = envPtr->expandCount; JumpFixup nonTrapFixup; if (auxBreakPtr != NULL) { diff --git a/generic/tclCompile.h b/generic/tclCompile.h index 5f906ac..2173d6a 100644 --- a/generic/tclCompile.h +++ b/generic/tclCompile.h @@ -118,16 +118,16 @@ typedef struct ExceptionAux { * one (see [for] next-clause) then we must * not pick up the range when scanning for a * target to continue to. */ - int stackDepth; /* The stack depth at the point where the + size_t stackDepth; /* The stack depth at the point where the * exception range was created. This is used * to calculate the number of POPs required to * restore the stack to its prior state. */ - int expandTarget; /* The number of expansions expected on the + size_t expandTarget; /* The number of expansions expected on the * auxData stack at the time the loop starts; * we can't currently discard them except by * doing INST_INVOKE_EXPANDED; this is a known * problem. */ - int expandTargetDepth; /* The stack depth expected at the outermost + size_t expandTargetDepth; /* The stack depth expected at the outermost * expansion within the loop. Not meaningful * if there are no open expansions between the * looping level and the point of jump @@ -388,7 +388,7 @@ typedef struct CompileEnv { * inefficient. If set to 2, that instruction * should not be issued at all (by the generic * part of the command compiler). */ - int expandCount; /* Number of INST_EXPAND_START instructions + size_t expandCount; /* Number of INST_EXPAND_START instructions * encountered that have not yet been paired * with a corresponding * INST_INVOKE_EXPANDED. */ diff --git a/generic/tclEnsemble.c b/generic/tclEnsemble.c index 3c6af3f..634766d 100644 --- a/generic/tclEnsemble.c +++ b/generic/tclEnsemble.c @@ -3250,7 +3250,7 @@ TclAttemptCompileProc( int result; size_t i; Tcl_Token *saveTokenPtr = parsePtr->tokenPtr; - int savedStackDepth = envPtr->currStackDepth; + size_t savedStackDepth = envPtr->currStackDepth; unsigned savedCodeNext = envPtr->codeNext - envPtr->codeStart; int savedAuxDataArrayNext = envPtr->auxDataArrayNext; size_t savedExceptArrayNext = envPtr->exceptArrayNext; -- cgit v0.12 From 471418d41a9b6c90ad576b6c85ae7764d4b04326 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 31 Mar 2022 16:21:42 +0000 Subject: More progress --- generic/tclCompile.c | 30 +++++++++++++++--------------- generic/tclCompile.h | 6 +++--- generic/tclEnsemble.c | 8 ++++---- generic/tclInt.decls | 4 ++-- generic/tclIntDecls.h | 8 ++++---- generic/tclLiteral.c | 24 ++++++++++++------------ 6 files changed, 40 insertions(+), 40 deletions(-) diff --git a/generic/tclCompile.c b/generic/tclCompile.c index 1c440e3..72f5a32 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -1449,8 +1449,8 @@ TclInitCompileEnv( envPtr->mallocedCodeArray = 0; envPtr->literalArrayPtr = envPtr->staticLiteralSpace; - envPtr->literalArrayNext = 0; - envPtr->literalArrayEnd = COMPILEENV_INIT_NUM_OBJECTS; + envPtr->literalArrayNext1 = 0; + envPtr->literalArrayEnd1 = COMPILEENV_INIT_NUM_OBJECTS; envPtr->mallocedLiteralArray = 0; envPtr->exceptArrayPtr = envPtr->staticExceptArraySpace; @@ -1597,7 +1597,7 @@ TclInitCompileEnv( envPtr->clNext = NULL; envPtr->auxDataArrayPtr = envPtr->staticAuxDataArraySpace; - envPtr->auxDataArrayNext = 0; + envPtr->auxDataArrayNext1 = 0; envPtr->auxDataArrayEnd = COMPILEENV_INIT_AUX_DATA_SIZE; envPtr->mallocedAuxDataArray = 0; } @@ -1638,11 +1638,11 @@ TclFreeCompileEnv( * have transferred to it. */ - int i; + size_t i; LiteralEntry *entryPtr = envPtr->literalArrayPtr; AuxData *auxDataPtr = envPtr->auxDataArrayPtr; - for (i = 0; i < envPtr->literalArrayNext; i++) { + for (i = 0; i < envPtr->literalArrayNext1; i++) { TclReleaseLiteral((Tcl_Interp *)envPtr->iPtr, entryPtr->objPtr); entryPtr++; } @@ -1651,7 +1651,7 @@ TclFreeCompileEnv( TclVerifyGlobalLiteralTable(envPtr->iPtr); #endif /*TCL_COMPILE_DEBUG*/ - for (i = 0; i < envPtr->auxDataArrayNext; i++) { + for (i = 0; i < envPtr->auxDataArrayNext1; i++) { if (auxDataPtr->type->freeProc != NULL) { auxDataPtr->type->freeProc(auxDataPtr->clientData); } @@ -2767,9 +2767,9 @@ PreventCycle( Tcl_Obj *objPtr, CompileEnv *envPtr) { - int i; + size_t i; - for (i = 0; i < envPtr->literalArrayNext; i++) { + for (i = 0; i < envPtr->literalArrayNext1; i++) { if (objPtr == TclFetchLiteral(envPtr, i)) { /* * Prevent circular reference where the bytecode internalrep of @@ -2806,7 +2806,7 @@ TclInitByteCode( #ifdef TCL_COMPILE_DEBUG unsigned char *nextPtr; #endif - int numLitObjects = envPtr->literalArrayNext; + int numLitObjects = envPtr->literalArrayNext1; Namespace *namespacePtr; int i, isNew; Interp *iPtr; @@ -2818,9 +2818,9 @@ TclInitByteCode( iPtr = envPtr->iPtr; codeBytes = envPtr->codeNext - envPtr->codeStart; - objArrayBytes = envPtr->literalArrayNext * sizeof(Tcl_Obj *); + objArrayBytes = envPtr->literalArrayNext1 * sizeof(Tcl_Obj *); exceptArrayBytes = envPtr->exceptArrayNext * sizeof(ExceptionRange); - auxDataArrayBytes = envPtr->auxDataArrayNext * sizeof(AuxData); + auxDataArrayBytes = envPtr->auxDataArrayNext1 * sizeof(AuxData); cmdLocBytes = GetCmdLocEncodingSize(envPtr); /* @@ -2861,7 +2861,7 @@ TclInitByteCode( codePtr->numCodeBytes = codeBytes; codePtr->numLitObjects = numLitObjects; codePtr->numExceptRanges = envPtr->exceptArrayNext; - codePtr->numAuxDataItems = envPtr->auxDataArrayNext; + codePtr->numAuxDataItems = envPtr->auxDataArrayNext1; codePtr->numCmdLocBytes = cmdLocBytes; codePtr->maxExceptDepth = envPtr->maxExceptDepth; codePtr->maxStackDepth = envPtr->maxStackDepth; @@ -3733,7 +3733,7 @@ TclCreateAuxData( AuxData *auxDataPtr; /* Points to the new AuxData structure */ - index = envPtr->auxDataArrayNext; + index = envPtr->auxDataArrayNext1; if (index >= envPtr->auxDataArrayEnd) { /* * Expand the AuxData array. The currently allocated entries are @@ -3741,7 +3741,7 @@ TclCreateAuxData( * [inclusive]. */ - size_t currBytes = envPtr->auxDataArrayNext * sizeof(AuxData); + size_t currBytes = envPtr->auxDataArrayNext1 * sizeof(AuxData); size_t newElems = 2*envPtr->auxDataArrayEnd; size_t newBytes = newElems * sizeof(AuxData); @@ -3762,7 +3762,7 @@ TclCreateAuxData( } envPtr->auxDataArrayEnd = newElems; } - envPtr->auxDataArrayNext++; + envPtr->auxDataArrayNext1++; auxDataPtr = &envPtr->auxDataArrayPtr[index]; auxDataPtr->clientData = clientData; diff --git a/generic/tclCompile.h b/generic/tclCompile.h index 2173d6a..297d9cb 100644 --- a/generic/tclCompile.h +++ b/generic/tclCompile.h @@ -322,8 +322,8 @@ typedef struct CompileEnv { #endif LiteralEntry *literalArrayPtr; /* Points to start of LiteralEntry array. */ - int literalArrayNext; /* Index of next free object array entry. */ - int literalArrayEnd; /* Index just after last obj array entry. */ + size_t literalArrayNext1; /* Index of next free object array entry. */ + size_t literalArrayEnd1; /* Index just after last obj array entry. */ int mallocedLiteralArray; /* 1 if object array was expanded and objArray * points into the heap, else 0. */ ExceptionRange *exceptArrayPtr; @@ -355,7 +355,7 @@ typedef struct CompileEnv { * auxDataArrayPtr points in heap else 0. */ #endif AuxData *auxDataArrayPtr; /* Points to auxiliary data array start. */ - int auxDataArrayNext; /* Next free compile aux data array index. + size_t auxDataArrayNext1; /* 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. */ diff --git a/generic/tclEnsemble.c b/generic/tclEnsemble.c index 634766d..b941609 100644 --- a/generic/tclEnsemble.c +++ b/generic/tclEnsemble.c @@ -3252,7 +3252,7 @@ TclAttemptCompileProc( Tcl_Token *saveTokenPtr = parsePtr->tokenPtr; size_t savedStackDepth = envPtr->currStackDepth; unsigned savedCodeNext = envPtr->codeNext - envPtr->codeStart; - int savedAuxDataArrayNext = envPtr->auxDataArrayNext; + size_t savedAuxDataArrayNext = envPtr->auxDataArrayNext1; size_t savedExceptArrayNext = envPtr->exceptArrayNext; #ifdef TCL_COMPILE_DEBUG size_t savedExceptDepth = envPtr->exceptDepth; @@ -3328,12 +3328,12 @@ TclAttemptCompileProc( } envPtr->exceptArrayNext = savedExceptArrayNext; - if (savedAuxDataArrayNext != envPtr->auxDataArrayNext) { + if (savedAuxDataArrayNext != envPtr->auxDataArrayNext1) { AuxData *auxDataPtr = envPtr->auxDataArrayPtr; AuxData *auxDataEnd = auxDataPtr; auxDataPtr += savedAuxDataArrayNext; - auxDataEnd += envPtr->auxDataArrayNext; + auxDataEnd += envPtr->auxDataArrayNext1; while (auxDataPtr < auxDataEnd) { if (auxDataPtr->type->freeProc != NULL) { @@ -3341,7 +3341,7 @@ TclAttemptCompileProc( } auxDataPtr++; } - envPtr->auxDataArrayNext = savedAuxDataArrayNext; + envPtr->auxDataArrayNext1 = savedAuxDataArrayNext; } envPtr->currStackDepth = savedStackDepth; envPtr->codeNext = envPtr->codeStart + savedCodeNext; diff --git a/generic/tclInt.decls b/generic/tclInt.decls index 5d5327a..3edc7ba 100644 --- a/generic/tclInt.decls +++ b/generic/tclInt.decls @@ -264,7 +264,7 @@ declare 142 { CompileHookProc *hookProc, void *clientData) } declare 143 { - int TclAddLiteralObj(struct CompileEnv *envPtr, Tcl_Obj *objPtr, + size_t TclAddLiteralObj(struct CompileEnv *envPtr, Tcl_Obj *objPtr, LiteralEntry **litPtrPtr) } declare 144 { @@ -548,7 +548,7 @@ declare 250 { # Allow extensions for optimization declare 251 { - int TclRegisterLiteral(void *envPtr, + size_t TclRegisterLiteral(void *envPtr, const char *bytes, size_t length, int flags) } diff --git a/generic/tclIntDecls.h b/generic/tclIntDecls.h index df65e0f..b25ec44 100644 --- a/generic/tclIntDecls.h +++ b/generic/tclIntDecls.h @@ -309,7 +309,7 @@ EXTERN int TclSetByteCodeFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr, CompileHookProc *hookProc, void *clientData); /* 143 */ -EXTERN int TclAddLiteralObj(struct CompileEnv *envPtr, +EXTERN size_t TclAddLiteralObj(struct CompileEnv *envPtr, Tcl_Obj *objPtr, LiteralEntry **litPtrPtr); /* 144 */ EXTERN void TclHideLiteral(Tcl_Interp *interp, @@ -546,7 +546,7 @@ EXTERN char * TclDoubleDigits(double dv, int ndigits, int flags, EXTERN void TclSetChildCancelFlags(Tcl_Interp *interp, int flags, int force); /* 251 */ -EXTERN int TclRegisterLiteral(void *envPtr, const char *bytes, +EXTERN size_t TclRegisterLiteral(void *envPtr, const char *bytes, size_t length, int flags); /* 252 */ EXTERN Tcl_Obj * TclPtrGetVar(Tcl_Interp *interp, Tcl_Var varPtr, @@ -726,7 +726,7 @@ typedef struct TclIntStubs { void (*reserved140)(void); const char * (*tclpGetCwd) (Tcl_Interp *interp, Tcl_DString *cwdPtr); /* 141 */ int (*tclSetByteCodeFromAny) (Tcl_Interp *interp, Tcl_Obj *objPtr, CompileHookProc *hookProc, void *clientData); /* 142 */ - int (*tclAddLiteralObj) (struct CompileEnv *envPtr, Tcl_Obj *objPtr, LiteralEntry **litPtrPtr); /* 143 */ + size_t (*tclAddLiteralObj) (struct CompileEnv *envPtr, Tcl_Obj *objPtr, LiteralEntry **litPtrPtr); /* 143 */ void (*tclHideLiteral) (Tcl_Interp *interp, struct CompileEnv *envPtr, int index); /* 144 */ const struct AuxDataType * (*tclGetAuxDataType) (const char *typeName); /* 145 */ TclHandle (*tclHandleCreate) (void *ptr); /* 146 */ @@ -834,7 +834,7 @@ typedef struct TclIntStubs { int (*tclCopyChannel) (Tcl_Interp *interp, Tcl_Channel inChan, Tcl_Channel outChan, long long toRead, Tcl_Obj *cmdPtr); /* 248 */ 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 */ + size_t (*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, 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 */ diff --git a/generic/tclLiteral.c b/generic/tclLiteral.c index bfc0403..86dcdb2 100644 --- a/generic/tclLiteral.c +++ b/generic/tclLiteral.c @@ -28,7 +28,7 @@ * Function prototypes for static functions in this file: */ -static int AddLocalLiteralEntry(CompileEnv *envPtr, +static size_t AddLocalLiteralEntry(CompileEnv *envPtr, Tcl_Obj *objPtr, int localHash); static void ExpandLocalLiteralArray(CompileEnv *envPtr); static size_t HashString(const char *string, size_t length); @@ -354,7 +354,7 @@ TclFetchLiteral( size_t index) /* Index of the desired literal, as returned * by prior call to TclRegisterLiteral() */ { - if (index >= (size_t) envPtr->literalArrayNext) { + if (index >= envPtr->literalArrayNext1) { return NULL; } return envPtr->literalArrayPtr[index].objPtr; @@ -387,7 +387,7 @@ TclFetchLiteral( *---------------------------------------------------------------------- */ -int +size_t TclRegisterLiteral( void *ePtr, /* Points to the CompileEnv in whose object * array an object is found or created. */ @@ -607,7 +607,7 @@ TclHideLiteral( *---------------------------------------------------------------------- */ -int +size_t TclAddLiteralObj( CompileEnv *envPtr,/* Points to CompileEnv in whose literal array * the object is to be inserted. */ @@ -617,13 +617,13 @@ TclAddLiteralObj( * NULL. */ { LiteralEntry *lPtr; - int objIndex; + size_t objIndex; - if (envPtr->literalArrayNext >= envPtr->literalArrayEnd) { + if (envPtr->literalArrayNext1 >= envPtr->literalArrayEnd1) { ExpandLocalLiteralArray(envPtr); } - objIndex = envPtr->literalArrayNext; - envPtr->literalArrayNext++; + objIndex = envPtr->literalArrayNext1; + envPtr->literalArrayNext1++; lPtr = &envPtr->literalArrayPtr[objIndex]; lPtr->objPtr = objPtr; @@ -656,7 +656,7 @@ TclAddLiteralObj( *---------------------------------------------------------------------- */ -static int +static size_t AddLocalLiteralEntry( CompileEnv *envPtr,/* Points to CompileEnv in whose literal array * the object is to be inserted. */ @@ -665,7 +665,7 @@ AddLocalLiteralEntry( { LiteralTable *localTablePtr = &envPtr->localLitTable; LiteralEntry *localPtr; - int objIndex; + size_t objIndex; objIndex = TclAddLiteralObj(envPtr, objPtr, &localPtr); @@ -745,7 +745,7 @@ ExpandLocalLiteralArray( */ LiteralTable *localTablePtr = &envPtr->localLitTable; - size_t currElems = envPtr->literalArrayNext; + size_t currElems = envPtr->literalArrayNext1; size_t currBytes = (currElems * sizeof(LiteralEntry)); LiteralEntry *currArrayPtr = envPtr->literalArrayPtr; LiteralEntry *newArrayPtr; @@ -790,7 +790,7 @@ ExpandLocalLiteralArray( } envPtr->literalArrayPtr = newArrayPtr; - envPtr->literalArrayEnd = newSize / sizeof(LiteralEntry); + envPtr->literalArrayEnd1 = newSize / sizeof(LiteralEntry); } /* -- cgit v0.12 From c21ba3a0d2f147398eaea4649b607d9eb72ba0ad Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 31 Mar 2022 16:33:47 +0000 Subject: more progress --- generic/tclAssembly.c | 12 ++++++------ generic/tclCompile.c | 2 +- generic/tclCompile.h | 4 ++-- generic/tclDisassemble.c | 14 +++++++------- 4 files changed, 16 insertions(+), 16 deletions(-) diff --git a/generic/tclAssembly.c b/generic/tclAssembly.c index 3abd4fa..4faf679 100644 --- a/generic/tclAssembly.c +++ b/generic/tclAssembly.c @@ -1940,7 +1940,7 @@ MoveExceptionRangesToBasicBlock( envPtr->exceptArrayPtr + savedExceptArrayNext, exceptionCount * sizeof(ExceptionRange)); for (i = 0; i < exceptionCount; ++i) { - curr_bb->foreignExceptions[i].nestingLevel -= envPtr->exceptDepth; + curr_bb->foreignExceptions[i].nestingLevel1 -= envPtr->exceptDepth; } envPtr->exceptArrayNext = savedExceptArrayNext; } @@ -4125,9 +4125,9 @@ StackFreshCatches( catchIndices[catchDepth] = TclCreateExceptRange(CATCH_EXCEPTION_RANGE, envPtr); range = envPtr->exceptArrayPtr + catchIndices[catchDepth]; - range->nestingLevel = envPtr->exceptDepth + catchDepth; + range->nestingLevel1 = envPtr->exceptDepth + catchDepth; envPtr->maxExceptDepth= - TclMax(range->nestingLevel + 1, (int)envPtr->maxExceptDepth); + TclMax(range->nestingLevel1 + 1, envPtr->maxExceptDepth); range->codeOffset = bbPtr->startOffset; entryPtr = Tcl_FindHashEntry(&assemEnvPtr->labelHash, @@ -4187,11 +4187,11 @@ RestoreEmbeddedExceptionRanges( for (i = 0; i < bbPtr->foreignExceptionCount; ++i) { range = bbPtr->foreignExceptions + i; rangeIndex = TclCreateExceptRange(range->type, envPtr); - range->nestingLevel += envPtr->exceptDepth + bbPtr->catchDepth; + range->nestingLevel1 += envPtr->exceptDepth + bbPtr->catchDepth; memcpy(envPtr->exceptArrayPtr + rangeIndex, range, sizeof(ExceptionRange)); - if (range->nestingLevel >= (int)envPtr->maxExceptDepth) { - envPtr->maxExceptDepth = range->nestingLevel + 1; + if ((int)range->nestingLevel1 >= (int)envPtr->maxExceptDepth) { + envPtr->maxExceptDepth = range->nestingLevel1 + 1; } } diff --git a/generic/tclCompile.c b/generic/tclCompile.c index 72f5a32..96832a9 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -3409,7 +3409,7 @@ TclCreateExceptRange( rangePtr = &envPtr->exceptArrayPtr[index]; rangePtr->type = type; - rangePtr->nestingLevel = envPtr->exceptDepth; + rangePtr->nestingLevel1 = envPtr->exceptDepth; rangePtr->codeOffset = TCL_INDEX_NONE; rangePtr->numCodeBytes = TCL_INDEX_NONE; rangePtr->breakOffset = TCL_INDEX_NONE; diff --git a/generic/tclCompile.h b/generic/tclCompile.h index 297d9cb..50a43d6 100644 --- a/generic/tclCompile.h +++ b/generic/tclCompile.h @@ -89,7 +89,7 @@ typedef enum { typedef struct { ExceptionRangeType type; /* The kind of ExceptionRange. */ - int nestingLevel; /* Static depth of the exception range. Used + size_t nestingLevel1; /* Static depth of the exception range. Used * to find the most deeply-nested range * surrounding a PC at runtime. */ size_t codeOffset; /* Offset of the first instruction byte of the @@ -1584,7 +1584,7 @@ MODULE_SCOPE int TclPushProcCallFrame(void *clientData, #define ExceptionRangeStarts(envPtr, index) \ (((envPtr)->exceptDepth++), \ ((envPtr)->maxExceptDepth = \ - TclMax((int)(envPtr)->exceptDepth, (int)(envPtr)->maxExceptDepth)), \ + TclMax((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 cf8a154..260fdde 100644 --- a/generic/tclDisassemble.c +++ b/generic/tclDisassemble.c @@ -281,7 +281,7 @@ DisassembleByteCodeObj( codePtr, codePtr->refCount, codePtr->compileEpoch, iPtr, iPtr->compileEpoch); Tcl_AppendToObj(bufferObj, " Source ", -1); PrintSourceToObj(bufferObj, codePtr->source, - TclMin((int)codePtr->numSrcBytes, 55)); + TclMin(codePtr->numSrcBytes, 55)); GetLocationInformation(codePtr->procPtr, &fileObj, &line); if (line >= 0 && fileObj != NULL) { Tcl_AppendPrintfToObj(bufferObj, "\n File \"%s\" Line %d", @@ -358,8 +358,8 @@ DisassembleByteCodeObj( ExceptionRange *rangePtr = &codePtr->exceptArrayPtr[i]; Tcl_AppendPrintfToObj(bufferObj, - " %d: level %d, %s, pc %" TCL_Z_MODIFIER "u-%" TCL_Z_MODIFIER "u, ", - i, rangePtr->nestingLevel, + " %d: level %" TCL_Z_MODIFIER "u, %s, pc %" TCL_Z_MODIFIER "u-%" TCL_Z_MODIFIER "u, ", + i, rangePtr->nestingLevel1, (rangePtr->type==LOOP_EXCEPTION_RANGE ? "loop" : "catch"), rangePtr->codeOffset, (rangePtr->codeOffset + rangePtr->numCodeBytes - 1)); @@ -1144,15 +1144,15 @@ DisassembleByteCodeAsDicts( switch (rangePtr->type) { case LOOP_EXCEPTION_RANGE: Tcl_ListObjAppendElement(NULL, exn, Tcl_ObjPrintf( - "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, + "type %s level %" TCL_Z_MODIFIER "u from %" TCL_Z_MODIFIER "u to %" TCL_Z_MODIFIER "u break %" TCL_Z_MODIFIER "u continue %" TCL_Z_MODIFIER "u", + "loop", rangePtr->nestingLevel1, 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 %" TCL_Z_MODIFIER "u to %" TCL_Z_MODIFIER "u catch %" TCL_Z_MODIFIER "u", - "catch", rangePtr->nestingLevel, rangePtr->codeOffset, + "type %s level %" TCL_Z_MODIFIER "u from %" TCL_Z_MODIFIER "u to %" TCL_Z_MODIFIER "u catch %" TCL_Z_MODIFIER "u", + "catch", rangePtr->nestingLevel1, rangePtr->codeOffset, rangePtr->codeOffset + rangePtr->numCodeBytes - 1, rangePtr->catchOffset)); break; -- cgit v0.12 From eda63bdf06c5012fdb062d138d9ad950d77ed25b Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 31 Mar 2022 20:10:33 +0000 Subject: More progress --- generic/tclCompCmdsGR.c | 4 ++-- generic/tclCompile.c | 2 +- generic/tclCompile.h | 4 ++-- 3 files changed, 5 insertions(+), 5 deletions(-) diff --git a/generic/tclCompCmdsGR.c b/generic/tclCompCmdsGR.c index 8202fa2..73d3da9 100644 --- a/generic/tclCompCmdsGR.c +++ b/generic/tclCompCmdsGR.c @@ -181,8 +181,8 @@ TclCompileIfCmd( * determined. */ Tcl_Token *tokenPtr, *testTokenPtr; int jumpIndex = 0; /* Avoid compiler warning. */ - size_t numBytes; - int jumpFalseDist, numWords, wordIdx, j, code; + size_t numBytes, j; + int jumpFalseDist, numWords, wordIdx, code; const char *word; int realCond = 1; /* Set to 0 for static conditions: * "if 0 {..}" */ diff --git a/generic/tclCompile.c b/generic/tclCompile.c index 96832a9..3095e72 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -3831,7 +3831,7 @@ TclExpandJumpFixupArray( */ size_t currBytes = fixupArrayPtr->next * sizeof(JumpFixup); - int newElems = 2*(fixupArrayPtr->end + 1); + size_t newElems = 2*(fixupArrayPtr->end + 1); size_t newBytes = newElems * sizeof(JumpFixup); if (fixupArrayPtr->mallocedArray) { diff --git a/generic/tclCompile.h b/generic/tclCompile.h index 50a43d6..4c55065 100644 --- a/generic/tclCompile.h +++ b/generic/tclCompile.h @@ -963,8 +963,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]; -- cgit v0.12 From 798a505ffb312727e4e5b9d44891d067aeb9172e Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 31 Mar 2022 21:25:13 +0000 Subject: more tweaks --- generic/tclBasic.c | 6 +++--- generic/tclCompile.c | 29 +++++++++++++++-------------- generic/tclCompile.h | 8 ++++---- generic/tclExecute.c | 2 +- generic/tclInt.h | 2 +- generic/tclLiteral.c | 12 ++++++------ 6 files changed, 30 insertions(+), 29 deletions(-) diff --git a/generic/tclBasic.c b/generic/tclBasic.c index 7d09caf..a43bca0 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -5019,7 +5019,7 @@ TclEvalEx( * TCL_EVAL_GLOBAL was set. */ int allowExceptions = (iPtr->evalFlags & TCL_ALLOW_EXCEPTIONS); int gotParse = 0; - unsigned int i, objectsUsed = 0; + size_t i, objectsUsed = 0; /* These variables keep track of how much * state has been allocated while evaluating * the script, so that it can be freed @@ -5219,7 +5219,7 @@ TclEvalEx( */ Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( - "\n (expanding word %d)", objectsUsed)); + "\n (expanding word %" TCL_Z_MODIFIER "u)", objectsUsed)); Tcl_DecrRefCount(objv[objectsUsed]); break; } @@ -5697,7 +5697,7 @@ TclArgumentBCEnter( * housekeeping, and can escape now. */ - if (ePtr->nline != objc) { + if (ePtr->nline != (size_t)objc) { return; } diff --git a/generic/tclCompile.c b/generic/tclCompile.c index 3095e72..016981d 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -692,9 +692,9 @@ static void StartExpanding(CompileEnv *envPtr); * TIP #280: Helper for building the per-word line information of all compiled * commands. */ -static void EnterCmdWordData(ExtCmdLoc *eclPtr, int srcOffset, +static void EnterCmdWordData(ExtCmdLoc *eclPtr, size_t srcOffset, Tcl_Token *tokenPtr, const char *cmd, - int numWords, int line, int *clNext, int **lines, + size_t numWords, int line, int *clNext, int **lines, CompileEnv *envPtr); static void ReleaseCmdWordData(ExtCmdLoc *eclPtr); @@ -1449,8 +1449,8 @@ TclInitCompileEnv( envPtr->mallocedCodeArray = 0; envPtr->literalArrayPtr = envPtr->staticLiteralSpace; - envPtr->literalArrayNext1 = 0; - envPtr->literalArrayEnd1 = COMPILEENV_INIT_NUM_OBJECTS; + envPtr->literalArrayNext = 0; + envPtr->literalArrayEnd = COMPILEENV_INIT_NUM_OBJECTS; envPtr->mallocedLiteralArray = 0; envPtr->exceptArrayPtr = envPtr->staticExceptArraySpace; @@ -1544,7 +1544,7 @@ TclInitCompileEnv( pc = 1; } - if ((ctxPtr->nline <= word) || (ctxPtr->line[word] < 0)) { + if ((ctxPtr->nline <= (size_t)word) || (ctxPtr->line[word] < 0)) { /* * Word is not a literal, relative counting. */ @@ -1642,7 +1642,7 @@ TclFreeCompileEnv( LiteralEntry *entryPtr = envPtr->literalArrayPtr; AuxData *auxDataPtr = envPtr->auxDataArrayPtr; - for (i = 0; i < envPtr->literalArrayNext1; i++) { + for (i = 0; i < envPtr->literalArrayNext; i++) { TclReleaseLiteral((Tcl_Interp *)envPtr->iPtr, entryPtr->objPtr); entryPtr++; } @@ -2769,7 +2769,7 @@ PreventCycle( { size_t i; - for (i = 0; i < envPtr->literalArrayNext1; i++) { + for (i = 0; i < envPtr->literalArrayNext; i++) { if (objPtr == TclFetchLiteral(envPtr, i)) { /* * Prevent circular reference where the bytecode internalrep of @@ -2806,7 +2806,7 @@ TclInitByteCode( #ifdef TCL_COMPILE_DEBUG unsigned char *nextPtr; #endif - int numLitObjects = envPtr->literalArrayNext1; + int numLitObjects = envPtr->literalArrayNext; Namespace *namespacePtr; int i, isNew; Interp *iPtr; @@ -2818,7 +2818,7 @@ TclInitByteCode( iPtr = envPtr->iPtr; codeBytes = envPtr->codeNext - envPtr->codeStart; - objArrayBytes = envPtr->literalArrayNext1 * sizeof(Tcl_Obj *); + objArrayBytes = envPtr->literalArrayNext * sizeof(Tcl_Obj *); exceptArrayBytes = envPtr->exceptArrayNext * sizeof(ExceptionRange); auxDataArrayBytes = envPtr->auxDataArrayNext1 * sizeof(AuxData); cmdLocBytes = GetCmdLocEncodingSize(envPtr); @@ -3283,10 +3283,10 @@ EnterCmdWordData( ExtCmdLoc *eclPtr, /* Points to the map environment structure in * which to enter command location * information. */ - int srcOffset, /* Offset of first char of the command. */ + size_t srcOffset, /* Offset of first char of the command. */ Tcl_Token *tokenPtr, const char *cmd, - int numWords, + size_t numWords, int line, int *clNext, int **wlines, @@ -3294,7 +3294,8 @@ EnterCmdWordData( { ECL *ePtr; const char *last; - int wordIdx, wordLine, *wwlines, *wordNext; + size_t wordIdx; + int wordLine, *wwlines, *wordNext; if (eclPtr->nuloc >= eclPtr->nloc) { /* @@ -3369,7 +3370,7 @@ TclCreateExceptRange( ExceptionAux *auxPtr; size_t index = envPtr->exceptArrayNext; - if (index >= (size_t)envPtr->exceptArrayEnd) { + if (index >= envPtr->exceptArrayEnd) { /* * Expand the ExceptionRange array. The currently allocated entries * are stored between elements 0 and (envPtr->exceptArrayNext - 1) @@ -3379,7 +3380,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); diff --git a/generic/tclCompile.h b/generic/tclCompile.h index 4c55065..700e3cf 100644 --- a/generic/tclCompile.h +++ b/generic/tclCompile.h @@ -182,7 +182,7 @@ typedef struct { typedef struct { size_t srcOffset; /* Command location to find the entry. */ - int nline; /* Number of words in the command */ + size_t nline; /* Number of words in the command */ int *line; /* Line information for all words in the * command. */ int **next; /* Transient information used by the compiler @@ -322,8 +322,8 @@ typedef struct CompileEnv { #endif LiteralEntry *literalArrayPtr; /* Points to start of LiteralEntry array. */ - size_t literalArrayNext1; /* Index of next free object array entry. */ - size_t literalArrayEnd1; /* Index just after last obj array entry. */ + size_t literalArrayNext; /* Index of next free object array entry. */ + size_t literalArrayEnd; /* Index just after last obj array entry. */ int mallocedLiteralArray; /* 1 if object array was expanded and objArray * points into the heap, else 0. */ ExceptionRange *exceptArrayPtr; @@ -333,7 +333,7 @@ typedef struct CompileEnv { * exceptArrayNext is the number of ranges and * (exceptArrayNext-1) is the index of the * current range's array entry. */ - int exceptArrayEnd; /* Index after the last ExceptionRange array + size_t exceptArrayEnd; /* Index after the last ExceptionRange array * entry. */ #if TCL_MAJOR_VERSION < 9 int mallocedExceptArray; diff --git a/generic/tclExecute.c b/generic/tclExecute.c index d920f2d..ab20c3e 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -1680,7 +1680,7 @@ TclCompileObj( } } - if (word < ctxCopyPtr->nline) { + if ((size_t)word < ctxCopyPtr->nline) { /* * Note: We do not care if the line[word] is -1. This is a * difference and requires a recompile (location changed from diff --git a/generic/tclInt.h b/generic/tclInt.h index 5e8980a..a7e9823 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -1208,7 +1208,7 @@ typedef struct CmdFrame { int level; /* Number of frames in stack, prevent O(n) * scan of list. */ int *line; /* Lines the words of the command start on. */ - int nline; + size_t nline; CallFrame *framePtr; /* Procedure activation record, may be * NULL. */ struct CmdFrame *nextPtr; /* Link to calling frame. */ diff --git a/generic/tclLiteral.c b/generic/tclLiteral.c index 86dcdb2..dfb92cb 100644 --- a/generic/tclLiteral.c +++ b/generic/tclLiteral.c @@ -354,7 +354,7 @@ TclFetchLiteral( size_t index) /* Index of the desired literal, as returned * by prior call to TclRegisterLiteral() */ { - if (index >= envPtr->literalArrayNext1) { + if (index >= envPtr->literalArrayNext) { return NULL; } return envPtr->literalArrayPtr[index].objPtr; @@ -619,11 +619,11 @@ TclAddLiteralObj( LiteralEntry *lPtr; size_t objIndex; - if (envPtr->literalArrayNext1 >= envPtr->literalArrayEnd1) { + if (envPtr->literalArrayNext >= envPtr->literalArrayEnd) { ExpandLocalLiteralArray(envPtr); } - objIndex = envPtr->literalArrayNext1; - envPtr->literalArrayNext1++; + objIndex = envPtr->literalArrayNext; + envPtr->literalArrayNext++; lPtr = &envPtr->literalArrayPtr[objIndex]; lPtr->objPtr = objPtr; @@ -745,7 +745,7 @@ ExpandLocalLiteralArray( */ LiteralTable *localTablePtr = &envPtr->localLitTable; - size_t currElems = envPtr->literalArrayNext1; + size_t currElems = envPtr->literalArrayNext; size_t currBytes = (currElems * sizeof(LiteralEntry)); LiteralEntry *currArrayPtr = envPtr->literalArrayPtr; LiteralEntry *newArrayPtr; @@ -790,7 +790,7 @@ ExpandLocalLiteralArray( } envPtr->literalArrayPtr = newArrayPtr; - envPtr->literalArrayEnd1 = newSize / sizeof(LiteralEntry); + envPtr->literalArrayEnd = newSize / sizeof(LiteralEntry); } /* -- cgit v0.12 From 73922cbaaa2876287ba74baabdabb84ae81a3b5f Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 31 Mar 2022 21:45:51 +0000 Subject: Make "word" in ForIterData size_t ; --- generic/tclInt.h | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/generic/tclInt.h b/generic/tclInt.h index a7e9823..4714c6f 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -2803,7 +2803,7 @@ typedef struct ForIterData { Tcl_Obj *body; /* Loop body. */ Tcl_Obj *next; /* Loop step script, NULL for 'while'. */ const char *msg; /* Error message part. */ - int word; /* Index of the body script in the command */ + size_t word; /* Index of the body script in the command */ } ForIterData; /* TIP #357 - Structure doing the bookkeeping of handles for Tcl_LoadFile -- cgit v0.12 From 4c82bda7741adb7962582755a619a9768f0ee8fa Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 1 Apr 2022 07:50:01 +0000 Subject: More protections for invalid argc values --- generic/tclMain.c | 16 +++++++++------- 1 file changed, 9 insertions(+), 7 deletions(-) diff --git a/generic/tclMain.c b/generic/tclMain.c index 6c545d1..7bc9516 100644 --- a/generic/tclMain.c +++ b/generic/tclMain.c @@ -288,7 +288,7 @@ Tcl_MainEx( * but before starting to execute commands. */ Tcl_Interp *interp) { - int i=0; /* argv[i] index */ + size_t i=0; /* argv[i] index */ Tcl_Obj *path, *resultPtr, *argvPtr, *appName; const char *encodingName = NULL; int code, exitCode = 0; @@ -297,7 +297,7 @@ Tcl_MainEx( InteractiveState is; TclpSetInitialEncodings(); - if (0 < argc) { + if (argc + 1 > 1) { --argc; /* consume argv[0] */ ++i; } @@ -326,7 +326,7 @@ Tcl_MainEx( */ /* mind argc is being adjusted as we proceed */ - if ((argc >= 3) && (0 == _tcscmp(TEXT("-encoding"), argv[1])) + if ((argc >= 3) && argv[1] && argv[2] && argv[3] && (0 == _tcscmp(TEXT("-encoding"), argv[1])) && ('-' != argv[3][0])) { Tcl_Obj *value = NewNativeObj(argv[2]); Tcl_SetStartupScript(NewNativeObj(argv[3]), @@ -334,7 +334,7 @@ Tcl_MainEx( Tcl_DecrRefCount(value); argc -= 3; i += 3; - } else if ((argc >= 1) && ('-' != argv[1][0])) { + } else if ((argc >= 1) && argv[1] && ('-' != argv[1][0])) { Tcl_SetStartupScript(NewNativeObj(argv[1]), NULL); argc--; i++; @@ -342,17 +342,19 @@ Tcl_MainEx( } path = Tcl_GetStartupScript(&encodingName); - if (path == NULL) { + if (path != NULL) { + appName = path; + } else if (argv[0]) { appName = NewNativeObj(argv[0]); } else { - appName = path; + appName = Tcl_NewStringObj("tclsh", -1); } Tcl_SetVar2Ex(interp, "argv0", NULL, appName, TCL_GLOBAL_ONLY); Tcl_SetVar2Ex(interp, "argc", NULL, Tcl_NewWideIntObj(argc), TCL_GLOBAL_ONLY); argvPtr = Tcl_NewListObj(0, NULL); - while (argc--) { + while (argc-- && argv[i]) { Tcl_ListObjAppendElement(NULL, argvPtr, NewNativeObj(argv[i++])); } Tcl_SetVar2Ex(interp, "argv", NULL, argvPtr, TCL_GLOBAL_ONLY); -- cgit v0.12 From d0fec7532c33f0b3da8057e2e0fda10524f22905 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 1 Apr 2022 10:29:45 +0000 Subject: Add UTF-16 versions of Tcl_GetCharLength/Tcl_GetRange/Tcl_GetUniChar to the stub table. Should have been part of TIP #542. Needed for Tk's "glyph_indexing_2" branch --- generic/tcl.decls | 15 ++++-- generic/tclDecls.h | 49 ++++++++++++++------ generic/tclStringObj.c | 121 ++++++++++++++++++++++++++++++++++++++++++++++++- generic/tclStubInit.c | 10 ++-- generic/tclUtf.c | 3 +- 5 files changed, 172 insertions(+), 26 deletions(-) diff --git a/generic/tcl.decls b/generic/tcl.decls index b943edd..d4f1c59 100644 --- a/generic/tcl.decls +++ b/generic/tcl.decls @@ -1396,17 +1396,17 @@ 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) + int TclGetUniChar(Tcl_Obj *objPtr, size_t index) } # Removed in 9.0, replaced by macro. #declare 382 { # Tcl_UniChar *Tcl_GetUnicode(Tcl_Obj *objPtr) #} declare 383 { - Tcl_Obj *Tcl_GetRange(Tcl_Obj *objPtr, size_t first, size_t last) + Tcl_Obj *TclGetRange(Tcl_Obj *objPtr, size_t first, size_t last) } # Removed in 9.0 #declare 384 { @@ -2519,9 +2519,18 @@ declare 668 { 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) } +declare 672 { + Tcl_Obj *Tcl_GetRange(Tcl_Obj *objPtr, size_t first, size_t last) +} +declare 673 { + int Tcl_GetUniChar(Tcl_Obj *objPtr, size_t index) +} # ----- BASELINE -- FOR -- 8.7.0 ----- # diff --git a/generic/tclDecls.h b/generic/tclDecls.h index 3e2b8cb..1345c6c 100644 --- a/generic/tclDecls.h +++ b/generic/tclDecls.h @@ -996,12 +996,12 @@ 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); +EXTERN int TclGetUniChar(Tcl_Obj *objPtr, size_t index); /* Slot 382 is reserved */ /* 383 */ -EXTERN Tcl_Obj * Tcl_GetRange(Tcl_Obj *objPtr, size_t first, +EXTERN Tcl_Obj * TclGetRange(Tcl_Obj *objPtr, size_t first, size_t last); /* Slot 384 is reserved */ /* 385 */ @@ -1776,9 +1776,15 @@ EXTERN int Tcl_AsyncMarkFromSignal(Tcl_AsyncHandler async, EXTERN size_t Tcl_UniCharLen(const int *uniStr); /* 669 */ EXTERN size_t Tcl_NumUtfChars(const char *src, size_t length); -/* Slot 670 is reserved */ +/* 670 */ +EXTERN size_t Tcl_GetCharLength(Tcl_Obj *objPtr); /* 671 */ EXTERN const char * Tcl_UtfAtIndex(const char *src, size_t index); +/* 672 */ +EXTERN Tcl_Obj * Tcl_GetRange(Tcl_Obj *objPtr, size_t first, + size_t last); +/* 673 */ +EXTERN int Tcl_GetUniChar(Tcl_Obj *objPtr, size_t index); typedef struct { const struct TclPlatStubs *tclPlatStubs; @@ -2170,10 +2176,10 @@ 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 */ - int (*tcl_GetUniChar) (Tcl_Obj *objPtr, size_t index); /* 381 */ + size_t (*tclGetCharLength) (Tcl_Obj *objPtr); /* 380 */ + int (*tclGetUniChar) (Tcl_Obj *objPtr, size_t index); /* 381 */ void (*reserved382)(void); - Tcl_Obj * (*tcl_GetRange) (Tcl_Obj *objPtr, size_t first, size_t last); /* 383 */ + Tcl_Obj * (*tclGetRange) (Tcl_Obj *objPtr, size_t first, size_t last); /* 383 */ void (*reserved384)(void); int (*tcl_RegExpMatchObj) (Tcl_Interp *interp, Tcl_Obj *textObj, Tcl_Obj *patternObj); /* 385 */ void (*tcl_SetNotifier) (const Tcl_NotifierProcs *notifierProcPtr); /* 386 */ @@ -2460,8 +2466,10 @@ typedef struct TclStubs { void (*reserved667)(void); size_t (*tcl_UniCharLen) (const int *uniStr); /* 668 */ size_t (*tcl_NumUtfChars) (const char *src, size_t length); /* 669 */ - void (*reserved670)(void); + size_t (*tcl_GetCharLength) (Tcl_Obj *objPtr); /* 670 */ const char * (*tcl_UtfAtIndex) (const char *src, size_t index); /* 671 */ + Tcl_Obj * (*tcl_GetRange) (Tcl_Obj *objPtr, size_t first, size_t last); /* 672 */ + int (*tcl_GetUniChar) (Tcl_Obj *objPtr, size_t index); /* 673 */ } TclStubs; extern const TclStubs *tclStubsPtr; @@ -3184,13 +3192,13 @@ extern const TclStubs *tclStubsPtr; (tclStubsPtr->tcl_NewUnicodeObj) /* 378 */ #define Tcl_SetUnicodeObj \ (tclStubsPtr->tcl_SetUnicodeObj) /* 379 */ -#define Tcl_GetCharLength \ - (tclStubsPtr->tcl_GetCharLength) /* 380 */ -#define Tcl_GetUniChar \ - (tclStubsPtr->tcl_GetUniChar) /* 381 */ +#define TclGetCharLength \ + (tclStubsPtr->tclGetCharLength) /* 380 */ +#define TclGetUniChar \ + (tclStubsPtr->tclGetUniChar) /* 381 */ /* Slot 382 is reserved */ -#define Tcl_GetRange \ - (tclStubsPtr->tcl_GetRange) /* 383 */ +#define TclGetRange \ + (tclStubsPtr->tclGetRange) /* 383 */ /* Slot 384 is reserved */ #define Tcl_RegExpMatchObj \ (tclStubsPtr->tcl_RegExpMatchObj) /* 385 */ @@ -3746,9 +3754,14 @@ extern const TclStubs *tclStubsPtr; (tclStubsPtr->tcl_UniCharLen) /* 668 */ #define Tcl_NumUtfChars \ (tclStubsPtr->tcl_NumUtfChars) /* 669 */ -/* Slot 670 is reserved */ +#define Tcl_GetCharLength \ + (tclStubsPtr->tcl_GetCharLength) /* 670 */ #define Tcl_UtfAtIndex \ (tclStubsPtr->tcl_UtfAtIndex) /* 671 */ +#define Tcl_GetRange \ + (tclStubsPtr->tcl_GetRange) /* 672 */ +#define Tcl_GetUniChar \ + (tclStubsPtr->tcl_GetUniChar) /* 673 */ #endif /* defined(USE_TCL_STUBS) */ @@ -3953,8 +3966,14 @@ extern const TclStubs *tclStubsPtr; #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 +# undef Tcl_GetRange +# define Tcl_GetRange TclGetRange +# undef Tcl_GetUniChar +# define Tcl_GetUniChar TclGetUniChar #endif #endif #if defined(USE_TCL_STUBS) diff --git a/generic/tclStringObj.c b/generic/tclStringObj.c index da3f8ee..107640b 100644 --- a/generic/tclStringObj.c +++ b/generic/tclStringObj.c @@ -446,6 +446,44 @@ Tcl_GetCharLength( 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 { + Tcl_GetString(objPtr); + numChars = TclNumUtfChars(objPtr->bytes, objPtr->length); + } + + return numChars; +} + + /* *---------------------------------------------------------------------- * @@ -574,6 +612,40 @@ Tcl_GetUniChar( #endif return ch; } + +int +TclGetUniChar( + Tcl_Obj *objPtr, /* The object to get the Unicode charater + * from. */ + size_t index) /* Get the index'th Unicode character. */ +{ + int ch = 0; + + /* + * Optimize the case where we're really dealing with a bytearray object + * we don't need to convert to a string to perform the indexing operation. + */ + + if (TclIsPureByteArray(objPtr)) { + size_t length = 0; + unsigned char *bytes = Tcl_GetByteArrayFromObj(objPtr, &length); + if (index >= length) { + return -1; + } + + return bytes[index]; + } + + size_t numChars = TclNumUtfChars(objPtr->bytes, objPtr->length); + + if (index >= numChars) { + return -1; + } + const char *begin = TclUtfAtIndex(objPtr->bytes, index); +#undef Tcl_UtfToUniChar + Tcl_UtfToUniChar(begin, &ch); + return ch; +} /* *---------------------------------------------------------------------- @@ -751,6 +823,51 @@ Tcl_GetRange( #endif return Tcl_NewUnicodeObj(stringPtr->unicode + first, last - first + 1); } + +Tcl_Obj * +TclGetRange( + Tcl_Obj *objPtr, /* The Tcl object to find the range of. */ + size_t first, /* First index of the range. */ + size_t last) /* Last index of the range. */ +{ + Tcl_Obj *newObjPtr; /* The Tcl object to find the range of. */ + size_t length = 0; + + if (first == TCL_INDEX_NONE) { + first = TCL_INDEX_START; + } + + /* + * Optimize the case where we're really dealing with a bytearray object + * we don't need to convert to a string to perform the substring operation. + */ + + if (TclIsPureByteArray(objPtr)) { + unsigned char *bytes = Tcl_GetByteArrayFromObj(objPtr, &length); + + if (last >= length) { + last = length - 1; + } + if (last + 1 < first + 1) { + TclNewObj(newObjPtr); + return newObjPtr; + } + return Tcl_NewByteArrayObj(bytes + first, last - first + 1); + } + + size_t numChars = TclNumUtfChars(objPtr->bytes, objPtr->length); + + if (last >= numChars) { + last = numChars - 1; + } + if (last + 1 < first + 1) { + TclNewObj(newObjPtr); + return newObjPtr; + } + const char *begin = TclUtfAtIndex(objPtr->bytes, first); + const char *end = TclUtfAtIndex(objPtr->bytes, last + 1); + return Tcl_NewStringObj(begin, end - begin); +} /* *---------------------------------------------------------------------- @@ -1206,7 +1323,7 @@ Tcl_AppendToObj( /* *---------------------------------------------------------------------- * - * TclAppendUnicodeToObj -- + * Tcl_AppendUnicodeToObj -- * * This function appends a Unicode string to an object in the most * efficient manner possible. Length must be >= 0. @@ -1230,7 +1347,7 @@ TclAppendUnicodeToObj( String *stringPtr; if (Tcl_IsShared(objPtr)) { - Tcl_Panic("%s called with shared object", "TclAppendUnicodeToObj"); + Tcl_Panic("%s called with shared object", "Tcl_AppendUnicodeToObj"); } if (length == 0) { diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c index 59036ec..704c51a 100644 --- a/generic/tclStubInit.c +++ b/generic/tclStubInit.c @@ -1073,10 +1073,10 @@ const TclStubs tclStubs = { Tcl_RegExpGetInfo, /* 377 */ Tcl_NewUnicodeObj, /* 378 */ Tcl_SetUnicodeObj, /* 379 */ - Tcl_GetCharLength, /* 380 */ - Tcl_GetUniChar, /* 381 */ + TclGetCharLength, /* 380 */ + TclGetUniChar, /* 381 */ 0, /* 382 */ - Tcl_GetRange, /* 383 */ + TclGetRange, /* 383 */ 0, /* 384 */ Tcl_RegExpMatchObj, /* 385 */ Tcl_SetNotifier, /* 386 */ @@ -1363,8 +1363,10 @@ const TclStubs tclStubs = { 0, /* 667 */ Tcl_UniCharLen, /* 668 */ Tcl_NumUtfChars, /* 669 */ - 0, /* 670 */ + Tcl_GetCharLength, /* 670 */ Tcl_UtfAtIndex, /* 671 */ + Tcl_GetRange, /* 672 */ + Tcl_GetUniChar, /* 673 */ }; /* !END!: Do not edit above this line. */ diff --git a/generic/tclUtf.c b/generic/tclUtf.c index 09e464f..6f43dc4 100644 --- a/generic/tclUtf.c +++ b/generic/tclUtf.c @@ -799,7 +799,6 @@ Tcl_UtfCharComplete( *--------------------------------------------------------------------------- */ -#undef Tcl_NumUtfChars size_t Tcl_NumUtfChars( const char *src, /* The UTF-8 string to measure. */ @@ -1220,7 +1219,6 @@ Tcl_UniCharAtIndex( *--------------------------------------------------------------------------- */ -#undef Tcl_UtfAtIndex const char * Tcl_UtfAtIndex( const char *src, /* The UTF-8 string. */ @@ -1230,6 +1228,7 @@ Tcl_UtfAtIndex( if (index != TCL_INDEX_NONE) { while (index--) { + /* Make use of the #undef Tcl_UtfToUniChar above, which already handles UCS4. */ src += Tcl_UtfToUniChar(src, &ch); } } -- cgit v0.12 From 18ce686ba411d43ed7e95ce8d497e04c38d1414e Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 4 Apr 2022 14:09:51 +0000 Subject: In tclCkalloc.c, count malloc/free's using size_t in stead of unsigned int. --- generic/tclCkalloc.c | 38 +++++++++++++++++++------------------- 1 file changed, 19 insertions(+), 19 deletions(-) diff --git a/generic/tclCkalloc.c b/generic/tclCkalloc.c index 6a6ed31..9ecce13 100644 --- a/generic/tclCkalloc.c +++ b/generic/tclCkalloc.c @@ -71,7 +71,7 @@ struct mem_header { static struct mem_header *allocHead = NULL; /* List of allocated structures */ -#define GUARD_VALUE 0141 +#define GUARD_VALUE 0x61 /* * The following macro determines the amount of guard space *above* each chunk @@ -89,14 +89,14 @@ static struct mem_header *allocHead = NULL; /* List of allocated structures */ #define BODY_OFFSET \ ((size_t) (&((struct mem_header *) 0)->body)) -static unsigned int total_mallocs = 0; -static unsigned int total_frees = 0; +static size_t total_mallocs = 0; +static size_t total_frees = 0; static size_t current_bytes_malloced = 0; static size_t maximum_bytes_malloced = 0; static size_t current_malloc_packets = 0; static size_t maximum_malloc_packets = 0; -static unsigned int break_on_malloc = 0; -static unsigned int trace_on_at_malloc = 0; +static size_t break_on_malloc = 0; +static size_t trace_on_at_malloc = 0; static int alloc_tracing = FALSE; static int init_malloced_bodies = TRUE; #ifdef MEM_VALIDATE @@ -186,8 +186,8 @@ TclDumpMemoryInfo( return 0; } sprintf(buf, - "total mallocs %10u\n" - "total frees %10u\n" + "total mallocs %10" TCL_Z_MODIFIER "u\n" + "total frees %10" TCL_Z_MODIFIER "u\n" "current packets allocated %10" TCL_Z_MODIFIER "u\n" "current bytes allocated %10" TCL_Z_MODIFIER "u\n" "maximum packets allocated %10" TCL_Z_MODIFIER "u\n" @@ -406,7 +406,7 @@ Tcl_DbCkalloc( } /* Don't let size argument to TclpAlloc overflow */ - if (size <= UINT_MAX - offsetof(struct mem_header, body) - 1U - HIGH_GUARD_SIZE) { + if (size <= (size_t)-2 - offsetof(struct mem_header, body) - HIGH_GUARD_SIZE) { result = (struct mem_header *) TclpAlloc(size + offsetof(struct mem_header, body) + 1U + HIGH_GUARD_SIZE); } @@ -451,7 +451,7 @@ Tcl_DbCkalloc( total_mallocs++; if (trace_on_at_malloc && (total_mallocs >= trace_on_at_malloc)) { (void) fflush(stdout); - fprintf(stderr, "reached malloc trace enable point (%u)\n", + fprintf(stderr, "reached malloc trace enable point (%" TCL_Z_MODIFIER "u)\n", total_mallocs); fflush(stderr); alloc_tracing = TRUE; @@ -466,7 +466,7 @@ Tcl_DbCkalloc( if (break_on_malloc && (total_mallocs >= break_on_malloc)) { break_on_malloc = 0; (void) fflush(stdout); - Tcl_Panic("reached malloc break limit (%u)", total_mallocs); + Tcl_Panic("reached malloc break limit (%" TCL_Z_MODIFIER "u)", total_mallocs); } current_malloc_packets++; @@ -496,7 +496,7 @@ Tcl_AttemptDbCkalloc( } /* Don't let size argument to TclpAlloc overflow */ - if (size <= UINT_MAX - offsetof(struct mem_header, body) - 1U - HIGH_GUARD_SIZE) { + if (size <= (size_t)-2 - offsetof(struct mem_header, body) - HIGH_GUARD_SIZE) { result = (struct mem_header *) TclpAlloc(size + offsetof(struct mem_header, body) + 1U + HIGH_GUARD_SIZE); } @@ -540,7 +540,7 @@ Tcl_AttemptDbCkalloc( total_mallocs++; if (trace_on_at_malloc && (total_mallocs >= trace_on_at_malloc)) { (void) fflush(stdout); - fprintf(stderr, "reached malloc trace enable point (%d)\n", + fprintf(stderr, "reached malloc trace enable point (%" TCL_Z_MODIFIER "u)\n", total_mallocs); fflush(stderr); alloc_tracing = TRUE; @@ -555,7 +555,7 @@ Tcl_AttemptDbCkalloc( if (break_on_malloc && (total_mallocs >= break_on_malloc)) { break_on_malloc = 0; (void) fflush(stdout); - Tcl_Panic("reached malloc break limit (%d)", total_mallocs); + Tcl_Panic("reached malloc break limit (%" TCL_Z_MODIFIER "u)", total_mallocs); } current_malloc_packets++; @@ -845,19 +845,19 @@ MemoryCmd( return TCL_OK; } if (strcmp(TclGetString(objv[1]),"break_on_malloc") == 0) { - int value; + Tcl_WideInt value; if (objc != 3) { goto argError; } - if (Tcl_GetIntFromObj(interp, objv[2], &value) != TCL_OK) { + if (Tcl_GetWideIntFromObj(interp, objv[2], &value) != TCL_OK) { return TCL_ERROR; } - break_on_malloc = (unsigned int) value; + break_on_malloc = value; return TCL_OK; } if (strcmp(TclGetString(objv[1]),"info") == 0) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "%-25s %10u\n%-25s %10u\n%-25s %10" TCL_Z_MODIFIER "u\n%-25s %10" TCL_Z_MODIFIER "u\n%-25s %10" TCL_Z_MODIFIER "u\n%-25s %10" TCL_Z_MODIFIER "u\n", + "%-25s %10" TCL_Z_MODIFIER "u\n%-25s %10" TCL_Z_MODIFIER "u\n%-25s %10" TCL_Z_MODIFIER "u\n%-25s %10" TCL_Z_MODIFIER "u\n%-25s %10" TCL_Z_MODIFIER "u\n%-25s %10" TCL_Z_MODIFIER "u\n", "total mallocs", total_mallocs, "total frees", total_frees, "current packets allocated", current_malloc_packets, "current bytes allocated", current_bytes_malloced, @@ -930,11 +930,11 @@ MemoryCmd( } if (strcmp(TclGetString(objv[1]),"trace_on_at_malloc") == 0) { - int value; + Tcl_WideInt value; if (objc != 3) { goto argError; } - if (Tcl_GetIntFromObj(interp, objv[2], &value) != TCL_OK) { + if (Tcl_GetWideIntFromObj(interp, objv[2], &value) != TCL_OK) { return TCL_ERROR; } trace_on_at_malloc = value; -- cgit v0.12 From 27aba5645ca809827fd1a655677fc1080f8dcb03 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 11 Apr 2022 15:13:12 +0000 Subject: CC_NONE -> CC_NULL. Otherwise, there's a conflict with Windows headers --- generic/regc_locale.c | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/generic/regc_locale.c b/generic/regc_locale.c index 4b1a1e8..d22fd50 100644 --- a/generic/regc_locale.c +++ b/generic/regc_locale.c @@ -1013,7 +1013,7 @@ cclass( }; enum classes { - CC_NONE = -1, + CC_NULL = -1, CC_ALNUM, CC_ALPHA, CC_ASCII, CC_BLANK, CC_CNTRL, CC_DIGIT, CC_GRAPH, CC_LOWER, CC_PRINT, CC_PUNCT, CC_SPACE, CC_UPPER, CC_XDIGIT } index; @@ -1031,7 +1031,7 @@ cclass( * Map the name to the corresponding enumerated value. */ - index = CC_NONE; + index = CC_NULL; for (namePtr=classNames,i=0 ; *namePtr!=NULL ; namePtr++,i++) { if ((strlen(*namePtr) == len) && (strncmp(*namePtr, np, len) == 0)) { index = (enum classes)i; @@ -1053,7 +1053,7 @@ cclass( */ switch(index) { - case CC_NONE: + case CC_NULL: ERR(REG_ECTYPE); return NULL; case CC_ALNUM: -- cgit v0.12 From 612617685a38e7bd7f80dce2f0f2e7b69b4db48e Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 12 Apr 2022 10:54:37 +0000 Subject: Fix breakage in tclInterp.c --- generic/tclInterp.c | 23 ++++++++++------------- 1 file changed, 10 insertions(+), 13 deletions(-) diff --git a/generic/tclInterp.c b/generic/tclInterp.c index ccb0aae..cfa6b7c 100644 --- a/generic/tclInterp.c +++ b/generic/tclInterp.c @@ -617,7 +617,6 @@ NRInterpCmd( Tcl_Obj *const objv[]) /* Argument objects. */ { Tcl_Interp *childInterp; - int index; static const char *const options[] = { "alias", "aliases", "bgerror", "cancel", "children", "create", "debug", "delete", @@ -649,20 +648,20 @@ NRInterpCmd( OPT_SLAVES, #endif OPT_TARGET, OPT_TRANSFER - } index1; + } index; if (objc < 2) { Tcl_WrongNumArgs(interp, 1, objv, "cmd ?arg ...?"); return TCL_ERROR; } if (Tcl_GetIndexFromObj(NULL, objv[1], options, - "option", 0, &index1) != TCL_OK) { + "option", 0, &index) != TCL_OK) { /* Don't report the "slaves" option as possibility */ Tcl_GetIndexFromObj(interp, objv[1], optionsNoSlaves, - "option", 0, &index1); + "option", 0, &index); return TCL_ERROR; } - switch (index1) { + switch (index) { case OPT_ALIAS: { Tcl_Interp *parentInterp; @@ -717,12 +716,11 @@ NRInterpCmd( }; enum optionCancelEnum { OPT_UNWIND, OPT_LAST - }; + } idx; flags = 0; for (i = 2; i < objc; i++) { - enum optionCancelEnum idx; if (TclGetString(objv[i])[0] != '-') { break; } @@ -950,7 +948,7 @@ NRInterpCmd( }; enum hiddenOption { OPT_GLOBAL, OPT_NAMESPACE, OPT_LAST - }; + } idx; namespaceName = NULL; for (i = 3; i < objc; i++) { @@ -958,12 +956,12 @@ NRInterpCmd( break; } if (Tcl_GetIndexFromObj(interp, objv[i], hiddenOptions, "option", - 0, &index) != TCL_OK) { + 0, &idx) != TCL_OK) { return TCL_ERROR; } - if (index == OPT_GLOBAL) { + if (idx == OPT_GLOBAL) { namespaceName = "::"; - } else if (index == OPT_NAMESPACE) { + } else if (idx == OPT_NAMESPACE) { if (++i == objc) { /* There must be more arguments. */ break; } else { @@ -4677,9 +4675,8 @@ ChildTimeLimitCmd( }; enum Options { OPT_CMD, OPT_GRAN, OPT_MILLI, OPT_SEC - }; + } index; Interp *iPtr = (Interp *) interp; - int index; ScriptLimitCallbackKey key; ScriptLimitCallback *limitCBPtr; Tcl_HashEntry *hPtr; -- cgit v0.12 From 514ebbd809f0096609a5971c1861a99460e77e73 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 12 Apr 2022 13:53:03 +0000 Subject: Code formatting --- generic/regc_locale.c | 2 +- generic/tclAssembly.c | 2 +- generic/tclCompExpr.c | 2 +- generic/tclExecute.c | 2 +- generic/tclStrToD.c | 2 +- generic/tclTestObj.c | 2 +- unix/tclLoadDyld.c | 2 +- 7 files changed, 7 insertions(+), 7 deletions(-) diff --git a/generic/regc_locale.c b/generic/regc_locale.c index d22fd50..c90014f 100644 --- a/generic/regc_locale.c +++ b/generic/regc_locale.c @@ -1052,7 +1052,7 @@ cclass( * Now compute the character class contents. */ - switch(index) { + switch (index) { case CC_NULL: ERR(REG_ECTYPE); return NULL; diff --git a/generic/tclAssembly.c b/generic/tclAssembly.c index 975906c..1ffcf07 100644 --- a/generic/tclAssembly.c +++ b/generic/tclAssembly.c @@ -1819,7 +1819,7 @@ CompileEmbeddedScript( envPtr->maxStackDepth = 0; StartBasicBlock(assemEnvPtr, BB_FALLTHRU, NULL); - switch(instPtr->tclInstCode) { + switch (instPtr->tclInstCode) { case INST_EVAL_STK: TclCompileScript(interp, tokenPtr->start, tokenPtr->size, envPtr); break; diff --git a/generic/tclCompExpr.c b/generic/tclCompExpr.c index d58dd24..87d9a71 100644 --- a/generic/tclCompExpr.c +++ b/generic/tclCompExpr.c @@ -1730,7 +1730,7 @@ ConvertTreeToTokens( scanned = ParseLexeme(start, numBytes, &lexeme, NULL); - switch(nodePtr->lexeme) { + switch (nodePtr->lexeme) { case OPEN_PAREN: case COMMA: case COLON: diff --git a/generic/tclExecute.c b/generic/tclExecute.c index d3b9dac..42e8008 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -7135,7 +7135,7 @@ TEBCresume( { /* Read the wall clock */ Tcl_WideInt wval; Tcl_Time now; - switch(TclGetUInt1AtPtr(pc+1)) { + switch (TclGetUInt1AtPtr(pc+1)) { case 0: /* clicks */ #ifdef TCL_WIDE_CLICKS wval = TclpGetWideClicks(); diff --git a/generic/tclStrToD.c b/generic/tclStrToD.c index a29ad07..15aeaf4 100644 --- a/generic/tclStrToD.c +++ b/generic/tclStrToD.c @@ -3827,7 +3827,7 @@ ShouldBankerRoundUpToNext( } r = mp_cmp_mag(&temp, S); mp_clear(&temp); - switch(r) { + switch (r) { case MP_EQ: return isodd; case MP_GT: diff --git a/generic/tclTestObj.c b/generic/tclTestObj.c index cb3fc79..c4f9e1f 100644 --- a/generic/tclTestObj.c +++ b/generic/tclTestObj.c @@ -878,7 +878,7 @@ TestlistobjCmd( 0, &cmdIndex) != TCL_OK) { return TCL_ERROR; } - switch(cmdIndex) { + switch (cmdIndex) { case LISTOBJ_SET: if ((varPtr[varIndex] != NULL) && !Tcl_IsShared(varPtr[varIndex])) { Tcl_SetListObj(varPtr[varIndex], objc-3, objv+3); diff --git a/unix/tclLoadDyld.c b/unix/tclLoadDyld.c index 24240af..c2339db 100644 --- a/unix/tclLoadDyld.c +++ b/unix/tclLoadDyld.c @@ -106,7 +106,7 @@ static const char * DyldOFIErrorMsg( int err) { - switch(err) { + switch (err) { case NSObjectFileImageSuccess: return NULL; case NSObjectFileImageFailure: -- cgit v0.12 From 05b9aa05c1439506d60f983b5dc4e37ed339f02b Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 26 Apr 2022 12:11:49 +0000 Subject: Missing macro's for Tcl_GetBytesFromObj() (TIP #568), only can handle size_t * this way --- generic/tclDecls.h | 7 ++++++- 1 file changed, 6 insertions(+), 1 deletion(-) diff --git a/generic/tclDecls.h b/generic/tclDecls.h index 559d67c..c5f89b5 100644 --- a/generic/tclDecls.h +++ b/generic/tclDecls.h @@ -3908,9 +3908,12 @@ extern const TclStubs *tclStubsPtr; #undef Tcl_GetStringFromObj #undef Tcl_GetUnicodeFromObj #undef Tcl_GetByteArrayFromObj +#undef Tcl_GetBytesFromObj #if defined(USE_TCL_STUBS) #define Tcl_GetStringFromObj(objPtr, sizePtr) \ (sizeof(*(sizePtr)) <= sizeof(int) ? tclStubsPtr->tclGetStringFromObj(objPtr, (int *)(sizePtr)) : tclStubsPtr->tcl_GetStringFromObj(objPtr, (size_t *)(sizePtr))) +#define Tcl_GetBytesFromObj(interp, objPtr, sizePtr) \ + (sizeof(*(sizePtr)) <= sizeof(int) ? tclStubsPtr->tclGetBytesFromObj(interp, objPtr, (int *)(sizePtr)) : tclStubsPtr->tcl_GetBytesFromObj(interp, objPtr, (size_t *)(sizePtr))) #define Tcl_GetByteArrayFromObj(objPtr, sizePtr) \ (sizeof(*(sizePtr)) <= sizeof(int) ? tclStubsPtr->tclGetBytesFromObj(NULL, objPtr, (int *)(sizePtr)) : tclStubsPtr->tcl_GetBytesFromObj(NULL, objPtr, (size_t *)(sizePtr))) #define Tcl_GetUnicodeFromObj(objPtr, sizePtr) \ @@ -3920,8 +3923,10 @@ extern const TclStubs *tclStubsPtr; #else #define Tcl_GetStringFromObj(objPtr, sizePtr) \ (sizeof(*(sizePtr)) <= sizeof(int) ? (TclGetStringFromObj)(objPtr, (int *)(sizePtr)) : (Tcl_GetStringFromObj)(objPtr, (size_t *)(sizePtr))) +#define Tcl_GetBytesFromObj(interp, objPtr, sizePtr) \ + (sizeof(*(sizePtr)) <= sizeof(int) ? (TclGetBytesFromObj)(interp, objPtr, (int *)(sizePtr)) : (Tcl_GetBytesFromObj)(interp, objPtr, (size_t *)(sizePtr))) #define Tcl_GetByteArrayFromObj(objPtr, sizePtr) \ - (sizeof(*(sizePtr)) <= sizeof(int) ? (TclGetBytesFromObj)(NULL, objPtr, (int *)(sizePtr)) : Tcl_GetBytesFromObj(NULL, 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))) #define Tcl_GetIndexFromObjStruct(interp, objPtr, tablePtr, offset, msg, flags, indexPtr) \ -- cgit v0.12 From 257691ef7309a95aa418da8017492f3c4c223fd6 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 26 Apr 2022 12:22:51 +0000 Subject: Tcl_GetIndexFromObjStruct -> Tcl_GetIndexFromObj. Don't use braces around (Tcl_GetBytesFromObj) --- generic/tclExecute.c | 2 +- generic/tclIO.c | 4 ++-- generic/tclStringObj.c | 6 +++--- generic/tclTimer.c | 4 ++-- generic/tclZipfs.c | 9 ++++----- generic/tclZlib.c | 18 +++++++++--------- 6 files changed, 21 insertions(+), 22 deletions(-) diff --git a/generic/tclExecute.c b/generic/tclExecute.c index 42e8008..23c3ef5 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -5113,7 +5113,7 @@ TEBCresume( TclNewObj(objResultPtr); } else if (TclIsPureByteArray(valuePtr)) { objResultPtr = Tcl_NewByteArrayObj( - (Tcl_GetBytesFromObj)(NULL, valuePtr, NULL)+index, 1); + Tcl_GetBytesFromObj(NULL, valuePtr, (size_t *)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 57e1a66..4cf6a7e 100644 --- a/generic/tclIO.c +++ b/generic/tclIO.c @@ -4573,7 +4573,7 @@ Tcl_GetsObj( if ((statePtr->encoding == NULL) && ((statePtr->inputTranslation == TCL_TRANSLATE_LF) || (statePtr->inputTranslation == TCL_TRANSLATE_CR)) - && (Tcl_GetBytesFromObj)(NULL, objPtr, NULL) != NULL) { + && Tcl_GetBytesFromObj(NULL, objPtr, (size_t *)NULL) != NULL) { return TclGetsObjBinary(chan, objPtr); } @@ -5843,7 +5843,7 @@ DoReadChars( && (statePtr->inEofChar == '\0'); if (appendFlag) { - if (binaryMode && (NULL == Tcl_GetBytesFromObj(NULL, objPtr, NULL))) { + if (binaryMode && (NULL == Tcl_GetBytesFromObj(NULL, objPtr, (size_t *)NULL))) { binaryMode = 0; } } else { diff --git a/generic/tclStringObj.c b/generic/tclStringObj.c index 107640b..c5e018f 100644 --- a/generic/tclStringObj.c +++ b/generic/tclStringObj.c @@ -1460,7 +1460,7 @@ Tcl_AppendObjToObj( */ TclAppendBytesToByteArray(objPtr, - (Tcl_GetBytesFromObj)(NULL, appendObjPtr, NULL), lengthSrc); + Tcl_GetBytesFromObj(NULL, appendObjPtr, (size_t *)NULL), lengthSrc); return; } @@ -2975,7 +2975,7 @@ TclStringRepeat( done *= 2; } TclAppendBytesToByteArray(objResultPtr, - (Tcl_GetBytesFromObj)(NULL, objResultPtr, NULL), + Tcl_GetBytesFromObj(NULL, objResultPtr, (size_t *)NULL), (count - done) * length); } else if (unichar) { /* @@ -3852,7 +3852,7 @@ TclStringReverse( if (!inPlace || Tcl_IsShared(objPtr)) { objPtr = Tcl_NewByteArrayObj(NULL, numBytes); } - ReverseBytes((Tcl_GetBytesFromObj)(NULL, objPtr, NULL), from, numBytes); + ReverseBytes(Tcl_GetBytesFromObj(NULL, objPtr, (size_t *)NULL), from, numBytes); return objPtr; } diff --git a/generic/tclTimer.c b/generic/tclTimer.c index 90301aa..0e6324c 100644 --- a/generic/tclTimer.c +++ b/generic/tclTimer.c @@ -818,8 +818,8 @@ Tcl_AfterObjCmd( */ if (Tcl_GetWideIntFromObj(NULL, objv[1], &ms) != TCL_OK) { - if (Tcl_GetIndexFromObjStruct(NULL, objv[1], afterSubCmds, - sizeof(char *), "", 0, &index) != TCL_OK) { + if (Tcl_GetIndexFromObj(NULL, objv[1], afterSubCmds, "", 0, &index) + != TCL_OK) { const char *arg = TclGetString(objv[1]); Tcl_SetObjResult(interp, Tcl_ObjPrintf( diff --git a/generic/tclZipfs.c b/generic/tclZipfs.c index 269d8bc..85b57a5 100644 --- a/generic/tclZipfs.c +++ b/generic/tclZipfs.c @@ -2409,7 +2409,7 @@ ZipFSMkKeyObjCmd( } passObj = Tcl_NewByteArrayObj(NULL, 264); - passBuf = Tcl_GetBytesFromObj(NULL, passObj, NULL); + passBuf = Tcl_GetBytesFromObj(NULL, passObj, (size_t *)NULL); while (len > 0) { int ch = pw[len - 1]; @@ -3776,8 +3776,8 @@ ZipFSListObjCmd( if (objc == 3) { int idx; - if (Tcl_GetIndexFromObjStruct(interp, objv[1], options, - sizeof(char *), "option", 0, &idx) != TCL_OK) { + if (Tcl_GetIndexFromObj(interp, objv[1], options, "option", + 0, &idx) != TCL_OK) { return TCL_ERROR; } switch (idx) { @@ -4998,8 +4998,7 @@ ZipFSMatchInDirectoryProc( Tcl_HashEntry *hPtr; Tcl_HashSearch search; Tcl_Obj *normPathPtr = Tcl_FSGetNormalizedPath(NULL, pathPtr); - int scnt, l, dirOnly = -1, prefixLen, strip = 0, mounts = 0; - int len; + int scnt, l, dirOnly = -1, prefixLen, strip = 0, mounts = 0, len; char *pat, *prefix, *path; Tcl_DString dsPref, *prefixBuf = NULL; diff --git a/generic/tclZlib.c b/generic/tclZlib.c index fa87a10..8a95fd5 100644 --- a/generic/tclZlib.c +++ b/generic/tclZlib.c @@ -496,8 +496,8 @@ GenerateHeader( if (GetValue(interp, dictObj, "type", &value) != TCL_OK) { goto error; - } else if (value != NULL && Tcl_GetIndexFromObjStruct(interp, value, types, - sizeof(char *), "type", TCL_EXACT, &headerPtr->header.text) != TCL_OK) { + } else if (value != NULL && Tcl_GetIndexFromObj(interp, value, types, + "type", TCL_EXACT, &headerPtr->header.text) != TCL_OK) { goto error; } @@ -1155,7 +1155,7 @@ Tcl_ZlibStreamSetCompressionDictionary( ZlibStreamHandle *zshPtr = (ZlibStreamHandle *) zshandle; if (compressionDictionaryObj && (NULL == Tcl_GetBytesFromObj(NULL, - compressionDictionaryObj, NULL))) { + compressionDictionaryObj, (size_t *)NULL))) { /* Missing or invalid compression dictionary */ compressionDictionaryObj = NULL; } @@ -1972,8 +1972,8 @@ ZlibCmd( Tcl_WrongNumArgs(interp, 1, objv, "command arg ?...?"); return TCL_ERROR; } - if (Tcl_GetIndexFromObjStruct(interp, objv[1], commands, - sizeof(char *), "command", 0, &command) != TCL_OK) { + if (Tcl_GetIndexFromObj(interp, objv[1], commands, "command", 0, + &command) != TCL_OK) { return TCL_ERROR; } @@ -2351,7 +2351,7 @@ ZlibStreamSubcmd( } if (compDictObj) { - if (NULL == (Tcl_GetBytesFromObj)(interp, compDictObj, NULL)) { + if (NULL == Tcl_GetBytesFromObj(interp, compDictObj, (size_t *)NULL)) { return TCL_ERROR; } } @@ -2533,7 +2533,7 @@ ZlibPushSubcmd( } } - if (compDictObj && (NULL == (Tcl_GetBytesFromObj)(interp, compDictObj, NULL))) { + if (compDictObj && (NULL == Tcl_GetBytesFromObj(interp, compDictObj, (size_t *)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, (size_t *)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_GetBytesFromObj)(NULL, cd->compDictObj, NULL); + Tcl_GetBytesFromObj(NULL, cd->compDictObj, (size_t *)NULL); } if (format == TCL_ZLIB_FORMAT_RAW) { -- cgit v0.12 -- cgit v0.12 From 3bdcb898d3c643d00352fcebe7fe7a3b79d2e9cc Mon Sep 17 00:00:00 2001 From: kjnash Date: Tue, 10 May 2022 07:48:31 +0000 Subject: Fix the bug. Standardise and document protocol upgrades. --- doc/http.n | 34 ++++++++++++++++++++++++++++ library/http/http.tcl | 57 ++++++++++++++++++++++++++++++++++++++++++++--- library/http/pkgIndex.tcl | 2 +- unix/Makefile.in | 4 ++-- win/Makefile.in | 4 ++-- 5 files changed, 93 insertions(+), 8 deletions(-) diff --git a/doc/http.n b/doc/http.n index 181b48b..a451f80 100644 --- a/doc/http.n +++ b/doc/http.n @@ -786,6 +786,40 @@ Subsequent GET and HEAD requests in a failed pipeline will also be retried. that the retry is appropriate\fR - specifically, the application must know that if the failed POST successfully modified the state of the server, a repeat POST would have no adverse effect. +.SH "PROTOCOL UPGRADES" +.PP +The HTTP/1.1 \fBConnection\fR and \fBUpgrade\fR client headers inform the server +that the client wishes to change the protocol used over the existing connection +(RFC 7230). This mechanism can be used to request a WebSocket (RFC 6455), a +higher version of the HTTP protocol (HTTP 2 or 3), or TLS encryption. If the +server accepts the upgrade request, its response code will be 101. +.PP +To request a protocol upgrade when calling \fBhttp::geturl\fR, the \fB-headers\fR +option must supply appropriate values for \fBConnection\fR and \fBUpgrade\fR, and +the \fB-command\fR option must supply a command that implements the requested +protocol and can also handle the server response if the server refuses the +protocol upgrade. For upgrade requests \fBhttp::geturl\fR ignores the value of +option \fB-keepalive\fR, and always uses the value \fB0\fR so that the upgrade +request is not made over a connection that is intended for multiple HTTP requests. +.PP +The Tcllib library \fBwebsocket\fR implements WebSockets, and makes the necessary +calls to commands in the \fBhttp\fR package. +.PP +There is currently no native Tcl client library for HTTP/2 or HTTP/3. +.PP +The \fBUpgrade\fR mechanism is not used to request TLS in web browsers, because +\fBhttp\fR and \fBhttps\fR are served over different ports. It is used by +protocols such as Internet Printing Protocol (IPP) that are built on top of +\fBhttp(s)\fR and use the same TCP port number for both secure and insecure +traffic. +.PP +In browsers, opportunistic encryption is instead implemented by the +\fBUpgrade-Insecure-Requests\fR client header. If a secure service is available, +the server response code is a 307 redirect, and the response header +\fBLocation\fR specifies the target URL. The browser must call \fBhttp::geturl\fR +again in order to fetch this URL. +See https://w3c.github.io/webappsec-upgrade-insecure-requests/ +.PP .SH EXAMPLE .PP This example creates a procedure to copy a URL to a file while printing a diff --git a/library/http/http.tcl b/library/http/http.tcl index 326d9d8..92d3a5a 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.6 +package provide http 2.9.7 namespace eval http { # Allow resourcing to not clobber existing data @@ -255,10 +255,49 @@ proc http::Finish {token {errormsg ""} {skipCB 0}} { if {[info commands ${token}EventCoroutine] ne {}} { rename ${token}EventCoroutine {} } + + # Is this an upgrade request/response? + set upgradeResponse 0 + if { [info exists state(upgradeRequest)] + && [info exists state(http)] + && $state(upgradeRequest) + && ([ncode $token] eq {101}) + } { + # An upgrade must be requested by the client. + # If 101 response, test server response headers for an upgrade. + set connectionHd {} + set upgradeHd {} + if {[dict exists $state(meta) connection]} { + set connectionHd [string tolower [dict get $state(meta) connection]] + } + if {[dict exists $state(meta) upgrade]} { + set upgradeHd [string tolower [dict get $state(meta) upgrade]] + } + if {($connectionHd eq {upgrade}) && ($upgradeHd ne {})} { + set upgradeResponse 1 + } + } + if { ($state(status) eq "timeout") || ($state(status) eq "error") || ($state(status) eq "eof") - || ([info exists state(-keepalive)] && !$state(-keepalive)) + } { + set closeQueue 1 + set connId $state(socketinfo) + set sock $state(sock) + CloseSocket $state(sock) $token + } elseif {$upgradeResponse} { + # Special handling for an upgrade request/response. + # - geturl ensures that this is not a "persistent" socket used for + # multiple HTTP requests, so a call to KeepSocket is not needed. + # - Leave socket open, so a call to CloseSocket is not needed either. + # - Remove fileevent bindings. The caller will set its own bindings. + # - THE CALLER MUST PROCESS THE UPGRADED SOCKET IN THE CALLBACK COMMAND + # PASSED TO http::geturl AS -command callback. + catch {fileevent $state(sock) readable {}} + catch {fileevent $state(sock) writable {}} + } elseif { + ([info exists state(-keepalive)] && !$state(-keepalive)) || ([info exists state(connection)] && ($state(connection) eq "close")) } { set closeQueue 1 @@ -946,6 +985,13 @@ proc http::geturl {url args} { # c11a51c482] set state(accept-types) $http(-accept) + set state(upgradeRequest) [expr { + [dict exists $state(-headers) Upgrade] + && [dict exists $state(-headers) Connection] + && ([dict get $state(-headers) Connection] eq {Upgrade}) + && ([dict get $state(-headers) Upgrade] ne {}) + }] + if {$isQuery || $isQueryChannel} { # It's a POST. # A client wishing to send a non-idempotent request SHOULD wait to send @@ -961,8 +1007,13 @@ proc http::geturl {url args} { # There is a small risk of a race against server timeout. set state(-pipeline) 0 } + } elseif {$state(upgradeRequest)} { + # It's an upgrade request. Method must be GET (untested). + # Force -keepalive to 0 so the connection is not made over a persistent + # socket, i.e. one used for multiple HTTP requests. + set state(-keepalive) 0 } else { - # It's a GET or HEAD. + # It's a non-upgrade GET or HEAD. set state(-pipeline) $http(-pipeline) } diff --git a/library/http/pkgIndex.tcl b/library/http/pkgIndex.tcl index 7249547..e12cf84 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.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}}}] +package ifneeded http 2.9.7 [list tclPkgSetup $dir http 2.9.7 {{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 2acaf8a..de7f25b 100644 --- a/unix/Makefile.in +++ b/unix/Makefile.in @@ -950,9 +950,9 @@ install-libraries: libraries do \ $(INSTALL_DATA) $$i "$(SCRIPT_INSTALL_DIR)/http1.0"; \ done - @echo "Installing package http 2.9.6 as a Tcl Module"; + @echo "Installing package http 2.9.7 as a Tcl Module"; @$(INSTALL_DATA) $(TOP_DIR)/library/http/http.tcl \ - "$(MODULE_INSTALL_DIR)/8.6/http-2.9.6.tm" + "$(MODULE_INSTALL_DIR)/8.6/http-2.9.7.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 99f04c8..37d579b 100644 --- a/win/Makefile.in +++ b/win/Makefile.in @@ -735,8 +735,8 @@ install-libraries: libraries install-tzdata install-msgs do \ $(COPY) "$$j" "$(SCRIPT_INSTALL_DIR)/http1.0"; \ done; - @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 package http 2.9.7 as a Tcl Module"; + @$(COPY) $(ROOT_DIR)/library/http/http.tcl "$(MODULE_INSTALL_DIR)/8.6/http-2.9.7.tm"; @echo "Installing library opt0.4 directory"; @for j in $(ROOT_DIR)/library/opt/*.tcl; \ do \ -- cgit v0.12 From 0a5154ce87f664c62309803df4d7b8ab14b4721d Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 10 May 2022 16:38:22 +0000 Subject: Now we're on it, keep better track with state(host) and state(path). Backported from http 2.10 --- library/http/http.tcl | 12 ++++++++++-- 1 file changed, 10 insertions(+), 2 deletions(-) diff --git a/library/http/http.tcl b/library/http/http.tcl index 92d3a5a..e754264 100644 --- a/library/http/http.tcl +++ b/library/http/http.tcl @@ -931,8 +931,12 @@ proc http::geturl {url args} { } return -code error "Illegal characters in URL path" } + if {![regexp {^[^?#]+} $srvurl state(path)]} { + set state(path) / + } } else { set srvurl / + set state(path) / } if {$proto eq ""} { set proto http @@ -1409,12 +1413,16 @@ proc http::Connected {token proto phost srvurl} { puts $sock "$how $srvurl HTTP/$state(-protocol)" if {[dict exists $state(-headers) Host]} { # Allow Host spoofing. [Bug 928154] - puts $sock "Host: [dict get $state(-headers) Host]" + set hostHdr [dict get $state(-headers) Host] + regexp {^[^:]+} $hostHdr state(host) + puts $sock "Host: $hostHdr" } elseif {$port == $defport} { # Don't add port in this case, to handle broken servers. [Bug # #504508] + set state(host) $host puts $sock "Host: $host" } else { + set state(host) $host puts $sock "Host: $host:$port" } puts $sock "User-Agent: $http(-useragent)" @@ -3175,7 +3183,7 @@ proc http::BlockingGets {sock} { while 1 { set count [gets $sock line] set eof [eof $sock] - if {$count > -1 || $eof} { + if {$count >= 0 || $eof} { return $line } else { yield -- cgit v0.12 -- cgit v0.12 From e95aa99b53ecc065995e046417ae4379a4b0c160 Mon Sep 17 00:00:00 2001 From: kjnash Date: Wed, 11 May 2022 17:21:37 +0000 Subject: Revise http(n) to fix #15e4bd83c2 --- doc/http.n | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/doc/http.n b/doc/http.n index a451f80..ed698f2 100644 --- a/doc/http.n +++ b/doc/http.n @@ -318,7 +318,8 @@ otherwise complain about HTTP/1.1. .TP \fB\-query\fR \fIquery\fR . -This flag causes \fB::http::geturl\fR to do a POST request that passes the +This flag (if the value is non-empty) causes \fB::http::geturl\fR to do a +POST request that passes the \fIquery\fR as payload verbatim to the server. The content format (and encoding) of \fIquery\fR is announced by the header field \fBcontent-type\fR set by the option \fB-type\fR. -- cgit v0.12 From f9d3eb28e94e4e1a235e70e3ca01c25e5aeeaed0 Mon Sep 17 00:00:00 2001 From: kjnash Date: Wed, 11 May 2022 18:13:32 +0000 Subject: Revise http(n) to fix #1414262 --- doc/http.n | 25 +++++++++++++++++++++++++ 1 file changed, 25 insertions(+) diff --git a/doc/http.n b/doc/http.n index ed698f2..7bcf21c 100644 --- a/doc/http.n +++ b/doc/http.n @@ -135,6 +135,13 @@ the proxy server and proxy port. Otherwise the filter should return an empty list. The default filter returns the values of the \fB\-proxyhost\fR and \fB\-proxyport\fR settings if they are non-empty. +.RS +.PP +The \fB::http::geturl\fR command runs the \fB-proxyfilter\fR callback inside +a \fBcatch\fR command. Therefore an error in the callback command does +not call the \fBbgerror\fR handler. See the \fBERRORS\fR section for +details. +.RE .TP \fB\-repost\fR \fIboolean\fR . @@ -228,6 +235,11 @@ proc httpCallback {token} { # Access state as a Tcl array } .CE +.PP +The \fB::http::geturl\fR command runs the \fB-command\fR callback inside +a \fBcatch\fR command. Therefore an error in the callback command does +not call the \fBbgerror\fR handler. See the \fBERRORS\fR section for +details. .RE .TP \fB\-handler\fR \fIcallback\fR @@ -257,6 +269,11 @@ proc httpHandlerCallback {socket token} { The \fBhttp::geturl\fR code for the \fB-handler\fR option is not compatible with either compression or chunked transfer-encoding. If \fB-handler\fR is specified, then to work around these issues \fBhttp::geturl\fR will reduce the HTTP protocol to 1.0, and override the \fB-zip\fR option (i.e. it will not send the header "\fBAccept-Encoding: gzip,deflate,compress\fR"). .PP If options \fB-handler\fR and \fB-channel\fR are used together, the handler is responsible for copying the data from the HTTP socket to the specified channel. The name of the channel is available to the handler as element \fB-channel\fR of the token array. +.PP +The \fB::http::geturl\fR command runs the \fB-handler\fR callback inside +a \fBcatch\fR command. Therefore an error in the callback command does +not call the \fBbgerror\fR handler. See the \fBERRORS\fR section for +details. .RE .TP \fB\-headers\fR \fIkeyvaluelist\fR @@ -523,6 +540,14 @@ to know the result of the asynchronous HTTP request, it can call \fB::http::wait\fR and then check status and error, just as the callback does. .PP +The \fB::http::geturl\fR command runs the \fB-command\fR, \fB-handler\fR, +and \fB-proxyfilter\fR callbacks inside a \fBcatch\fR command. Therefore +an error in the callback command does not call the \fBbgerror\fR handler. +When debugging one of these +callbacks, it may be convenient to report errors by using a +\fBcatch\fR command within the callback command itself, e.g. to write +an error message to stdout. +.PP In any case, you must still call \fB::http::cleanup\fR to delete the state array when you are done. .PP -- cgit v0.12 From cdea365a569c1ba3e22c816c475847b4bd3f5085 Mon Sep 17 00:00:00 2001 From: kjnash Date: Wed, 11 May 2022 18:24:00 +0000 Subject: Revise http(n) to fix #443195 --- doc/http.n | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/doc/http.n b/doc/http.n index 7bcf21c..c4a8688 100644 --- a/doc/http.n +++ b/doc/http.n @@ -49,6 +49,11 @@ http \- Client-side implementation of the HTTP/1.1 protocol \fB::http::registerError \fIport\fR ?\fImessage\fR? .sp \fB::http::unregister \fIproto\fR +.SH "EXPORTED COMMANDS" +.PP +Namespace \fBhttp\fR exports the commands \fBconfig\fR, \fBformatQuery\fR, \fBgeturl\fR, \fBquoteString\fR, \fBregister\fR, \fBregisterError\fR, \fBreset\fR, \fBunregister\fR, and \fBwait\fR. +.PP +It does not export the commands \fBcleanup\fR, \fBcode\fR, \fBdata\fR, \fBerror\fR, \fBmeta\fR, \fBncode\fR, \fBsize\fR, or \fBstatus\fR. .BE .SH DESCRIPTION .PP -- cgit v0.12 From a96ca020dfbf40d8a61669620d17c5a1e455a99a Mon Sep 17 00:00:00 2001 From: kjnash Date: Wed, 11 May 2022 18:25:55 +0000 Subject: Revise library/http/http.tcl to fix shift_jis typo and #6898f9cb71 --- library/http/http.tcl | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/library/http/http.tcl b/library/http/http.tcl index e754264..838fbee 100644 --- a/library/http/http.tcl +++ b/library/http/http.tcl @@ -3479,7 +3479,7 @@ proc http::CharsetToEncoding {charset} { set encoding "iso8859-$num" } elseif {[regexp {iso-?2022-(jp|kr)} $charset -> ext]} { set encoding "iso2022-$ext" - } elseif {[regexp {shift[-_]?js} $charset]} { + } elseif {[regexp {shift[-_]?jis} $charset]} { set encoding "shiftjis" } elseif {[regexp {(?:windows|cp)-?([0-9]+)} $charset -> num]} { set encoding "cp$num" -- cgit v0.12 From b9ef9f9cefccc2ef851149acbd14c280dd70e622 Mon Sep 17 00:00:00 2001 From: kjnash Date: Wed, 11 May 2022 18:48:20 +0000 Subject: Revise http(n) to fix #14e3c258d9 --- doc/http.n | 20 ++++++++++++++------ 1 file changed, 14 insertions(+), 6 deletions(-) diff --git a/doc/http.n b/doc/http.n index c4a8688..47ed057 100644 --- a/doc/http.n +++ b/doc/http.n @@ -341,12 +341,20 @@ otherwise complain about HTTP/1.1. \fB\-query\fR \fIquery\fR . This flag (if the value is non-empty) causes \fB::http::geturl\fR to do a -POST request that passes the -\fIquery\fR as payload verbatim to the server. -The content format (and encoding) of \fIquery\fR is announced by the header -field \fBcontent-type\fR set by the option \fB-type\fR. -\fIquery\fR is an x-url-encoding formatted query, if used for html forms. -The \fB::http::formatQuery\fR procedure can be used to do the formatting. +POST request that passes the string +\fIquery\fR verbatim to the server as the request payload. +The content format (and encoding) of \fIquery\fR is announced by the request +header \fBContent-Type\fR which is set by the option \fB-type\fR. Any value +of \fB-type\fR is permitted, and it is the responsibility of the caller to +supply \fIquery\fR in the correct format. +.RS +.PP +If \fB-type\fR is not specified, it defaults to +\fIapplication/x-www-form-urlencoded\fR, which requires \fIquery\fR to be an +x-url-encoding formatted query-string (this \fB-type\fR and query format are +used in a POST submitted from an html form). The \fB::http::formatQuery\fR +procedure can be used to do the formatting. +.RE .TP \fB\-queryblocksize\fR \fIsize\fR . -- cgit v0.12 From 355490c37c7a596e846ffeb26c4d82f2dfed9d37 Mon Sep 17 00:00:00 2001 From: kjnash Date: Wed, 11 May 2022 19:05:33 +0000 Subject: Revise http(n) to fix #6afa947d1a --- doc/http.n | 12 ++++++++++-- 1 file changed, 10 insertions(+), 2 deletions(-) diff --git a/doc/http.n b/doc/http.n index 47ed057..b5197a9 100644 --- a/doc/http.n +++ b/doc/http.n @@ -306,8 +306,16 @@ multiple requests. Default is 0. \fB\-method\fR \fItype\fR . Force the HTTP request method to \fItype\fR. \fB::http::geturl\fR will -auto-select GET, POST or HEAD based on other options, but this option -enables choices like PUT and DELETE for webdav support. +auto-select GET, POST or HEAD based on other options, but this option overrides +that selection and enables choices like PUT and DELETE for WebDAV support. +.RS +.PP +It is the caller's responsibility to ensure that the headers and request body +(if any) conform to the requirements of the request method. For example, if +using \fB\-method\fR \fIPOST\fR to send a POST with an empty request body, the +caller must also supply the option +.QW "-headers {Content-Length 0}" . +.RE .TP \fB\-myaddr\fR \fIaddress\fR . -- cgit v0.12 From 6d44e5c0f77c03a6daaf47db88c752018d980055 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 11 May 2022 19:06:56 +0000 Subject: Fix [6898f9cb71]: shiftjis is presumably misspelled in http 2.7.7. Also add more testcases for http::CharsetToEncoding, revealing one more bug --- library/http/http.tcl | 5 ++++- tests/http.test | 21 +++++++++++++++++++++ 2 files changed, 25 insertions(+), 1 deletion(-) diff --git a/library/http/http.tcl b/library/http/http.tcl index e754264..ae0a538 100644 --- a/library/http/http.tcl +++ b/library/http/http.tcl @@ -3479,7 +3479,7 @@ proc http::CharsetToEncoding {charset} { set encoding "iso8859-$num" } elseif {[regexp {iso-?2022-(jp|kr)} $charset -> ext]} { set encoding "iso2022-$ext" - } elseif {[regexp {shift[-_]?js} $charset]} { + } elseif {[regexp {shift[-_]?jis} $charset]} { set encoding "shiftjis" } elseif {[regexp {(?:windows|cp)-?([0-9]+)} $charset -> num]} { set encoding "cp$num" @@ -3491,6 +3491,9 @@ proc http::CharsetToEncoding {charset} { 1 - 2 - 3 { set encoding "iso8859-$num" } + default { + set encoding "binary" + } } } else { # other charset, like euc-xx, utf-8,... may directly map to encoding diff --git a/tests/http.test b/tests/http.test index c45a45a..40113dc 100644 --- a/tests/http.test +++ b/tests/http.test @@ -119,6 +119,27 @@ test http-1.6 {http::config} -setup { test http-2.1 {http::reset} { catch {http::reset http#1} } 0 +test http-2.2 {http::CharsetToEncoding} { + http::CharsetToEncoding iso-8859-11 +} iso8859-11 +test http-2.3 {http::CharsetToEncoding} { + http::CharsetToEncoding iso-2022-kr +} iso2022-kr +test http-2.4 {http::CharsetToEncoding} { + http::CharsetToEncoding shift-jis +} shiftjis +test http-2.5 {http::CharsetToEncoding} { + http::CharsetToEncoding windows-437 +} cp437 +test http-2.6 {http::CharsetToEncoding} { + http::CharsetToEncoding latin5 +} iso8859-9 +test http-2.7 {http::CharsetToEncoding} { + http::CharsetToEncoding latin1 +} iso8859-1 +test http-2.8 {http::CharsetToEncoding} { + http::CharsetToEncoding latin4 +} binary test http-3.1 {http::geturl} -returnCodes error -body { http::geturl -bogus flag -- cgit v0.12 From b68a248552b95b41779deac3bb98023718502216 Mon Sep 17 00:00:00 2001 From: kjnash Date: Wed, 11 May 2022 20:00:48 +0000 Subject: In http(n), escape - to \- in all command options except example code. --- doc/http.n | 62 +++++++++++++++++++++++++++++++------------------------------- 1 file changed, 31 insertions(+), 31 deletions(-) diff --git a/doc/http.n b/doc/http.n index b5197a9..89af32f 100644 --- a/doc/http.n +++ b/doc/http.n @@ -84,7 +84,7 @@ must be active. In Tk applications this is always true. For pure-Tcl applications, the caller can use \fB::http::wait\fR after calling \fB::http::geturl\fR to start the event loop. .PP -\fBNote:\fR The event queue is even used without the \fB-command\fR option. +\fBNote:\fR The event queue is even used without the \fB\-command\fR option. As a side effect, arbitrary commands may be processed while \fBhttp::geturl\fR is running. .SH COMMANDS .TP @@ -116,7 +116,7 @@ is 1. \fB\-postfresh\fR \fIboolean\fR . Specifies whether requests that use the \fBPOST\fR method will always use a -fresh socket, overriding the \fB-keepalive\fR option of +fresh socket, overriding the \fB\-keepalive\fR option of command \fBhttp::geturl\fR. See the \fBPERSISTENT SOCKETS\fR section for details. The default is 0. .TP @@ -142,7 +142,7 @@ an empty list. The default filter returns the values of the non-empty. .RS .PP -The \fB::http::geturl\fR command runs the \fB-proxyfilter\fR callback inside +The \fB::http::geturl\fR command runs the \fB\-proxyfilter\fR callback inside a \fBcatch\fR command. Therefore an error in the callback command does not call the \fBbgerror\fR handler. See the \fBERRORS\fR section for details. @@ -187,7 +187,7 @@ If the value is boolean \fBtrue\fR, then by default requests will send a header .QW "\fBAccept-Encoding: gzip,deflate,compress\fR" . If the value is boolean \fBfalse\fR, then by default this header will not be sent. In either case the default can be overridden for an individual request by -supplying a custom \fBAccept-Encoding\fR header in the \fB-headers\fR option +supplying a custom \fBAccept-Encoding\fR header in the \fB\-headers\fR option of \fBhttp::geturl\fR. The default is 1. .RE .TP @@ -241,7 +241,7 @@ proc httpCallback {token} { } .CE .PP -The \fB::http::geturl\fR command runs the \fB-command\fR callback inside +The \fB::http::geturl\fR command runs the \fB\-command\fR callback inside a \fBcatch\fR command. Therefore an error in the callback command does not call the \fBbgerror\fR handler. See the \fBERRORS\fR section for details. @@ -271,11 +271,11 @@ proc httpHandlerCallback {socket token} { } .CE .PP -The \fBhttp::geturl\fR code for the \fB-handler\fR option is not compatible with either compression or chunked transfer-encoding. If \fB-handler\fR is specified, then to work around these issues \fBhttp::geturl\fR will reduce the HTTP protocol to 1.0, and override the \fB-zip\fR option (i.e. it will not send the header "\fBAccept-Encoding: gzip,deflate,compress\fR"). +The \fBhttp::geturl\fR code for the \fB\-handler\fR option is not compatible with either compression or chunked transfer-encoding. If \fB\-handler\fR is specified, then to work around these issues \fBhttp::geturl\fR will reduce the HTTP protocol to 1.0, and override the \fB\-zip\fR option (i.e. it will not send the header "\fBAccept-Encoding: gzip,deflate,compress\fR"). .PP -If options \fB-handler\fR and \fB-channel\fR are used together, the handler is responsible for copying the data from the HTTP socket to the specified channel. The name of the channel is available to the handler as element \fB-channel\fR of the token array. +If options \fB\-handler\fR and \fB\-channel\fR are used together, the handler is responsible for copying the data from the HTTP socket to the specified channel. The name of the channel is available to the handler as element \fB\-channel\fR of the token array. .PP -The \fB::http::geturl\fR command runs the \fB-handler\fR callback inside +The \fB::http::geturl\fR command runs the \fB\-handler\fR callback inside a \fBcatch\fR command. Therefore an error in the callback command does not call the \fBbgerror\fR handler. See the \fBERRORS\fR section for details. @@ -314,7 +314,7 @@ It is the caller's responsibility to ensure that the headers and request body (if any) conform to the requirements of the request method. For example, if using \fB\-method\fR \fIPOST\fR to send a POST with an empty request body, the caller must also supply the option -.QW "-headers {Content-Length 0}" . +.QW "\-headers {Content-Length 0}" . .RE .TP \fB\-myaddr\fR \fIaddress\fR @@ -352,14 +352,14 @@ This flag (if the value is non-empty) causes \fB::http::geturl\fR to do a POST request that passes the string \fIquery\fR verbatim to the server as the request payload. The content format (and encoding) of \fIquery\fR is announced by the request -header \fBContent-Type\fR which is set by the option \fB-type\fR. Any value -of \fB-type\fR is permitted, and it is the responsibility of the caller to +header \fBContent-Type\fR which is set by the option \fB\-type\fR. Any value +of \fB\-type\fR is permitted, and it is the responsibility of the caller to supply \fIquery\fR in the correct format. .RS .PP -If \fB-type\fR is not specified, it defaults to +If \fB\-type\fR is not specified, it defaults to \fIapplication/x-www-form-urlencoded\fR, which requires \fIquery\fR to be an -x-url-encoding formatted query-string (this \fB-type\fR and query format are +x-url-encoding formatted query-string (this \fB\-type\fR and query format are used in a POST submitted from an html form). The \fB::http::formatQuery\fR procedure can be used to do the formatting. .RE @@ -561,8 +561,8 @@ to know the result of the asynchronous HTTP request, it can call \fB::http::wait\fR and then check status and error, just as the callback does. .PP -The \fB::http::geturl\fR command runs the \fB-command\fR, \fB-handler\fR, -and \fB-proxyfilter\fR callbacks inside a \fBcatch\fR command. Therefore +The \fB::http::geturl\fR command runs the \fB\-command\fR, \fB\-handler\fR, +and \fB\-proxyfilter\fR callbacks inside a \fBcatch\fR command. Therefore an error in the callback command does not call the \fBbgerror\fR handler. When debugging one of these callbacks, it may be convenient to report errors by using a @@ -751,9 +751,9 @@ whether the server was modified by the failed POST request, before sending the same request again. .PP A HTTP request will use a persistent socket if the call to -\fBhttp::geturl\fR has the option \fB-keepalive true\fR. It will use +\fBhttp::geturl\fR has the option \fB\-keepalive true\fR. It will use pipelining where permitted if the \fBhttp::config\fR option -\fB-pipeline\fR is boolean \fBtrue\fR (its default value). +\fB\-pipeline\fR is boolean \fBtrue\fR (its default value). .PP The http package maintains no more than one persistent connection to each server (i.e. each value of @@ -775,7 +775,7 @@ In accordance with RFC 7230, \fBhttp::geturl\fR does not pipeline requests that use the POST method. If a POST uses a persistent connection and is not the first request on that connection, \fBhttp::geturl\fR waits until it has received the response for the previous -request; or (if \fBhttp::config\fR option \fB-postfresh\fR is boolean \fBtrue\fR) it +request; or (if \fBhttp::config\fR option \fB\-postfresh\fR is boolean \fBtrue\fR) it uses a new connection for each POST. .PP If the server is processing a number of pipelined requests, and sends a @@ -796,7 +796,7 @@ GET requests, \fBhttp::geturl\fR opens another connection and retransmits the failed request. However, if the request was a POST, RFC 7230 forbids automatic retry by default, suggesting either user confirmation, or confirmation by user-agent software that has semantic understanding of -the application. The \fBhttp::config\fR option \fB-repost\fR allows for +the application. The \fBhttp::config\fR option \fB\-repost\fR allows for either possibility. .PP Asynchronous close events can occur only in a short interval of time. The @@ -804,16 +804,16 @@ Asynchronous close events can occur only in a short interval of time. The server. Upon detection, the connection is also closed at the client end, and subsequent requests will use a fresh connection. .PP -If the \fBhttp::geturl\fR command is called with option \fB-keepalive true\fR, +If the \fBhttp::geturl\fR command is called with option \fB\-keepalive true\fR, then it will both try to use an existing persistent connection (if one is available), and it will send the server a .QW "\fBConnection: keep-alive\fR" request header asking to keep the connection open for future requests. .PP -The \fBhttp::config\fR options \fB-pipeline\fR, \fB-postfresh\fR, and -\fB-repost\fR relate to persistent connections. +The \fBhttp::config\fR options \fB\-pipeline\fR, \fB\-postfresh\fR, and +\fB\-repost\fR relate to persistent connections. .PP -Option \fB-pipeline\fR, if boolean \fBtrue\fR, will pipeline GET and HEAD requests +Option \fB\-pipeline\fR, if boolean \fBtrue\fR, will pipeline GET and HEAD requests made over a persistent connection. POST requests will not be pipelined - if the POST is not the first transaction on the connection, its request will not @@ -821,15 +821,15 @@ be sent until the previous response has finished. GET and HEAD requests made after a POST will not be sent until the POST response has been delivered, and will not be sent if the POST fails. .PP -Option \fB-postfresh\fR, if boolean \fBtrue\fR, will override the \fBhttp::geturl\fR option -\fB-keepalive\fR, and always open a fresh connection for a POST request. +Option \fB\-postfresh\fR, if boolean \fBtrue\fR, will override the \fBhttp::geturl\fR option +\fB\-keepalive\fR, and always open a fresh connection for a POST request. .PP -Option \fB-repost\fR, if \fBtrue\fR, permits automatic retry of a POST request +Option \fB\-repost\fR, if \fBtrue\fR, permits automatic retry of a POST request that fails because it uses a persistent connection that the server has half-closed (an .QW "asynchronous close event" ). Subsequent GET and HEAD requests in a failed pipeline will also be retried. -\fIThe -repost option should be used only if the application understands +\fIThe \-repost option should be used only if the application understands that the retry is appropriate\fR - specifically, the application must know that if the failed POST successfully modified the state of the server, a repeat POST would have no adverse effect. @@ -841,12 +841,12 @@ that the client wishes to change the protocol used over the existing connection higher version of the HTTP protocol (HTTP 2 or 3), or TLS encryption. If the server accepts the upgrade request, its response code will be 101. .PP -To request a protocol upgrade when calling \fBhttp::geturl\fR, the \fB-headers\fR +To request a protocol upgrade when calling \fBhttp::geturl\fR, the \fB\-headers\fR option must supply appropriate values for \fBConnection\fR and \fBUpgrade\fR, and -the \fB-command\fR option must supply a command that implements the requested +the \fB\-command\fR option must supply a command that implements the requested protocol and can also handle the server response if the server refuses the protocol upgrade. For upgrade requests \fBhttp::geturl\fR ignores the value of -option \fB-keepalive\fR, and always uses the value \fB0\fR so that the upgrade +option \fB\-keepalive\fR, and always uses the value \fB0\fR so that the upgrade request is not made over a connection that is intended for multiple HTTP requests. .PP The Tcllib library \fBwebsocket\fR implements WebSockets, and makes the necessary @@ -902,7 +902,7 @@ proc httpcopy { url file {chunk 4096} } { return $token } proc httpCopyProgress {args} { - puts -nonewline stderr . + puts \-nonewline stderr . flush stderr } .CE -- cgit v0.12 From 511688085318c6f4a765786b9ea88a8f77861d6c Mon Sep 17 00:00:00 2001 From: kjnash Date: Wed, 11 May 2022 20:08:57 +0000 Subject: In http(n), repaginate long lines. --- doc/http.n | 51 ++++++++++++++++++++++++++++++++------------------- 1 file changed, 32 insertions(+), 19 deletions(-) diff --git a/doc/http.n b/doc/http.n index 89af32f..9617934 100644 --- a/doc/http.n +++ b/doc/http.n @@ -51,9 +51,12 @@ http \- Client-side implementation of the HTTP/1.1 protocol \fB::http::unregister \fIproto\fR .SH "EXPORTED COMMANDS" .PP -Namespace \fBhttp\fR exports the commands \fBconfig\fR, \fBformatQuery\fR, \fBgeturl\fR, \fBquoteString\fR, \fBregister\fR, \fBregisterError\fR, \fBreset\fR, \fBunregister\fR, and \fBwait\fR. +Namespace \fBhttp\fR exports the commands \fBconfig\fR, \fBformatQuery\fR, +\fBgeturl\fR, \fBquoteString\fR, \fBregister\fR, \fBregisterError\fR, +\fBreset\fR, \fBunregister\fR, and \fBwait\fR. .PP -It does not export the commands \fBcleanup\fR, \fBcode\fR, \fBdata\fR, \fBerror\fR, \fBmeta\fR, \fBncode\fR, \fBsize\fR, or \fBstatus\fR. +It does not export the commands \fBcleanup\fR, \fBcode\fR, \fBdata\fR, +\fBerror\fR, \fBmeta\fR, \fBncode\fR, \fBsize\fR, or \fBstatus\fR. .BE .SH DESCRIPTION .PP @@ -85,7 +88,8 @@ applications, the caller can use \fB::http::wait\fR after calling \fB::http::geturl\fR to start the event loop. .PP \fBNote:\fR The event queue is even used without the \fB\-command\fR option. -As a side effect, arbitrary commands may be processed while \fBhttp::geturl\fR is running. +As a side effect, arbitrary commands may be processed while \fBhttp::geturl\fR +is running. .SH COMMANDS .TP \fB::http::config\fR ?\fIoptions\fR? @@ -117,8 +121,8 @@ is 1. . Specifies whether requests that use the \fBPOST\fR method will always use a fresh socket, overriding the \fB\-keepalive\fR option of -command \fBhttp::geturl\fR. See the \fBPERSISTENT SOCKETS\fR section for details. -The default is 0. +command \fBhttp::geturl\fR. See the \fBPERSISTENT SOCKETS\fR section for +details. The default is 0. .TP \fB\-proxyhost\fR \fIhostname\fR . @@ -185,8 +189,8 @@ numbers of \fBhttp\fR and \fBTcl\fR. . If the value is boolean \fBtrue\fR, then by default requests will send a header .QW "\fBAccept-Encoding: gzip,deflate,compress\fR" . -If the value is boolean \fBfalse\fR, then by default this header will not be sent. -In either case the default can be overridden for an individual request by +If the value is boolean \fBfalse\fR, then by default this header will not be +sent. In either case the default can be overridden for an individual request by supplying a custom \fBAccept-Encoding\fR header in the \fB\-headers\fR option of \fBhttp::geturl\fR. The default is 1. .RE @@ -271,9 +275,16 @@ proc httpHandlerCallback {socket token} { } .CE .PP -The \fBhttp::geturl\fR code for the \fB\-handler\fR option is not compatible with either compression or chunked transfer-encoding. If \fB\-handler\fR is specified, then to work around these issues \fBhttp::geturl\fR will reduce the HTTP protocol to 1.0, and override the \fB\-zip\fR option (i.e. it will not send the header "\fBAccept-Encoding: gzip,deflate,compress\fR"). +The \fBhttp::geturl\fR code for the \fB\-handler\fR option is not compatible +with either compression or chunked transfer-encoding. If \fB\-handler\fR is +specified, then to work around these issues \fBhttp::geturl\fR will reduce the +HTTP protocol to 1.0, and override the \fB\-zip\fR option (i.e. it will not +send the header "\fBAccept-Encoding: gzip,deflate,compress\fR"). .PP -If options \fB\-handler\fR and \fB\-channel\fR are used together, the handler is responsible for copying the data from the HTTP socket to the specified channel. The name of the channel is available to the handler as element \fB\-channel\fR of the token array. +If options \fB\-handler\fR and \fB\-channel\fR are used together, the handler +is responsible for copying the data from the HTTP socket to the specified +channel. The name of the channel is available to the handler as element +\fB\-channel\fR of the token array. .PP The \fB::http::geturl\fR command runs the \fB\-handler\fR callback inside a \fBcatch\fR command. Therefore an error in the callback command does @@ -639,7 +650,8 @@ if the HTTP response is text. \fBbody\fR . The contents of the URL. This will be empty if the \fB\-channel\fR -option has been specified. This value is returned by the \fB::http::data\fR command. +option has been specified. This value is returned by the \fB::http::data\fR +command. .TP \fBcharset\fR . @@ -775,8 +787,8 @@ In accordance with RFC 7230, \fBhttp::geturl\fR does not pipeline requests that use the POST method. If a POST uses a persistent connection and is not the first request on that connection, \fBhttp::geturl\fR waits until it has received the response for the previous -request; or (if \fBhttp::config\fR option \fB\-postfresh\fR is boolean \fBtrue\fR) it -uses a new connection for each POST. +request; or (if \fBhttp::config\fR option \fB\-postfresh\fR is boolean +\fBtrue\fR) it uses a new connection for each POST. .PP If the server is processing a number of pipelined requests, and sends a response header @@ -813,16 +825,17 @@ request header asking to keep the connection open for future requests. The \fBhttp::config\fR options \fB\-pipeline\fR, \fB\-postfresh\fR, and \fB\-repost\fR relate to persistent connections. .PP -Option \fB\-pipeline\fR, if boolean \fBtrue\fR, will pipeline GET and HEAD requests -made -over a persistent connection. POST requests will not be pipelined - if the +Option \fB\-pipeline\fR, if boolean \fBtrue\fR, will pipeline GET and HEAD +requests made over a persistent connection. POST requests will not be +pipelined - if the POST is not the first transaction on the connection, its request will not be sent until the previous response has finished. GET and HEAD requests made after a POST will not be sent until the POST response has been delivered, and will not be sent if the POST fails. .PP -Option \fB\-postfresh\fR, if boolean \fBtrue\fR, will override the \fBhttp::geturl\fR option -\fB\-keepalive\fR, and always open a fresh connection for a POST request. +Option \fB\-postfresh\fR, if boolean \fBtrue\fR, will override the +\fBhttp::geturl\fR option \fB\-keepalive\fR, and always open a fresh connection +for a POST request. .PP Option \fB\-repost\fR, if \fBtrue\fR, permits automatic retry of a POST request that fails because it uses a persistent connection that the server has @@ -831,8 +844,8 @@ half-closed (an Subsequent GET and HEAD requests in a failed pipeline will also be retried. \fIThe \-repost option should be used only if the application understands that the retry is appropriate\fR - specifically, the application must know -that if the failed POST successfully modified the state of the server, a repeat POST -would have no adverse effect. +that if the failed POST successfully modified the state of the server, a repeat +POST would have no adverse effect. .SH "PROTOCOL UPGRADES" .PP The HTTP/1.1 \fBConnection\fR and \fBUpgrade\fR client headers inform the server -- cgit v0.12 From 6c00e4db82fb7bd7fda66af0d9652ae2b950cc1f Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 12 May 2022 12:36:30 +0000 Subject: Remove "testsize time_t" command, it isn't being used --- win/tclWinTest.c | 12 ++++-------- 1 file changed, 4 insertions(+), 8 deletions(-) diff --git a/win/tclWinTest.c b/win/tclWinTest.c index 8525718..357bbc5 100644 --- a/win/tclWinTest.c +++ b/win/tclWinTest.c @@ -323,18 +323,14 @@ TestSizeCmd( if (objc != 2) { goto syntax; } - if (strcmp(Tcl_GetString(objv[1]), "time_t") == 0) { - Tcl_SetObjResult(interp, Tcl_NewWideIntObj(sizeof(time_t))); - return TCL_OK; - } if (strcmp(Tcl_GetString(objv[1]), "st_mtime") == 0) { - Tcl_StatBuf *statPtr; - Tcl_SetObjResult(interp, Tcl_NewWideIntObj(sizeof(statPtr->st_mtime))); - return TCL_OK; + Tcl_StatBuf *statPtr; + Tcl_SetObjResult(interp, Tcl_NewWideIntObj(sizeof(statPtr->st_mtime))); + return TCL_OK; } syntax: - Tcl_WrongNumArgs(interp, 1, objv, "time_t|st_mtime"); + Tcl_WrongNumArgs(interp, 1, objv, "st_mtime"); return TCL_ERROR; } -- cgit v0.12 From a7d78a8fb4183478700856b8ba6471d5157e8a5a Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 13 May 2022 10:11:39 +0000 Subject: Remove [https://core.tcl-lang.org/tcl/info/1fe8ca8d3eb87b65|Horrible Hack] to keep the old error message. Instead depend on [https://core.tcl-lang.org/tips/doc/trunk/tip/601.md|TIP #601] to let "encoding convertto" generate an exception. --- doc/http.n | 7 +------ library/http/http.tcl | 14 ++------------ tests/http.test | 7 ++++--- 3 files changed, 7 insertions(+), 21 deletions(-) diff --git a/doc/http.n b/doc/http.n index 2b2d09d..84c75b0 100644 --- a/doc/http.n +++ b/doc/http.n @@ -161,12 +161,7 @@ default is 0. . The \fIencoding\fR used for creating the x-url-encoded URLs with \fB::http::formatQuery\fR and \fB::http::quoteString\fR. -The default is \fButf-8\fR, as specified by RFC -2718. Prior to http 2.5 this was unspecified, and that behavior can be -returned by specifying the empty string (\fB{}\fR), although -\fIiso8859-1\fR is recommended to restore similar behavior but without the -\fB::http::formatQuery\fR or \fB::http::quoteString\fR -throwing an error processing non-latin-1 characters. +The default is \fButf-8\fR, as specified by RFC 2718. .TP \fB\-useragent\fR \fIstring\fR . diff --git a/library/http/http.tcl b/library/http/http.tcl index 187d203..87003e4 100644 --- a/library/http/http.tcl +++ b/library/http/http.tcl @@ -3539,18 +3539,8 @@ proc http::mapReply {string} { # a pre-computed map and [string map] to do the conversion (much faster # than [regsub]/[subst]). [Bug 1020491] - if {$http(-urlencoding) ne ""} { - set string [encoding convertto $http(-urlencoding) $string] - return [string map $formMap $string] - } - set converted [string map $formMap $string] - if {[string match "*\[\u0100-\uffff\]*" $converted]} { - regexp "\[\u0100-\uffff\]" $converted badChar - # Return this error message for maximum compatibility... :^/ - return -code error \ - "can't read \"formMap($badChar)\": no such element in array" - } - return $converted + set string [encoding convertto $http(-urlencoding) $string] + return [string map $formMap $string] } interp alias {} http::quoteString {} http::mapReply diff --git a/tests/http.test b/tests/http.test index d59d588..e3baf58 100644 --- a/tests/http.test +++ b/tests/http.test @@ -677,17 +677,18 @@ test http-7.2 {http::mapReply} { test http-7.3 {http::formatQuery} -setup { set enc [http::config -urlencoding] } -returnCodes error -body { - # this would be reverting to http <=2.4 behavior + # -urlencoding "" no longer supported. Use "iso8859-1". http::config -urlencoding "" http::mapReply "∈" } -cleanup { http::config -urlencoding $enc -} -result "can't read \"formMap(∈)\": no such element in array" +} -result {unknown encoding ""} test http-7.4 {http::formatQuery} -constraints deprecated -setup { set enc [http::config -urlencoding] } -body { # this would be reverting to http <=2.4 behavior w/o errors - # (unknown chars become '?') + # with Tcl 8.x (unknown chars become '?'), generating a + # proper exception with Tcl 9.0 http::config -urlencoding "iso8859-1" http::mapReply "∈" } -cleanup { -- cgit v0.12 From ded51e0c9087a9fe17500b24f7f5fb1ec2171aa2 Mon Sep 17 00:00:00 2001 From: kjnash Date: Fri, 13 May 2022 22:49:06 +0000 Subject: Correction to http(n) - cannot use Upgrade header to upgrade to http/3 --- doc/http.n | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/doc/http.n b/doc/http.n index 9617934..c3ce165 100644 --- a/doc/http.n +++ b/doc/http.n @@ -851,7 +851,7 @@ POST would have no adverse effect. The HTTP/1.1 \fBConnection\fR and \fBUpgrade\fR client headers inform the server that the client wishes to change the protocol used over the existing connection (RFC 7230). This mechanism can be used to request a WebSocket (RFC 6455), a -higher version of the HTTP protocol (HTTP 2 or 3), or TLS encryption. If the +higher version of the HTTP protocol (HTTP 2), or TLS encryption. If the server accepts the upgrade request, its response code will be 101. .PP To request a protocol upgrade when calling \fBhttp::geturl\fR, the \fB\-headers\fR @@ -865,7 +865,7 @@ request is not made over a connection that is intended for multiple HTTP request The Tcllib library \fBwebsocket\fR implements WebSockets, and makes the necessary calls to commands in the \fBhttp\fR package. .PP -There is currently no native Tcl client library for HTTP/2 or HTTP/3. +There is currently no native Tcl client library for HTTP/2. .PP The \fBUpgrade\fR mechanism is not used to request TLS in web browsers, because \fBhttp\fR and \fBhttps\fR are served over different ports. It is used by -- cgit v0.12 From 720797e76cbd290e097b9094da83c44cadfac5bf Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Sun, 15 May 2022 20:19:30 +0000 Subject: Change (unsupported) "utfmax" option in rules.vc to it's reverse "utf16". No effect in Tcl 8.6. Not recommended (but working!) in Tcl 8.7 and 9.0 --- .travis.yml | 18 ------------------ win/makefile.vc | 4 ++-- win/rules.vc | 15 +++++++-------- 3 files changed, 9 insertions(+), 28 deletions(-) diff --git a/.travis.yml b/.travis.yml index eb1ec0c..061fe2d 100644 --- a/.travis.yml +++ b/.travis.yml @@ -197,15 +197,6 @@ jobs: script: - cmd.exe //C vcvarsall.bat x64 '&&' nmake '-f' makefile.vc all tcltest - cmd.exe //C vcvarsall.bat x64 '&&' nmake '-f' makefile.vc test - - name: "Windows/MSVC/Shared: UTF_MAX=4" - os: windows - compiler: cl - env: *vcenv - before_install: *vcpreinst - install: [] - script: - - cmd.exe //C vcvarsall.bat x64 '&&' nmake 'OPTS=utfmax' '-f' makefile.vc all tcltest - - cmd.exe //C vcvarsall.bat x64 '&&' nmake 'OPTS=utfmax' '-f' makefile.vc test - name: "Windows/MSVC/Static" os: windows compiler: cl @@ -252,15 +243,6 @@ jobs: script: - cmd.exe //C vcvarsall.bat x86 '&&' nmake '-f' makefile.vc all tcltest - cmd.exe //C vcvarsall.bat x86 '&&' nmake '-f' makefile.vc test - - name: "Windows/MSVC-x86/Shared: UTF_MAX=4" - os: windows - compiler: cl - env: *vcenv - before_install: *vcpreinst - install: [] - script: - - cmd.exe //C vcvarsall.bat x86 '&&' nmake 'OPTS=utfmax' '-f' makefile.vc all tcltest - - cmd.exe //C vcvarsall.bat x86 '&&' nmake 'OPTS=utfmax' '-f' makefile.vc test - name: "Windows/MSVC-x86/Static" os: windows compiler: cl diff --git a/win/makefile.vc b/win/makefile.vc index 395a9ca..011546a 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,nothreads,pdbs,profile,static,staticpkg,symbols,thrdalloc,time64bit,unchecked,utfmax,none +# OPTS=msvcrt,nothreads,pdbs,profile,static,staticpkg,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. @@ -77,7 +77,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 a571899..3107756 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 @@ -884,9 +883,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 @@ -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 fb3abfc9c3019d7b9b4ff002319576ef4004881b Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 17 May 2022 06:20:13 +0000 Subject: Add missing macro's. Thanks to Ashok, noticing this --- generic/tclDecls.h | 21 +++++++++++++++++++++ 1 file changed, 21 insertions(+) diff --git a/generic/tclDecls.h b/generic/tclDecls.h index 7fb7e74..4a3817e 100644 --- a/generic/tclDecls.h +++ b/generic/tclDecls.h @@ -4066,6 +4066,27 @@ extern const TclStubs *tclStubsPtr; # define Tcl_WCharLen (sizeof(wchar_t) != sizeof(short) \ ? (size_t (*)(wchar_t *))Tcl_UniCharLen \ : (size_t (*)(wchar_t *))Tcl_Char16Len) +# define Tcl_ListObjGetElements(interp, listPtr, objcPtr, objvPtr) (sizeof(*(objcPtr)) != sizeof(int) \ + ? (Tcl_ListObjGetElements)((interp), (listPtr), (size_t *)(void *)(objcPtr), (objvPtr)) \ + : TclListObjGetElements_((interp), (listPtr), (int *)(void *)(objcPtr), (objvPtr))) +# define Tcl_ListObjLength(interp, listPtr, lengthPtr) (sizeof(*(lengthPtr)) != sizeof(int) \ + ? (Tcl_ListObjLength)((interp), (listPtr), (size_t *)(void *)(lengthPtr)) \ + : TclListObjLength_((interp), (listPtr), (int *)(void *)(lengthPtr))) +# define Tcl_DictObjSize(interp, dictPtr, sizePtr) (sizeof(*(sizePtr)) != sizeof(int) \ + ? (Tcl_DictObjSize)((interp), (dictPtr), (size_t *)(void *)(sizePtr)) \ + : TclDictObjSize_((interp), (dictPtr), (int *)(void *)(sizePtr))) +# define Tcl_SplitList(interp, listStr, argcPtr, argvPtr) (sizeof(*(argcPtr)) != sizeof(int) \ + ? (Tcl_SplitList)((interp), (listStr), (size_t *)(void *)(argcPtr), (argvPtr)) \ + : TclSplitList_((interp), (listStr), (int *)(void *)(argcPtr), (argvPtr))) +# define Tcl_SplitPath(path, argcPtr, argvPtr) (sizeof(*(argcPtr)) != sizeof(int) \ + ? (Tcl_SplitPath)((path), (size_t *)(void *)(argcPtr), (argvPtr)) \ + : TclSplitPath_((path), (int *)(void *)(argcPtr), (argvPtr))) +# define Tcl_FSSplitPath(pathPtr, lenPtr) (sizeof(*(lenPtr)) != sizeof(int) \ + ? (Tcl_FSSplitPath)((pathPtr), (size_t *)(void *)(lenPtr)) \ + : TclFSSplitPath_((pathPtr), (int *)(void *)(lenPtr))) +# define Tcl_ParseArgsObjv(interp, argTable, objcPtr, objv, remObjv) (sizeof(*(objcPtr)) != sizeof(int) \ + ? (Tcl_ParseArgsObjv)((interp), (argTable), (size_t *)(void *)(objcPtr), (objv), (remObjv)) \ + : TclParseArgsObjv_((interp), (argTable), (int *)(void *)(objcPtr), (objv), (remObjv))) #endif /* -- cgit v0.12 From bd2e73ff510f8fd5d9291cc8eff89544cdce2583 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 17 May 2022 07:21:51 +0000 Subject: Fix compiler warning in tclTest.c --- generic/tclTest.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/generic/tclTest.c b/generic/tclTest.c index cbd1f70..c740109 100644 --- a/generic/tclTest.c +++ b/generic/tclTest.c @@ -6985,7 +6985,7 @@ TestUtfNextCmd( } bytes = Tcl_GetStringFromObj(objv[1], &numBytes); - if (numBytes + 4 > sizeof(buffer)) { + if (numBytes + 4U > sizeof(buffer)) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "\"testutfnext\" can only handle %" TCL_Z_MODIFIER "u bytes", sizeof(buffer) - 4)); -- cgit v0.12 From 2c603a6a0f21a7c2eadaad5c05dde221d46699c0 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 17 May 2022 08:49:40 +0000 Subject: some less underscores in exported functions --- generic/tcl.decls | 10 ++++---- generic/tclDecls.h | 70 +++++++++++++++++++++++---------------------------- generic/tclStubInit.c | 31 +++++++++-------------- 3 files changed, 48 insertions(+), 63 deletions(-) diff --git a/generic/tcl.decls b/generic/tcl.decls index 46b68f5..68bad77 100644 --- a/generic/tcl.decls +++ b/generic/tcl.decls @@ -2460,20 +2460,20 @@ declare 662 { size_t *lengthPtr) } declare 663 { - int TclDictObjSize_(Tcl_Interp *interp, Tcl_Obj *dictPtr, size_t *sizePtr) + int TclDictObjSize(Tcl_Interp *interp, Tcl_Obj *dictPtr, size_t *sizePtr) } declare 664 { - int TclSplitList_(Tcl_Interp *interp, const char *listStr, size_t *argcPtr, + 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) + void TclSplitPath(const char *path, size_t *argcPtr, const char ***argvPtr) } declare 666 { - Tcl_Obj *TclFSSplitPath_(Tcl_Obj *pathPtr, size_t *lenPtr) + Tcl_Obj *TclFSSplitPath(Tcl_Obj *pathPtr, size_t *lenPtr) } declare 667 { - int TclParseArgsObjv_(Tcl_Interp *interp, const Tcl_ArgvInfo *argTable, + int TclParseArgsObjv(Tcl_Interp *interp, const Tcl_ArgvInfo *argTable, size_t *objcPtr, Tcl_Obj *const *objv, Tcl_Obj ***remObjv) } diff --git a/generic/tclDecls.h b/generic/tclDecls.h index e10f25a..77ec110 100644 --- a/generic/tclDecls.h +++ b/generic/tclDecls.h @@ -1963,19 +1963,18 @@ EXTERN int TclListObjGetElements_(Tcl_Interp *interp, EXTERN int TclListObjLength_(Tcl_Interp *interp, Tcl_Obj *listPtr, size_t *lengthPtr); /* 663 */ -EXTERN int TclDictObjSize_(Tcl_Interp *interp, Tcl_Obj *dictPtr, +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); +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, +EXTERN void TclSplitPath(const char *path, size_t *argcPtr, const char ***argvPtr); /* 666 */ -EXTERN Tcl_Obj * TclFSSplitPath_(Tcl_Obj *pathPtr, size_t *lenPtr); +EXTERN Tcl_Obj * TclFSSplitPath(Tcl_Obj *pathPtr, size_t *lenPtr); /* 667 */ -EXTERN int TclParseArgsObjv_(Tcl_Interp *interp, +EXTERN int TclParseArgsObjv(Tcl_Interp *interp, const Tcl_ArgvInfo *argTable, size_t *objcPtr, Tcl_Obj *const *objv, Tcl_Obj ***remObjv); @@ -2689,11 +2688,11 @@ 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 */ - 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 */ + 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 */ + int (*tclParseArgsObjv) (Tcl_Interp *interp, const Tcl_ArgvInfo *argTable, size_t *objcPtr, Tcl_Obj *const *objv, Tcl_Obj ***remObjv); /* 667 */ int (*tcl_UniCharLen) (const int *uniStr); /* 668 */ int (*tclNumUtfChars) (const char *src, int length); /* 669 */ int (*tclGetCharLength) (Tcl_Obj *objPtr); /* 670 */ @@ -4056,16 +4055,16 @@ extern const TclStubs *tclStubsPtr; (tclStubsPtr->tclListObjGetElements_) /* 661 */ #define TclListObjLength_ \ (tclStubsPtr->tclListObjLength_) /* 662 */ -#define TclDictObjSize_ \ - (tclStubsPtr->tclDictObjSize_) /* 663 */ -#define TclSplitList_ \ - (tclStubsPtr->tclSplitList_) /* 664 */ -#define TclSplitPath_ \ - (tclStubsPtr->tclSplitPath_) /* 665 */ -#define TclFSSplitPath_ \ - (tclStubsPtr->tclFSSplitPath_) /* 666 */ -#define TclParseArgsObjv_ \ - (tclStubsPtr->tclParseArgsObjv_) /* 667 */ +#define TclDictObjSize \ + (tclStubsPtr->tclDictObjSize) /* 663 */ +#define TclSplitList \ + (tclStubsPtr->tclSplitList) /* 664 */ +#define TclSplitPath \ + (tclStubsPtr->tclSplitPath) /* 665 */ +#define TclFSSplitPath \ + (tclStubsPtr->tclFSSplitPath) /* 666 */ +#define TclParseArgsObjv \ + (tclStubsPtr->tclParseArgsObjv) /* 667 */ #define Tcl_UniCharLen \ (tclStubsPtr->tcl_UniCharLen) /* 668 */ #define TclNumUtfChars \ @@ -4376,23 +4375,23 @@ extern const TclStubs *tclStubsPtr; # 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->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))) + : 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))) + : 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))) + : 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))) + : tclStubsPtr->tclParseArgsObjv((interp), (argTable), (size_t *)(void *)(objcPtr), (objv), (remObjv))) #endif /* TCL_NO_DEPRECATED */ #else # define Tcl_WCharToUtfDString (sizeof(wchar_t) != sizeof(short) \ @@ -4416,19 +4415,19 @@ extern const TclStubs *tclStubsPtr; : TclListObjLength_((interp), (listPtr), (size_t *)(void *)(lengthPtr))) # define Tcl_DictObjSize(interp, dictPtr, sizePtr) (sizeof(*(sizePtr)) == sizeof(int) \ ? (Tcl_DictObjSize)((interp), (dictPtr), (int *)(void *)(sizePtr)) \ - : TclDictObjSize_((interp), (dictPtr), (size_t *)(void *)(sizePtr))) + : TclDictObjSize((interp), (dictPtr), (size_t *)(void *)(sizePtr))) # define Tcl_SplitList(interp, listStr, argcPtr, argvPtr) (sizeof(*(argcPtr)) == sizeof(int) \ ? (Tcl_SplitList)((interp), (listStr), (int *)(void *)(argcPtr), (argvPtr)) \ - : TclSplitList_((interp), (listStr), (size_t *)(void *)(argcPtr), (argvPtr))) + : TclSplitList((interp), (listStr), (size_t *)(void *)(argcPtr), (argvPtr))) # define Tcl_SplitPath(path, argcPtr, argvPtr) (sizeof(*(argcPtr)) == sizeof(int) \ ? (Tcl_SplitPath)((path), (int *)(void *)(argcPtr), (argvPtr)) \ - : TclSplitPath_((path), (size_t *)(void *)(argcPtr), (argvPtr))) + : TclSplitPath((path), (size_t *)(void *)(argcPtr), (argvPtr))) # define Tcl_FSSplitPath(pathPtr, lenPtr) (sizeof(*(lenPtr)) == sizeof(int) \ ? (Tcl_FSSplitPath)((pathPtr), (int *)(void *)(lenPtr)) \ - : TclFSSplitPath_((pathPtr), (size_t *)(void *)(lenPtr))) + : TclFSSplitPath((pathPtr), (size_t *)(void *)(lenPtr))) # define Tcl_ParseArgsObjv(interp, argTable, objcPtr, objv, remObjv) (sizeof(*(objcPtr)) == sizeof(int) \ ? (Tcl_ParseArgsObjv)((interp), (argTable), (int *)(void *)(objcPtr), (objv), (remObjv)) \ - : TclParseArgsObjv_((interp), (argTable), (size_t *)(void *)(objcPtr), (objv), (remObjv))) + : TclParseArgsObjv((interp), (argTable), (size_t *)(void *)(objcPtr), (objv), (remObjv))) #endif /* TCL_NO_DEPRECATED */ #endif @@ -4451,13 +4450,6 @@ extern const TclStubs *tclStubsPtr; #undef TclUtfCharComplete #undef TclUtfNext #undef TclUtfPrev -#undef TclListObjGetElements_ -#undef TclListObjLength_ -#undef TclDictObjSize_ -#undef TclSplitList_ -#undef TclSplitPath_ -#undef TclFSSplitPath_ -#undef TclParseArgsObjv_ #if defined(USE_TCL_STUBS) && (TCL_UTF_MAX < 4) && !defined(TCL_NO_DEPRECATED) # undef Tcl_UtfCharComplete # undef Tcl_UtfNext diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c index 18a8bff..ba74f8e 100644 --- a/generic/tclStubInit.c +++ b/generic/tclStubInit.c @@ -131,14 +131,7 @@ static const char *TclUtfPrev(const char *src, const char *start) { return Tcl_UtfPrev(src, start); } -#define TclListObjGetElements_ LOGetElements -#define TclListObjLength_ LOLength -#define TclDictObjSize_ DOSize -#define TclSplitList_ SplitList -#define TclSplitPath_ SplitPath -#define TclFSSplitPath_ FSSplitPath -#define TclParseArgsObjv_ ParseArgsObjv -static int LOGetElements(Tcl_Interp *interp, Tcl_Obj *listPtr, +int TclListObjGetElements_(Tcl_Interp *interp, Tcl_Obj *listPtr, size_t *objcPtr, Tcl_Obj ***objvPtr) { int n, result = Tcl_ListObjGetElements(interp, listPtr, &n, objvPtr); if ((result == TCL_OK) && objcPtr) { @@ -146,7 +139,7 @@ static int LOGetElements(Tcl_Interp *interp, Tcl_Obj *listPtr, } return result; } -static int LOLength(Tcl_Interp *interp, Tcl_Obj *listPtr, +int TclListObjLength_(Tcl_Interp *interp, Tcl_Obj *listPtr, size_t *lengthPtr) { int n; int result = Tcl_ListObjLength(interp, listPtr, &n); @@ -155,7 +148,7 @@ static int LOLength(Tcl_Interp *interp, Tcl_Obj *listPtr, } return result; } -static int DOSize(Tcl_Interp *interp, Tcl_Obj *dictPtr, +int TclDictObjSize(Tcl_Interp *interp, Tcl_Obj *dictPtr, size_t *sizePtr) { int n, result = Tcl_DictObjSize(interp, dictPtr, &n); if ((result == TCL_OK) && sizePtr) { @@ -163,7 +156,7 @@ static int DOSize(Tcl_Interp *interp, Tcl_Obj *dictPtr, } return result; } -static int SplitList(Tcl_Interp *interp, const char *listStr, size_t *argcPtr, +int TclSplitList(Tcl_Interp *interp, const char *listStr, size_t *argcPtr, const char ***argvPtr) { int n; int result = Tcl_SplitList(interp, listStr, &n, argvPtr); @@ -172,14 +165,14 @@ static int SplitList(Tcl_Interp *interp, const char *listStr, size_t *argcPtr, } return result; } -static void SplitPath(const char *path, size_t *argcPtr, const char ***argvPtr) { +void TclSplitPath(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) { +Tcl_Obj *TclFSSplitPath(Tcl_Obj *pathPtr, size_t *lenPtr) { int n; Tcl_Obj *result = Tcl_FSSplitPath(pathPtr, &n); if (result && lenPtr) { @@ -187,7 +180,7 @@ static Tcl_Obj *FSSplitPath(Tcl_Obj *pathPtr, size_t *lenPtr) { } return result; } -static int ParseArgsObjv(Tcl_Interp *interp, +int TclParseArgsObjv(Tcl_Interp *interp, const Tcl_ArgvInfo *argTable, size_t *objcPtr, Tcl_Obj *const *objv, Tcl_Obj ***remObjv) { int n, result; @@ -2025,11 +2018,11 @@ const TclStubs tclStubs = { Tcl_AsyncMarkFromSignal, /* 660 */ TclListObjGetElements_, /* 661 */ TclListObjLength_, /* 662 */ - TclDictObjSize_, /* 663 */ - TclSplitList_, /* 664 */ - TclSplitPath_, /* 665 */ - TclFSSplitPath_, /* 666 */ - TclParseArgsObjv_, /* 667 */ + TclDictObjSize, /* 663 */ + TclSplitList, /* 664 */ + TclSplitPath, /* 665 */ + TclFSSplitPath, /* 666 */ + TclParseArgsObjv, /* 667 */ Tcl_UniCharLen, /* 668 */ TclNumUtfChars, /* 669 */ TclGetCharLength, /* 670 */ -- cgit v0.12 From af999a3a2c4770f8654059f5c5b50d766cc88c7f Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 17 May 2022 09:32:51 +0000 Subject: Rename macro's TclListObjGetElements -> TclListObjGetElementsM and TclListObjLength -> TclListObjLengthM (prevent conflict with TIP #616) --- generic/tclAssembly.c | 2 +- generic/tclBasic.c | 14 +++++++------- generic/tclBinary.c | 4 ++-- generic/tclClock.c | 8 ++++---- generic/tclCmdAH.c | 6 +++--- generic/tclCmdIL.c | 38 +++++++++++++++++++------------------- generic/tclCmdMZ.c | 26 +++++++++++++------------- generic/tclCompCmds.c | 6 +++--- generic/tclCompCmdsSZ.c | 12 ++++++------ generic/tclCompExpr.c | 4 ++-- generic/tclDictObj.c | 18 +++++++++--------- generic/tclDisassemble.c | 2 +- generic/tclEncoding.c | 14 +++++++------- generic/tclEnsemble.c | 38 +++++++++++++++++++------------------- generic/tclEvent.c | 2 +- generic/tclExecute.c | 42 +++++++++++++++++++++--------------------- 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 | 4 ++-- generic/tclInterp.c | 6 +++--- generic/tclLink.c | 2 +- generic/tclListObj.c | 12 ++++++------ 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/tclTrace.c | 10 +++++----- generic/tclUtil.c | 2 +- generic/tclVar.c | 12 ++++++------ generic/tclZipfs.c | 2 +- generic/tclZlib.c | 8 ++++---- 44 files changed, 215 insertions(+), 215 deletions(-) diff --git a/generic/tclAssembly.c b/generic/tclAssembly.c index 5825dcb..5a4e30d 100644 --- a/generic/tclAssembly.c +++ b/generic/tclAssembly.c @@ -1985,7 +1985,7 @@ CreateMirrorJumpTable( * table. */ int i; - if (TclListObjGetElements(interp, jumps, &objc, &objv) != TCL_OK) { + if (TclListObjGetElementsM(interp, jumps, &objc, &objv) != TCL_OK) { return TCL_ERROR; } if (objc % 2 != 0) { diff --git a/generic/tclBasic.c b/generic/tclBasic.c index 74cb683..f87e1e1 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -5179,7 +5179,7 @@ TEOV_NotFound( * itself. */ - TclListObjGetElements(NULL, currNsPtr->unknownHandlerPtr, + TclListObjGetElementsM(NULL, currNsPtr->unknownHandlerPtr, &handlerObjc, &handlerObjv); newObjc = objc + handlerObjc; newObjv = (Tcl_Obj **)TclStackAlloc(interp, sizeof(Tcl_Obj *) * newObjc); @@ -5736,7 +5736,7 @@ TclEvalEx( if (tokenPtr->type == TCL_TOKEN_EXPAND_WORD) { int numElements; - code = TclListObjLength(interp, objv[objectsUsed], + code = TclListObjLengthM(interp, objv[objectsUsed], &numElements); if (code == TCL_ERROR) { /* @@ -5788,7 +5788,7 @@ TclEvalEx( int numElements; Tcl_Obj **elements, *temp = copy[wordIdx]; - TclListObjGetElements(NULL, temp, &numElements, + TclListObjGetElementsM(NULL, temp, &numElements, &elements); objectsUsed += numElements; while (numElements--) { @@ -6628,7 +6628,7 @@ TclNREvalObjEx( TclNRAddCallback(interp, TEOEx_ListCallback, listPtr, eoFramePtr, objPtr, NULL); - TclListObjGetElements(NULL, listPtr, &objc, &objv); + TclListObjGetElementsM(NULL, listPtr, &objc, &objv); return TclNREvalObjv(interp, objc, objv, flags, NULL); } @@ -9397,7 +9397,7 @@ TclNRTailcallEval( int objc; Tcl_Obj **objv; - TclListObjGetElements(interp, listPtr, &objc, &objv); + TclListObjGetElementsM(interp, listPtr, &objc, &objv); nsObjPtr = objv[0]; if (result == TCL_OK) { @@ -9825,7 +9825,7 @@ TclNREvalList( TclMarkTailcall(interp); TclNRAddCallback(interp, TclNRReleaseValues, listPtr, NULL, NULL,NULL); - TclListObjGetElements(NULL, listPtr, &objc, &objv); + TclListObjGetElementsM(NULL, listPtr, &objc, &objv); return TclNREvalObjv(interp, objc, objv, 0, NULL); } @@ -10111,7 +10111,7 @@ InjectHandler( TclMarkTailcall(interp); TclNRAddCallback(interp, InjectHandlerPostCall, corPtr, listPtr, INT2PTR(nargs), isProbe); - TclListObjGetElements(NULL, listPtr, &objc, &objv); + TclListObjGetElementsM(NULL, listPtr, &objc, &objv); return TclNREvalObjv(interp, objc, objv, 0, NULL); } diff --git a/generic/tclBinary.c b/generic/tclBinary.c index bc17232..5678a66 100644 --- a/generic/tclBinary.c +++ b/generic/tclBinary.c @@ -1129,7 +1129,7 @@ BinaryFormatCmd( * The macro evals its args more than once: avoid arg++ */ - if (TclListObjGetElements(interp, objv[arg], &listc, + if (TclListObjGetElementsM(interp, objv[arg], &listc, &listv) != TCL_OK) { return TCL_ERROR; } @@ -1411,7 +1411,7 @@ BinaryFormatCmd( listc = 1; count = 1; } else { - TclListObjGetElements(interp, objv[arg], &listc, &listv); + TclListObjGetElementsM(interp, objv[arg], &listc, &listv); if (count == BINARY_ALL) { count = listc; } diff --git a/generic/tclClock.c b/generic/tclClock.c index 4473f74..0669ffe 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 (TclListObjGetElementsM(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, + || TclListObjGetElementsM(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 (TclListObjGetElementsM(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 || + TclListObjGetElementsM(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 401b14a..e4303e6 100644 --- a/generic/tclCmdAH.c +++ b/generic/tclCmdAH.c @@ -188,7 +188,7 @@ Tcl_CaseObjCmd( if (caseObjc == 1) { Tcl_Obj **newObjv; - TclListObjGetElements(interp, caseObjv[0], &caseObjc, &newObjv); + TclListObjGetElementsM(interp, caseObjv[0], &caseObjc, &newObjv); caseObjv = newObjv; } @@ -2742,7 +2742,7 @@ EachloopCmd( result = TCL_ERROR; goto done; } - TclListObjGetElements(NULL, statePtr->vCopyList[i], + TclListObjGetElementsM(NULL, statePtr->vCopyList[i], &statePtr->varcList[i], &statePtr->varvList[i]); if (statePtr->varcList[i] < 1) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( @@ -2760,7 +2760,7 @@ EachloopCmd( result = TCL_ERROR; goto done; } - TclListObjGetElements(NULL, statePtr->aCopyList[i], + TclListObjGetElementsM(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 986dd49..f32fd98 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 (TclListObjGetElementsM(interp, objv[1], &listLen, &elemPtrs) != TCL_OK) { return TCL_ERROR; } @@ -2281,7 +2281,7 @@ Tcl_LassignObjCmd( return TCL_ERROR; } - TclListObjGetElements(NULL, listCopyPtr, &listObjc, &listObjv); + TclListObjGetElementsM(NULL, listCopyPtr, &listObjc, &listObjv); objc -= 2; objv += 2; @@ -2406,7 +2406,7 @@ Tcl_LinsertObjCmd( return TCL_ERROR; } - result = TclListObjLength(interp, objv[1], &len); + result = TclListObjLengthM(interp, objv[1], &len); if (result != TCL_OK) { return result; } @@ -2524,7 +2524,7 @@ Tcl_LlengthObjCmd( return TCL_ERROR; } - result = TclListObjLength(interp, objv[1], &listLen); + result = TclListObjLengthM(interp, objv[1], &listLen); if (result != TCL_OK) { return result; } @@ -2577,7 +2577,7 @@ Tcl_LpopObjCmd( return TCL_ERROR; } - result = TclListObjGetElements(interp, listPtr, &listLen, &elemPtrs); + result = TclListObjGetElementsM(interp, listPtr, &listLen, &elemPtrs); if (result != TCL_OK) { return result; } @@ -2671,7 +2671,7 @@ Tcl_LrangeObjCmd( return TCL_ERROR; } - result = TclListObjLength(interp, objv[1], &listLen); + result = TclListObjLengthM(interp, objv[1], &listLen); if (result != TCL_OK) { return result; } @@ -2745,7 +2745,7 @@ Tcl_LremoveObjCmd( } listObj = objv[1]; - if (TclListObjLength(interp, listObj, &listLen) != TCL_OK) { + if (TclListObjLengthM(interp, listObj, &listLen) != TCL_OK) { return TCL_ERROR; } @@ -2969,7 +2969,7 @@ Tcl_LreplaceObjCmd( return TCL_ERROR; } - result = TclListObjLength(interp, objv[1], &listLen); + result = TclListObjLengthM(interp, objv[1], &listLen); if (result != TCL_OK) { return result; } @@ -3067,7 +3067,7 @@ Tcl_LreverseObjCmd( Tcl_WrongNumArgs(interp, 1, objv, "list"); return TCL_ERROR; } - if (TclListObjGetElements(interp, objv[1], &elemc, &elemv) != TCL_OK) { + if (TclListObjGetElementsM(interp, objv[1], &elemc, &elemv) != TCL_OK) { return TCL_ERROR; } @@ -3338,7 +3338,7 @@ Tcl_LsearchObjCmd( */ i++; - if (TclListObjGetElements(interp, objv[i], + if (TclListObjGetElementsM(interp, objv[i], &sortInfo.indexc, &indices) != TCL_OK) { result = TCL_ERROR; goto done; @@ -3444,7 +3444,7 @@ Tcl_LsearchObjCmd( * pointer to its array of element pointers. */ - result = TclListObjGetElements(interp, objv[objc - 2], &listc, &listv); + result = TclListObjGetElementsM(interp, objv[objc - 2], &listc, &listv); if (result != TCL_OK) { goto done; } @@ -3549,7 +3549,7 @@ Tcl_LsearchObjCmd( * 1844789] */ - TclListObjGetElements(NULL, objv[objc - 2], &listc, &listv); + TclListObjGetElementsM(NULL, objv[objc - 2], &listc, &listv); break; case REAL: result = Tcl_GetDoubleFromObj(interp, patObj, &patDouble); @@ -3562,7 +3562,7 @@ Tcl_LsearchObjCmd( * 1844789] */ - TclListObjGetElements(NULL, objv[objc - 2], &listc, &listv); + TclListObjGetElementsM(NULL, objv[objc - 2], &listc, &listv); break; } } else { @@ -4073,7 +4073,7 @@ Tcl_LsortObjCmd( sortInfo.resultCode = TCL_ERROR; goto done; } - if (TclListObjGetElements(interp, objv[i+1], &sortindex, + if (TclListObjGetElementsM(interp, objv[i+1], &sortindex, &indexv) != TCL_OK) { sortInfo.resultCode = TCL_ERROR; goto done; @@ -4165,7 +4165,7 @@ Tcl_LsortObjCmd( if (indexPtr) { Tcl_Obj **indexv; - TclListObjGetElements(interp, indexPtr, &sortInfo.indexc, &indexv); + TclListObjGetElementsM(interp, indexPtr, &sortInfo.indexc, &indexv); switch (sortInfo.indexc) { case 0: sortInfo.indexv = NULL; @@ -4225,7 +4225,7 @@ Tcl_LsortObjCmd( sortInfo.compareCmdPtr = newCommandPtr; } - sortInfo.resultCode = TclListObjGetElements(interp, listObj, + sortInfo.resultCode = TclListObjGetElementsM(interp, listObj, &length, &listObjPtrs); if (sortInfo.resultCode != TCL_OK || length <= 0) { goto done; @@ -4642,10 +4642,10 @@ SortCompare( * Replace them and evaluate the result. */ - TclListObjLength(infoPtr->interp, infoPtr->compareCmdPtr, &objc); + TclListObjLengthM(infoPtr->interp, infoPtr->compareCmdPtr, &objc); Tcl_ListObjReplace(infoPtr->interp, infoPtr->compareCmdPtr, objc - 2, 2, 2, paramObjv); - TclListObjGetElements(infoPtr->interp, infoPtr->compareCmdPtr, + TclListObjGetElementsM(infoPtr->interp, infoPtr->compareCmdPtr, &objc, &objv); infoPtr->resultCode = Tcl_EvalObjv(infoPtr->interp, objc, objv, 0); @@ -4855,7 +4855,7 @@ SelectObjFromSublist( int listLen, index; Tcl_Obj *currentObj; - if (TclListObjLength(infoPtr->interp, objPtr, &listLen) != TCL_OK) { + if (TclListObjLengthM(infoPtr->interp, objPtr, &listLen) != TCL_OK) { infoPtr->resultCode = TCL_ERROR; return NULL; } diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c index 29a73cf..a9d1f11 100644 --- a/generic/tclCmdMZ.c +++ b/generic/tclCmdMZ.c @@ -674,7 +674,7 @@ Tcl_RegsubObjCmd( * object. (If they aren't, that's cheap to do.) */ - if (TclListObjLength(interp, objv[2], &numParts) != TCL_OK) { + if (TclListObjLengthM(interp, objv[2], &numParts) != TCL_OK) { return TCL_ERROR; } if (numParts < 1) { @@ -776,7 +776,7 @@ Tcl_RegsubObjCmd( Tcl_Obj **args = NULL, **parts; int numArgs; - TclListObjGetElements(interp, subPtr, &numParts, &parts); + TclListObjGetElementsM(interp, subPtr, &numParts, &parts); numArgs = numParts + info.nsubs + 1; args = (Tcl_Obj **)ckalloc(sizeof(Tcl_Obj*) * numArgs); memcpy(args, parts, sizeof(Tcl_Obj*) * numParts); @@ -1811,7 +1811,7 @@ StringIsCmd( * well-formed lists. */ - if (TCL_OK == TclListObjLength(NULL, objPtr, &length2)) { + if (TCL_OK == TclListObjLengthM(NULL, objPtr, &length2)) { break; } @@ -2025,7 +2025,7 @@ StringMapCmd( } Tcl_DictObjDone(&search); } else { - if (TclListObjGetElements(interp, objv[objc-2], &mapElemc, + if (TclListObjGetElementsM(interp, objv[objc-2], &mapElemc, &mapElemv) != TCL_OK) { return TCL_ERROR; } @@ -3610,7 +3610,7 @@ TclNRSwitchObjCmd( Tcl_Obj **listv; blist = objv[0]; - if (TclListObjGetElements(interp, objv[0], &objc, &listv) != TCL_OK) { + if (TclListObjGetElementsM(interp, objv[0], &objc, &listv) != TCL_OK) { return TCL_ERROR; } @@ -3995,7 +3995,7 @@ Tcl_ThrowObjCmd( * The type must be a list of at least length 1. */ - if (TclListObjLength(interp, objv[1], &len) != TCL_OK) { + if (TclListObjLengthM(interp, objv[1], &len) != TCL_OK) { return TCL_ERROR; } else if (len < 1) { Tcl_SetObjResult(interp, Tcl_NewStringObj( @@ -4783,7 +4783,7 @@ TclNRTryObjCmd( return TCL_ERROR; } code = 1; - if (TclListObjLength(NULL, objv[i+1], &dummy) != TCL_OK) { + if (TclListObjLengthM(NULL, objv[i+1], &dummy) != TCL_OK) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "bad prefix '%s': must be a list", Tcl_GetString(objv[i+1]))); @@ -4795,7 +4795,7 @@ TclNRTryObjCmd( info[2] = objv[i+1]; commonHandler: - if (TclListObjLength(interp, objv[i+2], &dummy) != TCL_OK) { + if (TclListObjLengthM(interp, objv[i+2], &dummy) != TCL_OK) { Tcl_DecrRefCount(handlersObj); return TCL_ERROR; } @@ -4945,12 +4945,12 @@ TryPostBody( int found = 0; Tcl_Obj **handlers, **info; - TclListObjGetElements(NULL, handlersObj, &numHandlers, &handlers); + TclListObjGetElementsM(NULL, handlersObj, &numHandlers, &handlers); for (i=0 ; i 0) { Tcl_Obj *varName; diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c index a45c059..2d78ab6 100644 --- a/generic/tclCompCmds.c +++ b/generic/tclCompCmds.c @@ -301,7 +301,7 @@ TclCompileArraySetCmd( TclNewObj(literalObj); isDataLiteral = TclWordKnownAtCompileTime(dataTokenPtr, literalObj); isDataValid = (isDataLiteral - && TclListObjLength(NULL, literalObj, &len) == TCL_OK); + && TclListObjLengthM(NULL, literalObj, &len) == TCL_OK); isDataEven = (isDataValid && (len & 1) == 0); /* @@ -892,7 +892,7 @@ TclCompileConcatCmd( const char *bytes; int len; - TclListObjGetElements(NULL, listObj, &len, &objs); + TclListObjGetElementsM(NULL, listObj, &len, &objs); objPtr = Tcl_ConcatObj(len, objs); Tcl_DecrRefCount(listObj); bytes = TclGetStringFromObj(objPtr, &len); @@ -2750,7 +2750,7 @@ CompileEachloopCmd( */ if (!TclWordKnownAtCompileTime(tokenPtr, varListObj) || - TCL_OK != TclListObjLength(NULL, varListObj, &numVars) || + TCL_OK != TclListObjLengthM(NULL, varListObj, &numVars) || numVars == 0) { code = TCL_ERROR; goto done; diff --git a/generic/tclCompCmdsSZ.c b/generic/tclCompCmdsSZ.c index a637786..29e48eb 100644 --- a/generic/tclCompCmdsSZ.c +++ b/generic/tclCompCmdsSZ.c @@ -938,7 +938,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 (TclListObjGetElementsM(NULL, mapObj, &len, &objv) != TCL_OK) { Tcl_DecrRefCount(mapObj); return TclCompileBasic2ArgCmd(interp, parsePtr, cmdPtr, envPtr); } else if (len != 2) { @@ -2731,7 +2731,7 @@ TclCompileThrowCmd( CompileWord(envPtr, msgToken, interp, 2); codeIsList = codeKnown && (TCL_OK == - TclListObjLength(interp, objPtr, &len)); + TclListObjLengthM(interp, objPtr, &len)); codeIsValid = codeIsList && (len != 0); if (codeIsValid) { @@ -2864,7 +2864,7 @@ TclCompileTryCmd( TclNewObj(tmpObj); Tcl_IncrRefCount(tmpObj); if (!TclWordKnownAtCompileTime(tokenPtr, tmpObj) - || TclListObjLength(NULL, tmpObj, &objc) != TCL_OK + || TclListObjLengthM(NULL, tmpObj, &objc) != TCL_OK || (objc == 0)) { TclDecrRefCount(tmpObj); goto failedToCompile; @@ -2907,7 +2907,7 @@ TclCompileTryCmd( TclDecrRefCount(tmpObj); goto failedToCompile; } - if (TclListObjGetElements(NULL, tmpObj, &objc, &objv) != TCL_OK + if (TclListObjGetElementsM(NULL, tmpObj, &objc, &objv) != TCL_OK || (objc > 2)) { TclDecrRefCount(tmpObj); goto failedToCompile; @@ -3121,7 +3121,7 @@ IssueTryClausesInstructions( JUMP4( JUMP_FALSE, notCodeJumpSource); if (matchClauses[i]) { const char *p; - TclListObjLength(NULL, matchClauses[i], &len); + TclListObjLengthM(NULL, matchClauses[i], &len); /* * Match the errorcode according to try/trap rules. @@ -3332,7 +3332,7 @@ IssueTryClausesFinallyInstructions( OP( EQ); JUMP4( JUMP_FALSE, notCodeJumpSource); if (matchClauses[i]) { - TclListObjLength(NULL, matchClauses[i], &len); + TclListObjLengthM(NULL, matchClauses[i], &len); /* * Match the errorcode according to try/trap rules. diff --git a/generic/tclCompExpr.c b/generic/tclCompExpr.c index 23d8711..06b4b05 100644 --- a/generic/tclCompExpr.c +++ b/generic/tclCompExpr.c @@ -2223,8 +2223,8 @@ TclCompileExpr( TclAdvanceLines(&envPtr->line, script, script + TclParseAllWhiteSpace(script, numBytes)); - TclListObjGetElements(NULL, litList, &objc, (Tcl_Obj ***)&litObjv); - TclListObjGetElements(NULL, funcList, &objc, &funcObjv); + TclListObjGetElementsM(NULL, litList, &objc, (Tcl_Obj ***)&litObjv); + TclListObjGetElementsM(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 b93b141..019c69b 100644 --- a/generic/tclDictObj.c +++ b/generic/tclDictObj.c @@ -616,7 +616,7 @@ SetDictFromAny( Tcl_Obj **objv; /* Cannot fail, we already know the Tcl_ObjType is "list". */ - TclListObjGetElements(NULL, objPtr, &objc, &objv); + TclListObjGetElementsM(NULL, objPtr, &objc, &objv); if (objc & 1) { goto missingValue; } @@ -2480,7 +2480,7 @@ DictForNRCmd( * Parse arguments. */ - if (TclListObjGetElements(interp, objv[1], &varc, &varv) != TCL_OK) { + if (TclListObjGetElementsM(interp, objv[1], &varc, &varv) != TCL_OK) { return TCL_ERROR; } if (varc != 2) { @@ -2499,7 +2499,7 @@ DictForNRCmd( TclStackFree(interp, searchPtr); return TCL_OK; } - TclListObjGetElements(NULL, objv[1], &varc, &varv); + TclListObjGetElementsM(NULL, objv[1], &varc, &varv); keyVarObj = varv[0]; valueVarObj = varv[1]; scriptObj = objv[3]; @@ -2674,7 +2674,7 @@ DictMapNRCmd( * Parse arguments. */ - if (TclListObjGetElements(interp, objv[1], &varc, &varv) != TCL_OK) { + if (TclListObjGetElementsM(interp, objv[1], &varc, &varv) != TCL_OK) { return TCL_ERROR; } if (varc != 2) { @@ -2700,7 +2700,7 @@ DictMapNRCmd( return TCL_OK; } TclNewObj(storagePtr->accumulatorObj); - TclListObjGetElements(NULL, objv[1], &varc, &varv); + TclListObjGetElementsM(NULL, objv[1], &varc, &varv); storagePtr->keyVarObj = varv[0]; storagePtr->valueVarObj = varv[1]; storagePtr->scriptObj = objv[3]; @@ -3113,7 +3113,7 @@ DictFilterCmd( * copying from the "dict for" implementation has occurred! */ - if (TclListObjGetElements(interp, objv[3], &varc, &varv) != TCL_OK) { + if (TclListObjGetElementsM(interp, objv[3], &varc, &varv) != TCL_OK) { return TCL_ERROR; } if (varc != 2) { @@ -3374,7 +3374,7 @@ FinalizeDictUpdate( * an instruction to remove the key. */ - TclListObjGetElements(NULL, argsObj, &objc, &objv); + TclListObjGetElementsM(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 (TclListObjLengthM(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 (TclListObjGetElementsM(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 (TclListObjLengthM(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 (TclListObjLengthM(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 (TclListObjLengthM(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 (TclListObjGetElementsM(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 (TclListObjLengthM(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 (TclListObjLengthM(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 (TclListObjLengthM(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 (TclListObjLengthM(interp, unknownList, &length) != TCL_OK) { return TCL_ERROR; } if (length < 1) { @@ -1890,7 +1890,7 @@ NsEnsembleImplementationCmdNR( Tcl_Obj **copyObjv; int copyObjc, prefixObjc; - TclListObjLength(NULL, prefixObj, &prefixObjc); + TclListObjLengthM(NULL, prefixObj, &prefixObjc); if (objc == 2) { copyPtr = TclListObjCopy(NULL, prefixObj); @@ -1924,7 +1924,7 @@ NsEnsembleImplementationCmdNR( */ TclSkipTailcall(interp); - TclListObjGetElements(NULL, copyPtr, ©Objc, ©Objv); + TclListObjGetElementsM(NULL, copyPtr, ©Objc, ©Objv); ((Interp *)interp)->lookupNsPtr = ensemblePtr->nsPtr; return TclNREvalObjv(interp, copyObjc, copyObjv, TCL_EVAL_INVOKE, NULL); } @@ -2299,7 +2299,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 71ca814..c8fe92e 100644 --- a/generic/tclEvent.c +++ b/generic/tclEvent.c @@ -230,7 +230,7 @@ HandleBgErrors( errPtr = assocPtr->firstBgPtr; - TclListObjGetElements(NULL, copyObj, &prefixObjc, &prefixObjv); + TclListObjGetElementsM(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 1f72d63..027b8f3 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -2729,7 +2729,7 @@ TEBCresume( objPtr = OBJ_AT_TOS; TRACE(("\"%.30s\" => ", O2S(objPtr))); - if (TclListObjGetElements(interp, objPtr, &objc, &objv) != TCL_OK) { + if (TclListObjGetElementsM(interp, objPtr, &objc, &objv) != TCL_OK) { TRACE_ERROR(interp); goto gotError; } @@ -3024,7 +3024,7 @@ TEBCresume( TclMarkTailcall(interp); TclNRAddCallback(interp, TclClearRootEnsemble, NULL, NULL, NULL, NULL); - TclListObjGetElements(NULL, objPtr, &objc, &objv); + TclListObjGetElementsM(NULL, objPtr, &objc, &objv); TclNRAddCallback(interp, TclNRReleaseValues, objPtr, NULL, NULL, NULL); return TclNREvalObjv(interp, objc, objv, TCL_EVAL_INVOKE, NULL); @@ -3435,7 +3435,7 @@ TEBCresume( varPtr = varPtr->value.linkPtr; } TRACE(("%u <- \"%.30s\" => ", opnd, O2S(valuePtr))); - if (TclListObjGetElements(interp, valuePtr, &objc, &objv) + if (TclListObjGetElementsM(interp, valuePtr, &objc, &objv) != TCL_OK) { TRACE_ERROR(interp); goto gotError; @@ -3461,7 +3461,7 @@ TEBCresume( } TRACE(("%u \"%.30s\" \"%.30s\" => ", opnd, O2S(part2Ptr), O2S(valuePtr))); - if (TclListObjGetElements(interp, valuePtr, &objc, &objv) + if (TclListObjGetElementsM(interp, valuePtr, &objc, &objv) != TCL_OK) { TRACE_ERROR(interp); goto gotError; @@ -3503,7 +3503,7 @@ TEBCresume( lappendListDirect: objResultPtr = varPtr->value.objPtr; - if (TclListObjLength(interp, objResultPtr, &len) != TCL_OK) { + if (TclListObjLengthM(interp, objResultPtr, &len) != TCL_OK) { TRACE_ERROR(interp); goto gotError; } @@ -3524,7 +3524,7 @@ TEBCresume( lappendList: opnd = -1; - if (TclListObjGetElements(interp, valuePtr, &objc, &objv) + if (TclListObjGetElementsM(interp, valuePtr, &objc, &objv) != TCL_OK) { TRACE_ERROR(interp); goto gotError; @@ -3562,7 +3562,7 @@ TEBCresume( if (!objResultPtr) { valueToAssign = valuePtr; - } else if (TclListObjLength(interp, objResultPtr, &len)!=TCL_OK) { + } else if (TclListObjLengthM(interp, objResultPtr, &len)!=TCL_OK) { TRACE_ERROR(interp); goto gotError; } else { @@ -4846,7 +4846,7 @@ TEBCresume( case INST_LIST_LENGTH: TRACE(("\"%.30s\" => ", O2S(OBJ_AT_TOS))); - if (TclListObjLength(interp, OBJ_AT_TOS, &length) != TCL_OK) { + if (TclListObjLengthM(interp, OBJ_AT_TOS, &length) != TCL_OK) { TRACE_ERROR(interp); goto gotError; } @@ -4863,7 +4863,7 @@ TEBCresume( * Extract the desired list element. */ - if ((TclListObjGetElements(interp, valuePtr, &objc, &objv) == TCL_OK) + if ((TclListObjGetElementsM(interp, valuePtr, &objc, &objv) == TCL_OK) && !TclHasInternalRep(value2Ptr, &tclListType)) { int code; @@ -4908,7 +4908,7 @@ TEBCresume( * in the process. */ - if (TclListObjGetElements(interp, valuePtr, &objc, &objv) != TCL_OK) { + if (TclListObjGetElementsM(interp, valuePtr, &objc, &objv) != TCL_OK) { TRACE_ERROR(interp); goto gotError; } @@ -5047,7 +5047,7 @@ TEBCresume( * in the process. */ - if (TclListObjLength(interp, valuePtr, &objc) != TCL_OK) { + if (TclListObjLengthM(interp, valuePtr, &objc) != TCL_OK) { TRACE_ERROR(interp); goto gotError; } @@ -5112,7 +5112,7 @@ TEBCresume( s1 = TclGetStringFromObj(valuePtr, &s1len); TRACE(("\"%.30s\" \"%.30s\" => ", O2S(valuePtr), O2S(value2Ptr))); - if (TclListObjLength(interp, value2Ptr, &length) != TCL_OK) { + if (TclListObjLengthM(interp, value2Ptr, &length) != TCL_OK) { TRACE_ERROR(interp); goto gotError; } @@ -6516,7 +6516,7 @@ TEBCresume( listVarPtr = LOCAL(listTmpIndex); listPtr = listVarPtr->value.objPtr; - if (TclListObjLength(interp, listPtr, &listLen) != TCL_OK) { + if (TclListObjLengthM(interp, listPtr, &listLen) != TCL_OK) { TRACE_APPEND(("ERROR converting list %ld, \"%.30s\": %s\n", i, O2S(listPtr), O2S(Tcl_GetObjResult(interp)))); goto gotError; @@ -6544,7 +6544,7 @@ TEBCresume( listVarPtr = LOCAL(listTmpIndex); listPtr = TclListObjCopy(NULL, listVarPtr->value.objPtr); - TclListObjGetElements(interp, listPtr, &listLen, &elements); + TclListObjGetElementsM(interp, listPtr, &listLen, &elements); valIndex = (iterNum * numVars); for (j = 0; j < numVars; j++) { @@ -6635,7 +6635,7 @@ TEBCresume( varListPtr = infoPtr->varLists[i]; numVars = varListPtr->numVars; listPtr = OBJ_AT_DEPTH(listTmpDepth); - if (TclListObjLength(interp, listPtr, &listLen) != TCL_OK) { + if (TclListObjLengthM(interp, listPtr, &listLen) != TCL_OK) { TRACE_APPEND(("ERROR converting list %ld, \"%s\": %s", i, O2S(listPtr), O2S(Tcl_GetObjResult(interp)))); goto gotError; @@ -6716,7 +6716,7 @@ TEBCresume( numVars = varListPtr->numVars; listPtr = OBJ_AT_DEPTH(listTmpDepth); - TclListObjGetElements(interp, listPtr, &listLen, &elements); + TclListObjGetElementsM(interp, listPtr, &listLen, &elements); valIndex = (iterNum * numVars); for (j = 0; j < numVars; j++) { @@ -7328,7 +7328,7 @@ TEBCresume( } } Tcl_IncrRefCount(dictPtr); - if (TclListObjGetElements(interp, OBJ_AT_TOS, &length, + if (TclListObjGetElementsM(interp, OBJ_AT_TOS, &length, &keyPtrPtr) != TCL_OK) { TRACE_ERROR(interp); goto gotError; @@ -7388,7 +7388,7 @@ TEBCresume( NEXT_INST_F(9, 1, 0); } if (Tcl_DictObjSize(interp, dictPtr, &length) != TCL_OK - || TclListObjGetElements(interp, OBJ_AT_TOS, &length, + || TclListObjGetElementsM(interp, OBJ_AT_TOS, &length, &keyPtrPtr) != TCL_OK) { TRACE_ERROR(interp); goto gotError; @@ -7447,7 +7447,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 (TclListObjGetElementsM(interp, listPtr, &objc, &objv) != TCL_OK) { TRACE_ERROR(interp); goto gotError; } @@ -7465,7 +7465,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 (TclListObjGetElementsM(interp, listPtr, &objc, &objv) != TCL_OK) { TRACE_ERROR(interp); TclDecrRefCount(keysPtr); goto gotError; @@ -7496,7 +7496,7 @@ TEBCresume( varPtr = LOCAL(opnd); TRACE(("%u <- \"%.30s\" \"%.30s\" => ", opnd, O2S(valuePtr), O2S(keysPtr))); - if (TclListObjGetElements(interp, listPtr, &objc, &objv) != TCL_OK) { + if (TclListObjGetElementsM(interp, listPtr, &objc, &objv) != TCL_OK) { TRACE_ERROR(interp); goto gotError; } diff --git a/generic/tclFCmd.c b/generic/tclFCmd.c index 1a67155..6eb6644 100644 --- a/generic/tclFCmd.c +++ b/generic/tclFCmd.c @@ -1006,7 +1006,7 @@ TclFileAttrsCmd( * Use objStrings as a list object. */ - if (TclListObjLength(interp, objStrings, &numObjStrings) != TCL_OK) { + if (TclListObjLengthM(interp, objStrings, &numObjStrings) != TCL_OK) { goto end; } attributeStringsAllocated = (const char **) diff --git a/generic/tclFileName.c b/generic/tclFileName.c index 1603951..266e31e 100644 --- a/generic/tclFileName.c +++ b/generic/tclFileName.c @@ -517,7 +517,7 @@ TclpNativeSplitPath( */ if (lenPtr != NULL) { - TclListObjLength(NULL, resultPtr, lenPtr); + TclListObjLengthM(NULL, resultPtr, lenPtr); } return resultPtr; } @@ -1332,7 +1332,7 @@ Tcl_GlobObjCmd( return TCL_ERROR; } typePtr = objv[i+1]; - if (TclListObjLength(interp, typePtr, &length) != TCL_OK) { + if (TclListObjLengthM(interp, typePtr, &length) != TCL_OK) { return TCL_ERROR; } i++; @@ -1454,7 +1454,7 @@ Tcl_GlobObjCmd( * platform. */ - TclListObjLength(interp, typePtr, &length); + TclListObjLengthM(interp, typePtr, &length); if (length <= 0) { goto skipTypes; } @@ -1524,7 +1524,7 @@ Tcl_GlobObjCmd( } else { Tcl_Obj *item; - if ((TclListObjLength(NULL, look, &len) == TCL_OK) + if ((TclListObjLengthM(NULL, look, &len) == TCL_OK) && (len == 3)) { Tcl_ListObjIndex(interp, look, 0, &item); if (!strcmp("macintosh", Tcl_GetString(item))) { @@ -1631,7 +1631,7 @@ Tcl_GlobObjCmd( } if ((globFlags & TCL_GLOBMODE_NO_COMPLAIN) == 0) { - if (TclListObjLength(interp, Tcl_GetObjResult(interp), + if (TclListObjLengthM(interp, Tcl_GetObjResult(interp), &length) != TCL_OK) { /* * This should never happen. Maybe we should be more dramatic. @@ -2014,7 +2014,7 @@ TclGlob( } } - TclListObjGetElements(NULL, filenamesObj, &objc, &objv); + TclListObjGetElementsM(NULL, filenamesObj, &objc, &objv); for (i = 0; i< objc; i++) { int len; const char *oldStr = TclGetStringFromObj(objv[i], &len); @@ -2343,13 +2343,13 @@ DoGlob( int subdirc, i, repair = -1; Tcl_Obj **subdirv; - result = TclListObjGetElements(interp, subdirsPtr, + result = TclListObjGetElementsM(interp, subdirsPtr, &subdirc, &subdirv); for (i=0; result==TCL_OK && ifsPtr->listVolumesProc(); if (thisFsVolumes != NULL) { - if (TclListObjLength(NULL, thisFsVolumes, &numVolumes) + if (TclListObjLengthM(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 e1526ad..3b74e02 100644 --- a/generic/tclIndexObj.c +++ b/generic/tclIndexObj.c @@ -190,7 +190,7 @@ GetIndexFromObjList( * of the code there. This is a bit ineffiecient but simpler. */ - result = TclListObjGetElements(interp, tableObjPtr, &objc, &objv); + result = TclListObjGetElementsM(interp, tableObjPtr, &objc, &objv); if (result != TCL_OK) { return result; } @@ -618,7 +618,7 @@ PrefixMatchObjCmd( return TCL_ERROR; } i++; - result = TclListObjLength(interp, objv[i], &errorLength); + result = TclListObjLengthM(interp, objv[i], &errorLength); if (result != TCL_OK) { return TCL_ERROR; } @@ -642,7 +642,7 @@ PrefixMatchObjCmd( * error case regardless of level. */ - result = TclListObjLength(interp, tablePtr, &dummyLength); + result = TclListObjLengthM(interp, tablePtr, &dummyLength); if (result != TCL_OK) { return result; } @@ -707,7 +707,7 @@ PrefixAllObjCmd( return TCL_ERROR; } - result = TclListObjGetElements(interp, objv[1], &tableObjc, &tableObjv); + result = TclListObjGetElementsM(interp, objv[1], &tableObjc, &tableObjv); if (result != TCL_OK) { return result; } @@ -764,7 +764,7 @@ PrefixLongestObjCmd( return TCL_ERROR; } - result = TclListObjGetElements(interp, objv[1], &tableObjc, &tableObjv); + result = TclListObjGetElementsM(interp, objv[1], &tableObjc, &tableObjv); if (result != TCL_OK) { return result; } diff --git a/generic/tclInt.h b/generic/tclInt.h index 6b4f33a..59106cd 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -2464,12 +2464,12 @@ typedef struct List { #define ListObjIsCanonical(listPtr) \ (((listPtr)->bytes == NULL) || ListRepPtr(listPtr)->canonicalFlag) -#define TclListObjGetElements(interp, listPtr, objcPtr, objvPtr) \ +#define TclListObjGetElementsM(interp, listPtr, objcPtr, objvPtr) \ (((listPtr)->typePtr == &tclListType) \ ? ((ListObjGetElements((listPtr), *(objcPtr), *(objvPtr))), TCL_OK)\ : Tcl_ListObjGetElements((interp), (listPtr), (objcPtr), (objvPtr))) -#define TclListObjLength(interp, listPtr, lenPtr) \ +#define TclListObjLengthM(interp, listPtr, lenPtr) \ (((listPtr)->typePtr == &tclListType) \ ? ((ListObjLength((listPtr), *(lenPtr))), TCL_OK)\ : Tcl_ListObjLength((interp), (listPtr), (lenPtr))) diff --git a/generic/tclInterp.c b/generic/tclInterp.c index e590775..b87bf7c 100644 --- a/generic/tclInterp.c +++ b/generic/tclInterp.c @@ -2315,7 +2315,7 @@ GetInterp( Tcl_Interp *searchInterp; /* Interim storage for interp. to find. */ InterpInfo *parentInfoPtr; - if (TclListObjGetElements(interp, pathPtr, &objc, &objv) != TCL_OK) { + if (TclListObjGetElementsM(interp, pathPtr, &objc, &objv) != TCL_OK) { return NULL; } @@ -2371,7 +2371,7 @@ ChildBgerror( if (objc) { int length; - if (TCL_ERROR == TclListObjLength(NULL, objv[0], &length) + if (TCL_ERROR == TclListObjLengthM(NULL, objv[0], &length) || (length < 1)) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "cmdPrefix must be list of length >= 1", -1)); @@ -2418,7 +2418,7 @@ ChildCreate( int isNew, objc; Tcl_Obj **objv; - if (TclListObjGetElements(interp, pathPtr, &objc, &objv) != TCL_OK) { + if (TclListObjGetElementsM(interp, pathPtr, &objc, &objv) != TCL_OK) { return NULL; } if (objc < 2) { diff --git a/generic/tclLink.c b/generic/tclLink.c index ee77654..384fcf3 100644 --- a/generic/tclLink.c +++ b/generic/tclLink.c @@ -947,7 +947,7 @@ LinkTraceProc( */ if (linkPtr->flags & LINK_ALLOC_LAST) { - if (TclListObjGetElements(NULL, (valueObj), &objc, &objv) == TCL_ERROR + if (TclListObjGetElementsM(NULL, (valueObj), &objc, &objv) == TCL_ERROR || objc != linkPtr->numElems) { return (char *) "wrong dimension"; } diff --git a/generic/tclListObj.c b/generic/tclListObj.c index c66fd1e..597ab4a 100644 --- a/generic/tclListObj.c +++ b/generic/tclListObj.c @@ -470,7 +470,7 @@ TclListObjRange( int listLen, i, newLen; List *listRepPtr; - TclListObjGetElements(NULL, listPtr, &listLen, &elemPtrs); + TclListObjGetElementsM(NULL, listPtr, &listLen, &elemPtrs); if (fromIdx < 0) { fromIdx = 0; @@ -628,7 +628,7 @@ Tcl_ListObjAppendList( * Pull the elements to append from elemListPtr. */ - if (TCL_OK != TclListObjGetElements(interp, elemListPtr, &objc, &objv)) { + if (TCL_OK != TclListObjGetElementsM(interp, elemListPtr, &objc, &objv)) { return TCL_ERROR; } @@ -1364,7 +1364,7 @@ TclLindexFlat( break; } - TclListObjGetElements(NULL, sublistCopy, &listLen, &elemPtrs); + TclListObjGetElementsM(NULL, sublistCopy, &listLen, &elemPtrs); if (TclGetIntForIndexM(interp, indexArray[i], /*endValue*/ listLen-1, &index) == TCL_OK) { @@ -1464,7 +1464,7 @@ TclLsetList( return TclLsetFlat(interp, listPtr, 1, &indexArgPtr, valuePtr); } - TclListObjGetElements(NULL, indexArgPtr, &indexCount, &indices); + TclListObjGetElementsM(NULL, indexArgPtr, &indexCount, &indices); /* * Let TclLsetFlat handle the actual lset'ting. @@ -1581,7 +1581,7 @@ TclLsetFlat( * Check for the possible error conditions... */ - if (TclListObjGetElements(interp, subListPtr, &elemCount, &elemPtrs) + if (TclListObjGetElementsM(interp, subListPtr, &elemCount, &elemPtrs) != TCL_OK) { /* ...the sublist we're indexing into isn't a list at all. */ result = TCL_ERROR; @@ -1728,7 +1728,7 @@ TclLsetFlat( */ len = -1; - TclListObjLength(NULL, subListPtr, &len); + TclListObjLengthM(NULL, subListPtr, &len); if (valuePtr == NULL) { Tcl_ListObjReplace(NULL, subListPtr, index, 1, 0, NULL); } else if (index == len) { diff --git a/generic/tclNamesp.c b/generic/tclNamesp.c index 1782a34..6269bbe 100644 --- a/generic/tclNamesp.c +++ b/generic/tclNamesp.c @@ -4065,7 +4065,7 @@ 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 (TclListObjGetElementsM(interp, objv[1], &nsObjc, &nsObjv) != TCL_OK) { goto badNamespace; } if (nsObjc != 0) { @@ -4433,7 +4433,7 @@ Tcl_SetNamespaceUnknownHandler( */ if (handlerPtr != NULL) { - if (TclListObjLength(interp, handlerPtr, &lstlen) != TCL_OK) { + if (TclListObjLengthM(interp, handlerPtr, &lstlen) != TCL_OK) { /* * Not a list. */ @@ -5010,7 +5010,7 @@ TclLogCommandInfo( int len; iPtr->resetErrorStack = 0; - TclListObjLength(interp, iPtr->errorStack, &len); + TclListObjLengthM(interp, iPtr->errorStack, &len); /* * Reset while keeping the list internalrep as much as possible. @@ -5095,7 +5095,7 @@ TclErrorStackResetIf( int len; iPtr->resetErrorStack = 0; - TclListObjLength(interp, iPtr->errorStack, &len); + TclListObjLengthM(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 4af23c2..42c6637 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); - TclListObjGetElements(NULL, objPtr, &dummy, &objs); + TclListObjGetElementsM(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 (TclListObjGetElements(interp, objv[0], &filterc, + } else if (TclListObjGetElementsM(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 (TclListObjGetElements(interp, objv[0], &mixinc, + } else if (TclListObjGetElementsM(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 (TclListObjGetElements(interp, objv[0], &superc, + } else if (TclListObjGetElementsM(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 (TclListObjGetElements(interp, objv[0], &varc, + } else if (TclListObjGetElementsM(interp, objv[0], &varc, &varv) != TCL_OK) { return TCL_ERROR; } @@ -2828,7 +2828,7 @@ ObjFilterSet( return TCL_ERROR; } objv += Tcl_ObjectContextSkippedArgs(context); - if (TclListObjGetElements(interp, objv[0], &filterc, + if (TclListObjGetElementsM(interp, objv[0], &filterc, &filterv) != TCL_OK) { return TCL_ERROR; } @@ -2902,7 +2902,7 @@ ObjMixinSet( return TCL_ERROR; } objv += Tcl_ObjectContextSkippedArgs(context); - if (TclListObjGetElements(interp, objv[0], &mixinc, + if (TclListObjGetElementsM(interp, objv[0], &mixinc, &mixinv) != TCL_OK) { return TCL_ERROR; } @@ -2992,7 +2992,7 @@ ObjVarsSet( return TCL_ERROR; } objv += Tcl_ObjectContextSkippedArgs(context); - if (TclListObjGetElements(interp, objv[0], &varc, + if (TclListObjGetElementsM(interp, objv[0], &varc, &varv) != TCL_OK) { return TCL_ERROR; } diff --git a/generic/tclOOMethod.c b/generic/tclOOMethod.c index 8a71c6f..ae1f3bd 100644 --- a/generic/tclOOMethod.c +++ b/generic/tclOOMethod.c @@ -339,7 +339,7 @@ TclOONewProcInstanceMethod( ProcedureMethod *pmPtr; Tcl_Method method; - if (TclListObjLength(interp, argsObj, &argsLen) != TCL_OK) { + if (TclListObjLengthM(interp, argsObj, &argsLen) != TCL_OK) { return NULL; } pmPtr = (ProcedureMethod *)ckalloc(sizeof(ProcedureMethod)); @@ -397,7 +397,7 @@ TclOONewProcMethod( TclNewObj(argsObj); Tcl_IncrRefCount(argsObj); procName = ""; - } else if (TclListObjLength(interp, argsObj, &argsLen) != TCL_OK) { + } else if (TclListObjLengthM(interp, argsObj, &argsLen) != TCL_OK) { return NULL; } else { procName = (nameObj==NULL ? "" : TclGetString(nameObj)); @@ -1389,7 +1389,7 @@ TclOONewForwardInstanceMethod( int prefixLen; ForwardMethod *fmPtr; - if (TclListObjLength(interp, prefixObj, &prefixLen) != TCL_OK) { + if (TclListObjLengthM(interp, prefixObj, &prefixLen) != TCL_OK) { return NULL; } if (prefixLen < 1) { @@ -1428,7 +1428,7 @@ TclOONewForwardMethod( int prefixLen; ForwardMethod *fmPtr; - if (TclListObjLength(interp, prefixObj, &prefixLen) != TCL_OK) { + if (TclListObjLengthM(interp, prefixObj, &prefixLen) != TCL_OK) { return NULL; } if (prefixLen < 1) { @@ -1476,7 +1476,7 @@ InvokeForwardMethod( * can ignore here. */ - TclListObjGetElements(NULL, fmPtr->prefixObj, &numPrefixes, &prefixObjs); + TclListObjGetElementsM(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 f1f1561..1a9925b 100644 --- a/generic/tclObj.c +++ b/generic/tclObj.c @@ -877,7 +877,7 @@ Tcl_AppendAllObjTypes( * Get the test for a valid list out of the way first. */ - if (TclListObjLength(interp, objPtr, &numElems) != TCL_OK) { + if (TclListObjLengthM(interp, objPtr, &numElems) != TCL_OK) { return TCL_ERROR; } diff --git a/generic/tclPathObj.c b/generic/tclPathObj.c index cb4d0ce..9524f26 100644 --- a/generic/tclPathObj.c +++ b/generic/tclPathObj.c @@ -812,12 +812,12 @@ Tcl_FSJoinPath( int objc; Tcl_Obj **objv; - if (TclListObjLength(NULL, listObj, &objc) != TCL_OK) { + if (TclListObjLengthM(NULL, listObj, &objc) != TCL_OK) { return NULL; } elements = ((elements >= 0) && (elements <= objc)) ? elements : objc; - TclListObjGetElements(NULL, listObj, &objc, &objv); + TclListObjGetElementsM(NULL, listObj, &objc, &objv); res = TclJoinPath(elements, objv, 0); return res; } @@ -2313,7 +2313,7 @@ SetFsPathFromAny( Tcl_Obj **objv; Tcl_Obj *parts = TclpNativeSplitPath(pathPtr, NULL); - TclListObjGetElements(NULL, parts, &objc, &objv); + TclListObjGetElementsM(NULL, parts, &objc, &objv); /* * Skip '~'. It's replaced by its expansion. diff --git a/generic/tclPkg.c b/generic/tclPkg.c index a5708da..fd45cc1 100644 --- a/generic/tclPkg.c +++ b/generic/tclPkg.c @@ -1359,7 +1359,7 @@ TclNRPackageObjCmd( objvListPtr = Tcl_NewListObj(0, NULL); Tcl_IncrRefCount(objvListPtr); Tcl_ListObjAppendElement(interp, objvListPtr, ov); - TclListObjGetElements(interp, objvListPtr, &newobjc, &newObjvPtr); + TclListObjGetElementsM(interp, objvListPtr, &newobjc, &newObjvPtr); Tcl_NRAddCallback(interp, TclNRPackageObjCmdCleanup, objv[3], objvListPtr, NULL,NULL); @@ -1386,7 +1386,7 @@ TclNRPackageObjCmd( Tcl_ListObjAppendElement(interp, objvListPtr, Tcl_DuplicateObj(newobjv[i])); } - TclListObjGetElements(interp, objvListPtr, &newobjc, &newObjvPtr); + TclListObjGetElementsM(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 75687f0..8c65de3 100644 --- a/generic/tclProc.c +++ b/generic/tclProc.c @@ -484,7 +484,7 @@ TclCreateProc( * in the Proc. */ - result = TclListObjGetElements(interp , argsPtr ,&numArgs ,&argArray); + result = TclListObjGetElementsM(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 = TclListObjGetElements(interp, argArray[i], &fieldCount, + result = TclListObjGetElementsM(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 = TclListObjLength(interp, objv[1], &llength); + status = TclListObjLengthM(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. */ @@ -2446,7 +2446,7 @@ SetLambdaFromAny( * length is not 2, then it cannot be converted to lambdaType. */ - result = TclListObjGetElements(NULL, objPtr, &objc, &objv); + result = TclListObjGetElementsM(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 f418c2b..65c087c 100644 --- a/generic/tclProcess.c +++ b/generic/tclProcess.c @@ -533,7 +533,7 @@ ProcessStatusObjCmd( * Only return statuses of provided processes. */ - result = TclListObjGetElements(interp, objv[1], &numPids, &pidObjs); + result = TclListObjGetElementsM(interp, objv[1], &numPids, &pidObjs); if (result != TCL_OK) { return result; } @@ -648,7 +648,7 @@ ProcessPurgeObjCmd( * Purge only provided processes. */ - result = TclListObjGetElements(interp, objv[1], &numPids, &pidObjs); + result = TclListObjGetElementsM(interp, objv[1], &numPids, &pidObjs); if (result != TCL_OK) { return result; } diff --git a/generic/tclResult.c b/generic/tclResult.c index acdcb70..7e108e9 100644 --- a/generic/tclResult.c +++ b/generic/tclResult.c @@ -1328,12 +1328,12 @@ TclProcessReturn( * if someone does [return -errorstack [info errorstack]] */ - if (TclListObjGetElements(interp, valuePtr, &valueObjc, + if (TclListObjGetElementsM(interp, valuePtr, &valueObjc, &valueObjv) == TCL_ERROR) { return TCL_ERROR; } iPtr->resetErrorStack = 0; - TclListObjLength(interp, iPtr->errorStack, &len); + TclListObjLengthM(interp, iPtr->errorStack, &len); /* * Reset while keeping the list internalrep as much as possible. @@ -1490,7 +1490,7 @@ TclMergeReturnOptions( if (valuePtr != NULL) { int length; - if (TCL_ERROR == TclListObjLength(NULL, valuePtr, &length )) { + if (TCL_ERROR == TclListObjLengthM(NULL, valuePtr, &length )) { /* * Value is not a list, which is illegal for -errorcode. */ @@ -1512,7 +1512,7 @@ TclMergeReturnOptions( if (valuePtr != NULL) { int length; - if (TCL_ERROR == TclListObjLength(NULL, valuePtr, &length )) { + if (TCL_ERROR == TclListObjLengthM(NULL, valuePtr, &length )) { /* * Value is not a list, which is illegal for -errorstack. */ @@ -1682,7 +1682,7 @@ Tcl_SetReturnOptions( Tcl_Obj **objv, *mergedOpts; Tcl_IncrRefCount(options); - if (TCL_ERROR == TclListObjGetElements(interp, options, &objc, &objv) + if (TCL_ERROR == TclListObjGetElementsM(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 a7986b0..cda840d 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); + TclListObjLengthM(NULL, objPtr, &length); if (length != 1) { return TCL_ERROR; } diff --git a/generic/tclStringObj.c b/generic/tclStringObj.c index 33f84bd..2fbf854 100644 --- a/generic/tclStringObj.c +++ b/generic/tclStringObj.c @@ -716,7 +716,7 @@ TclCheckEmptyString( } if (TclListObjIsCanonical(objPtr)) { - TclListObjLength(NULL, objPtr, &length); + TclListObjLengthM(NULL, objPtr, &length); return length == 0; } @@ -3190,7 +3190,7 @@ AppendPrintfToObjVA( } } while (seekingConversion); } - TclListObjGetElements(NULL, list, &objc, &objv); + TclListObjGetElementsM(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 535e2c2..e1c03bb 100644 --- a/generic/tclTrace.c +++ b/generic/tclTrace.c @@ -432,7 +432,7 @@ TraceExecutionObjCmd( * pointer to its array of element pointers. */ - result = TclListObjGetElements(interp, objv[4], &listLen, &elemPtrs); + result = TclListObjGetElementsM(interp, objv[4], &listLen, &elemPtrs); if (result != TCL_OK) { return result; } @@ -602,7 +602,7 @@ TraceExecutionObjCmd( TclNewLiteralStringObj(opObj, "leavestep"); Tcl_ListObjAppendElement(NULL, elemObjPtr, opObj); } - TclListObjLength(NULL, elemObjPtr, &numOps); + TclListObjLengthM(NULL, elemObjPtr, &numOps); if (0 == numOps) { Tcl_DecrRefCount(elemObjPtr); continue; @@ -673,7 +673,7 @@ TraceCommandObjCmd( * pointer to its array of element pointers. */ - result = TclListObjGetElements(interp, objv[4], &listLen, &elemPtrs); + result = TclListObjGetElementsM(interp, objv[4], &listLen, &elemPtrs); if (result != TCL_OK) { return result; } @@ -797,7 +797,7 @@ TraceCommandObjCmd( TclNewLiteralStringObj(opObj, "delete"); Tcl_ListObjAppendElement(NULL, elemObjPtr, opObj); } - TclListObjLength(NULL, elemObjPtr, &numOps); + TclListObjLengthM(NULL, elemObjPtr, &numOps); if (0 == numOps) { Tcl_DecrRefCount(elemObjPtr); continue; @@ -872,7 +872,7 @@ TraceVariableObjCmd( * pointer to its array of element pointers. */ - result = TclListObjGetElements(interp, objv[4], &listLen, &elemPtrs); + result = TclListObjGetElementsM(interp, objv[4], &listLen, &elemPtrs); if (result != TCL_OK) { return result; } diff --git a/generic/tclUtil.c b/generic/tclUtil.c index 3537ecc..e9d943b 100644 --- a/generic/tclUtil.c +++ b/generic/tclUtil.c @@ -3786,7 +3786,7 @@ GetEndOffsetFromObj( if ((TclMaxListLength(bytes, -1, NULL) > 1) /* If it's possible, do the full list parse. */ - && (TCL_OK == TclListObjLength(NULL, objPtr, &length)) + && (TCL_OK == TclListObjLengthM(NULL, objPtr, &length)) && (length > 1)) { goto parseError; } diff --git a/generic/tclVar.c b/generic/tclVar.c index 6d948dd..0ab2c55 100644 --- a/generic/tclVar.c +++ b/generic/tclVar.c @@ -2981,7 +2981,7 @@ Tcl_LappendObjCmd( return TCL_ERROR; } } else { - result = TclListObjLength(interp, newValuePtr, &numElems); + result = TclListObjLengthM(interp, newValuePtr, &numElems); if (result != TCL_OK) { return result; } @@ -3039,7 +3039,7 @@ Tcl_LappendObjCmd( createdNewObj = 1; } - result = TclListObjLength(interp, varValuePtr, &numElems); + result = TclListObjLengthM(interp, varValuePtr, &numElems); if (result == TCL_OK) { result = Tcl_ListObjReplace(interp, varValuePtr, numElems, 0, (objc-2), (objv+2)); @@ -3191,7 +3191,7 @@ ArrayForNRCmd( * Parse arguments. */ - if (TclListObjLength(interp, objv[1], &numVars) != TCL_OK) { + if (TclListObjLengthM(interp, objv[1], &numVars) != TCL_OK) { return TCL_ERROR; } @@ -3302,7 +3302,7 @@ ArrayForLoopCallback( goto arrayfordone; } - TclListObjGetElements(NULL, varListObj, &varc, &varv); + TclListObjGetElementsM(NULL, varListObj, &varc, &varv); if (Tcl_ObjSetVar2(interp, varv[0], NULL, keyObj, TCL_LEAVE_ERR_MSG) == NULL) { result = TCL_ERROR; @@ -3842,7 +3842,7 @@ ArrayGetCmd( */ TclNewObj(tmpResObj); - result = TclListObjGetElements(interp, nameLstObj, &count, &nameObjPtr); + result = TclListObjGetElementsM(interp, nameLstObj, &count, &nameObjPtr); if (result != TCL_OK) { goto errorInArrayGet; } @@ -4165,7 +4165,7 @@ ArraySetCmd( int elemLen; Tcl_Obj **elemPtrs, *copyListObj; - result = TclListObjGetElements(interp, arrayElemObj, + result = TclListObjGetElementsM(interp, arrayElemObj, &elemLen, &elemPtrs); if (result != TCL_OK) { return result; diff --git a/generic/tclZipfs.c b/generic/tclZipfs.c index 61dc615..82e125c 100644 --- a/generic/tclZipfs.c +++ b/generic/tclZipfs.c @@ -3044,7 +3044,7 @@ ZipFSMkZipOrImg( } } Tcl_IncrRefCount(list); - if (TclListObjGetElements(interp, list, &lobjc, &lobjv) != TCL_OK) { + if (TclListObjGetElementsM(interp, list, &lobjc, &lobjv) != TCL_OK) { Tcl_DecrRefCount(list); return TCL_ERROR; } diff --git a/generic/tclZlib.c b/generic/tclZlib.c index 6a9a38a..f6d7660 100644 --- a/generic/tclZlib.c +++ b/generic/tclZlib.c @@ -1370,7 +1370,7 @@ Tcl_ZlibStreamGet( Tcl_DecrRefCount(zshPtr->currentInput); zshPtr->currentInput = NULL; } - TclListObjLength(NULL, zshPtr->inData, &listLen); + TclListObjLengthM(NULL, zshPtr->inData, &listLen); if (listLen > 0) { /* * There is more input available, get it from the list and @@ -1419,7 +1419,7 @@ Tcl_ZlibStreamGet( e = inflate(&zshPtr->stream, zshPtr->flush); } }; - TclListObjLength(NULL, zshPtr->inData, &listLen); + TclListObjLengthM(NULL, zshPtr->inData, &listLen); while ((zshPtr->stream.avail_out > 0) && (e == Z_OK || e == Z_BUF_ERROR) && (listLen > 0)) { @@ -1499,7 +1499,7 @@ Tcl_ZlibStreamGet( inflateEnd(&zshPtr->stream); } } else { - TclListObjLength(NULL, zshPtr->outData, &listLen); + TclListObjLengthM(NULL, zshPtr->outData, &listLen); if (count == -1) { count = 0; for (i=0; i dataPos) && - (TclListObjLength(NULL, zshPtr->outData, &listLen) == TCL_OK) + (TclListObjLengthM(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 5c0af8783c940374355b648f2a47176f6c48af25 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 17 May 2022 17:02:17 +0000 Subject: Doc fix --- doc/StringObj.3 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/doc/StringObj.3 b/doc/StringObj.3 index 156618b..c9bdd4a 100644 --- a/doc/StringObj.3 +++ b/doc/StringObj.3 @@ -40,7 +40,7 @@ Tcl_UniChar * int \fBTcl_GetUniChar\fR(\fIobjPtr, index\fR) .sp -int +size_t \fBTcl_GetCharLength\fR(\fIobjPtr\fR) .sp Tcl_Obj * -- cgit v0.12 From 98d911931078d5c87ac0468c2a6f43d9c38918cc Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 18 May 2022 09:05:19 +0000 Subject: Improve doc: error-handling in Dict/List when > 2**31 elements --- doc/DictObj.3 | 3 ++- doc/ListObj.3 | 6 +++++- doc/SplitList.3 | 5 +++-- 3 files changed, 10 insertions(+), 4 deletions(-) diff --git a/doc/DictObj.3 b/doc/DictObj.3 index 73b0da8..ca9847c 100644 --- a/doc/DictObj.3 +++ b/doc/DictObj.3 @@ -138,7 +138,8 @@ converted to a dictionary. \fBTcl_DictObjSize\fR updates the given variable with the number of key/value pairs currently in the given dictionary. The result of this procedure is \fBTCL_OK\fR, or \fBTCL_ERROR\fR if the \fIdictPtr\fR cannot be -converted to a dictionary. +converted to a dictionary or if \fIsizePtr\fR points to a variable of type +\fBint\fR and the dict contains more than 2**31 key/value pairs. .PP \fBTcl_DictObjFirst\fR commences an iteration across all the key/value pairs in the given dictionary, placing the key and value in the diff --git a/doc/ListObj.3 b/doc/ListObj.3 index 09ab3b7..c4aa4bc 100644 --- a/doc/ListObj.3 +++ b/doc/ListObj.3 @@ -153,7 +153,9 @@ address \fIobjcPtr\fR. Similarly, it returns the array pointer by storing it in the address \fIobjvPtr\fR. The memory pointed to is managed by Tcl and should not be freed or written to by the caller. If the list is empty, 0 is stored at \fIobjcPtr\fR -and NULL at \fIobjvPtr\fR. +and NULL at \fIobjvPtr\fR. If \fIobjcPtr\fR points to a variable +of type \fBint\fR and the list contains more than 2**31 elements, the +function returns \fBTCL_ERROR\fR. If \fIlistPtr\fR is not already a list value, \fBTcl_ListObjGetElements\fR will attempt to convert it to one; if the conversion fails, it returns \fBTCL_ERROR\fR and leaves an error message in the interpreter's result @@ -163,6 +165,8 @@ Otherwise it returns \fBTCL_OK\fR after storing the count and array pointer. \fBTcl_ListObjLength\fR returns the number of elements in the list value referenced by \fIlistPtr\fR. It returns this count by storing a value in the address \fIlengthPtr\fR. +If \fIlengthPtr\fR points to a variable of type \fBint\fR and the list +contains more than 2**31 elements, the function returns \fBTCL_ERROR\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/doc/SplitList.3 b/doc/SplitList.3 index 696906c..f56330b 100644 --- a/doc/SplitList.3 +++ b/doc/SplitList.3 @@ -97,8 +97,9 @@ Tcl_Free(argv); .CE .PP \fBTcl_SplitList\fR normally returns \fBTCL_OK\fR, which means the list was -successfully parsed. -If there was a syntax error in \fIlist\fR, then \fBTCL_ERROR\fR is returned +successfully parsed. If \fIsizePtr\fR points to a variable of type +\fBint\fR and the list contains more than 2**31 key/value pairs, or there was +a syntax error in \fIlist\fR, then \fBTCL_ERROR\fR is returned and the interpreter's result will point to an error message describing the problem (if \fIinterp\fR was not NULL). If \fBTCL_ERROR\fR is returned then no memory is allocated and \fI*argvPtr\fR -- cgit v0.12 From 2e04ff831d043373741c9252f3ff791bbc2bbda9 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 18 May 2022 09:06:12 +0000 Subject: doc fix --- doc/SplitPath.3 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/doc/SplitPath.3 b/doc/SplitPath.3 index c011194..5dae109 100644 --- a/doc/SplitPath.3 +++ b/doc/SplitPath.3 @@ -72,7 +72,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_JoinPath\fR is the inverse of \fBTcl_SplitPath\fR: it takes a -- cgit v0.12 From fdedfe57992474d342bf1ecb84bc04ae0fd9aeb2 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 18 May 2022 09:23:49 +0000 Subject: More doc fixes --- doc/DetachPids.3 | 2 +- doc/DictObj.3 | 2 +- doc/FileSystem.3 | 2 +- doc/Limit.3 | 2 +- doc/SetRecLmt.3 | 4 ++-- 5 files changed, 6 insertions(+), 6 deletions(-) diff --git a/doc/DetachPids.3 b/doc/DetachPids.3 index 26075c3..c4d6fa7 100644 --- a/doc/DetachPids.3 +++ b/doc/DetachPids.3 @@ -22,7 +22,7 @@ Tcl_Pid \fBTcl_WaitPid\fR(\fIpid, statusPtr, options\fR) .SH ARGUMENTS .AS Tcl_Pid *statusPtr out -.AP int numPids in +.AP size_t numPids in Number of process ids contained in the array pointed to by \fIpidPtr\fR. .AP int *pidPtr in Address of array containing \fInumPids\fR process ids. diff --git a/doc/DictObj.3 b/doc/DictObj.3 index ca9847c..c03d267 100644 --- a/doc/DictObj.3 +++ b/doc/DictObj.3 @@ -84,7 +84,7 @@ returned, the search record \fImust\fR be passed to Points to a variable that will have a non-zero value written into it when the enumeration of the key/value pairs in a dictionary has completed, and a zero otherwise. -.AP int keyc in +.AP size_t keyc in Indicates the number of keys that will be supplied in the \fIkeyv\fR array. .AP "Tcl_Obj *const" *keyv in diff --git a/doc/FileSystem.3 b/doc/FileSystem.3 index 96dafa9..0975dbe 100644 --- a/doc/FileSystem.3 +++ b/doc/FileSystem.3 @@ -269,7 +269,7 @@ allowed for the \fImode\fR argument to the Tcl \fBopen\fR command. .AP int permissions in POSIX-style permission flags such as 0644. If a new file is created, these permissions will be set on the created file. -.AP int *lenPtr out +.AP size_t | int *lenPtr out If non-NULL, filled with the number of elements in the split path. .AP Tcl_Obj *basePtr in The base path on to which to join the given elements. May be NULL. diff --git a/doc/Limit.3 b/doc/Limit.3 index 4842c05..43e92f0 100644 --- a/doc/Limit.3 +++ b/doc/Limit.3 @@ -65,7 +65,7 @@ its limits checked. .AP int type in The type of limit that the operation refers to. This must be either \fBTCL_LIMIT_COMMANDS\fR or \fBTCL_LIMIT_TIME\fR. -.AP int commandLimit in +.AP size_t commandLimit in The maximum number of commands (as reported by \fBinfo cmdcount\fR) that may be executed in the interpreter. .AP Tcl_Time *timeLimitPtr in/out diff --git a/doc/SetRecLmt.3 b/doc/SetRecLmt.3 index 41c2a0a..0358cc9 100644 --- a/doc/SetRecLmt.3 +++ b/doc/SetRecLmt.3 @@ -14,14 +14,14 @@ Tcl_SetRecursionLimit \- set maximum allowable nesting depth in interpreter .nf \fB#include \fR .sp -int +size_t \fBTcl_SetRecursionLimit\fR(\fIinterp, depth\fR) .SH ARGUMENTS .AS Tcl_Interp *interp .AP Tcl_Interp *interp in Interpreter whose recursion limit is to be set. Must be greater than zero. -.AP int depth in +.AP size_t depth in New limit for nested calls to \fBTcl_Eval\fR for \fIinterp\fR. .BE -- cgit v0.12 From b4b177bc926f1e246054462ba147e0448a0a95e3 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 19 May 2022 11:00:04 +0000 Subject: Elaborate TIP #481 implementation: Make clear that Tcl_GetUnicodeFromObj and Tcl_GetStringFromObj panic if lengthPtr points to an int and length > INT_MAX. Also if sizeof(int) == sizeof(size_t), prefer the size_t variant of the functions --- doc/StringObj.3 | 7 +++++-- generic/tclDecls.h | 16 ++++++++-------- generic/tclObj.c | 6 +++++- generic/tclStringObj.c | 4 ++++ 4 files changed, 22 insertions(+), 11 deletions(-) diff --git a/doc/StringObj.3 b/doc/StringObj.3 index c9bdd4a..2526a01 100644 --- a/doc/StringObj.3 +++ b/doc/StringObj.3 @@ -188,7 +188,9 @@ Even in the limited situations where writing to this pointer is acceptable, one should take care to respect the copy-on-write semantics required by \fBTcl_Obj\fR's, with appropriate calls to \fBTcl_IsShared\fR and \fBTcl_DuplicateObj\fR prior to any -in-place modification of the string representation. +in-place modification of the string representation. If \fIlengthPtr\fR +points to an \fBint\fR variable, and the string has more than 2^31 bytes, +a panic will result. The procedure \fBTcl_GetString\fR is used in the common case where the caller does not need the length of the string representation. @@ -200,7 +202,8 @@ value as a Unicode string. This is given by the returned pointer and byte pointer is owned by the value manager and should not be modified by the caller. The procedure \fBTcl_GetUnicode\fR is used in the common case where the caller does not need the length of the unicode string -representation. +representation. If \fIlengthPtr\fR points to an \fBint\fR variable, +and the string has more than 2^31 unicode characters, a panic will result. .PP \fBTcl_GetUniChar\fR returns the \fIindex\fR'th character in the value's Unicode representation. If the index is out of range or diff --git a/generic/tclDecls.h b/generic/tclDecls.h index 0995678..02c365e 100644 --- a/generic/tclDecls.h +++ b/generic/tclDecls.h @@ -3916,24 +3916,24 @@ extern const TclStubs *tclStubsPtr; #undef Tcl_GetBytesFromObj #if defined(USE_TCL_STUBS) #define Tcl_GetStringFromObj(objPtr, sizePtr) \ - (sizeof(*(sizePtr)) <= sizeof(int) ? tclStubsPtr->tclGetStringFromObj(objPtr, (int *)(sizePtr)) : tclStubsPtr->tcl_GetStringFromObj(objPtr, (size_t *)(sizePtr))) + ((sizeof(*(sizePtr)) <= sizeof(int) && sizeof(int) != sizeof(size_t)) ? tclStubsPtr->tclGetStringFromObj(objPtr, (int *)(sizePtr)) : tclStubsPtr->tcl_GetStringFromObj(objPtr, (size_t *)(sizePtr))) #define Tcl_GetBytesFromObj(interp, objPtr, sizePtr) \ - (sizeof(*(sizePtr)) <= sizeof(int) ? tclStubsPtr->tclGetBytesFromObj(interp, objPtr, (int *)(sizePtr)) : tclStubsPtr->tcl_GetBytesFromObj(interp, objPtr, (size_t *)(sizePtr))) + ((sizeof(*(sizePtr)) <= sizeof(int)) ? tclStubsPtr->tclGetBytesFromObj(interp, objPtr, (int *)(sizePtr)) : tclStubsPtr->tcl_GetBytesFromObj(interp, objPtr, (size_t *)(sizePtr))) #define Tcl_GetByteArrayFromObj(objPtr, sizePtr) \ - (sizeof(*(sizePtr)) <= sizeof(int) ? tclStubsPtr->tclGetBytesFromObj(NULL, objPtr, (int *)(sizePtr)) : tclStubsPtr->tcl_GetBytesFromObj(NULL, 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))) + ((sizeof(*(sizePtr)) <= sizeof(int)) ? tclStubsPtr->tclGetUnicodeFromObj(objPtr, (int *)(sizePtr)) : tclStubsPtr->tcl_GetUnicodeFromObj(objPtr, (size_t *)(sizePtr))) #define Tcl_GetIndexFromObjStruct(interp, objPtr, tablePtr, offset, msg, flags, indexPtr) \ (tclStubsPtr->tcl_GetIndexFromObjStruct((interp), (objPtr), (tablePtr), (offset), (msg), (flags)|(int)(sizeof(*(indexPtr))<<1), (indexPtr))) #else #define Tcl_GetStringFromObj(objPtr, sizePtr) \ - (sizeof(*(sizePtr)) <= sizeof(int) ? (TclGetStringFromObj)(objPtr, (int *)(sizePtr)) : (Tcl_GetStringFromObj)(objPtr, (size_t *)(sizePtr))) + ((sizeof(*(sizePtr)) <= sizeof(int) && sizeof(int) != sizeof(size_t)) ? (TclGetStringFromObj)(objPtr, (int *)(sizePtr)) : (Tcl_GetStringFromObj)(objPtr, (size_t *)(sizePtr))) #define Tcl_GetBytesFromObj(interp, objPtr, sizePtr) \ - (sizeof(*(sizePtr)) <= sizeof(int) ? (TclGetBytesFromObj)(interp, objPtr, (int *)(sizePtr)) : (Tcl_GetBytesFromObj)(interp, objPtr, (size_t *)(sizePtr))) + ((sizeof(*(sizePtr)) <= sizeof(int) && sizeof(int) != sizeof(size_t)) ? (TclGetBytesFromObj)(interp, objPtr, (int *)(sizePtr)) : (Tcl_GetBytesFromObj)(interp, objPtr, (size_t *)(sizePtr))) #define Tcl_GetByteArrayFromObj(objPtr, sizePtr) \ - (sizeof(*(sizePtr)) <= sizeof(int) ? (TclGetBytesFromObj)(NULL, objPtr, (int *)(sizePtr)) : (Tcl_GetBytesFromObj)(NULL, objPtr, (size_t *)(sizePtr))) + ((sizeof(*(sizePtr)) <= sizeof(int) && sizeof(int) != sizeof(size_t)) ? (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))) + ((sizeof(*(sizePtr)) <= sizeof(int) && sizeof(int) != sizeof(size_t)) ? (TclGetUnicodeFromObj)(objPtr, (int *)(sizePtr)) : Tcl_GetUnicodeFromObj(objPtr, (size_t *)(sizePtr))) #define Tcl_GetIndexFromObjStruct(interp, objPtr, tablePtr, offset, msg, flags, indexPtr) \ ((Tcl_GetIndexFromObjStruct)((interp), (objPtr), (tablePtr), (offset), (msg), (flags)|(int)(sizeof(*(indexPtr))<<1), (indexPtr))) #endif diff --git a/generic/tclObj.c b/generic/tclObj.c index b4d6332..300e408 100644 --- a/generic/tclObj.c +++ b/generic/tclObj.c @@ -1675,7 +1675,11 @@ TclGetStringFromObj( } } if (lengthPtr != NULL) { - *lengthPtr = (objPtr->length < INT_MAX)? objPtr->length: INT_MAX; + if (objPtr->length > INT_MAX) { + Tcl_Panic("Tcl_GetStringFromObj with 'int' lengthPtr" + "cannot handle such long strings. Please use 'size_t'"); + } + *lengthPtr = (int)objPtr->length; } return objPtr->bytes; } diff --git a/generic/tclStringObj.c b/generic/tclStringObj.c index a3ee1c3..d0bac17 100644 --- a/generic/tclStringObj.c +++ b/generic/tclStringObj.c @@ -686,6 +686,10 @@ TclGetUnicodeFromObj( } if (lengthPtr != NULL) { + if (stringPtr->numChars > INT_MAX) { + Tcl_Panic("Tcl_GetUnicodeFromObj with 'int' lengthPtr" + "cannot handle such long strings. Please use 'size_t'"); + } *lengthPtr = (int)stringPtr->numChars; } return stringPtr->unicode; -- cgit v0.12 From 53a20bbf1cf609252a8ec050ed68a139687e7ad0 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 19 May 2022 14:51:03 +0000 Subject: TIP #481: Also prefer size_t functions when lengthPtr == NULL --- generic/tclDecls.h | 38 ++++++++++++++++++++++++++++---------- 1 file changed, 28 insertions(+), 10 deletions(-) diff --git a/generic/tclDecls.h b/generic/tclDecls.h index 02c365e..1b8de88 100644 --- a/generic/tclDecls.h +++ b/generic/tclDecls.h @@ -3916,26 +3916,44 @@ extern const TclStubs *tclStubsPtr; #undef Tcl_GetBytesFromObj #if defined(USE_TCL_STUBS) #define Tcl_GetStringFromObj(objPtr, sizePtr) \ - ((sizeof(*(sizePtr)) <= sizeof(int) && sizeof(int) != sizeof(size_t)) ? tclStubsPtr->tclGetStringFromObj(objPtr, (int *)(sizePtr)) : tclStubsPtr->tcl_GetStringFromObj(objPtr, (size_t *)(sizePtr))) + ((sizePtr) && (sizeof(*(sizePtr)) == sizeof(int) && sizeof(int) != sizeof(size_t)) ? \ + tclStubsPtr->tclGetStringFromObj(objPtr, (int *)(void *)(sizePtr)) : \ + tclStubsPtr->tcl_GetStringFromObj(objPtr, (size_t *)(void *)(sizePtr))) #define Tcl_GetBytesFromObj(interp, objPtr, sizePtr) \ - ((sizeof(*(sizePtr)) <= sizeof(int)) ? tclStubsPtr->tclGetBytesFromObj(interp, objPtr, (int *)(sizePtr)) : tclStubsPtr->tcl_GetBytesFromObj(interp, objPtr, (size_t *)(sizePtr))) + ((sizePtr) && (sizeof(*(sizePtr)) == sizeof(int) && sizeof(int) != sizeof(size_t)) ? \ + tclStubsPtr->tclGetBytesFromObj(interp, objPtr, (int *)(void *)(sizePtr)) : \ + tclStubsPtr->tcl_GetBytesFromObj(interp, objPtr, (size_t *)(void *)(sizePtr))) #define Tcl_GetByteArrayFromObj(objPtr, sizePtr) \ - ((sizeof(*(sizePtr)) <= sizeof(int)) ? tclStubsPtr->tclGetBytesFromObj(NULL, objPtr, (int *)(sizePtr)) : tclStubsPtr->tcl_GetBytesFromObj(NULL, objPtr, (size_t *)(sizePtr))) + ((sizePtr) && (sizeof(*(sizePtr)) == sizeof(int) && sizeof(int) != sizeof(size_t)) ? \ + tclStubsPtr->tclGetBytesFromObj(NULL, objPtr, (int *)(void *)(sizePtr)) : \ + tclStubsPtr->tcl_GetBytesFromObj(NULL, objPtr, (size_t *)(void *)(sizePtr))) #define Tcl_GetUnicodeFromObj(objPtr, sizePtr) \ - ((sizeof(*(sizePtr)) <= sizeof(int)) ? tclStubsPtr->tclGetUnicodeFromObj(objPtr, (int *)(sizePtr)) : tclStubsPtr->tcl_GetUnicodeFromObj(objPtr, (size_t *)(sizePtr))) + ((sizePtr) && (sizeof(*(sizePtr)) == sizeof(int) && sizeof(int) != sizeof(size_t)) ? \ + tclStubsPtr->tclGetUnicodeFromObj(objPtr, (int *)(void *)(sizePtr)) : \ + tclStubsPtr->tcl_GetUnicodeFromObj(objPtr, (size_t *)(void *)(sizePtr))) #define Tcl_GetIndexFromObjStruct(interp, objPtr, tablePtr, offset, msg, flags, indexPtr) \ - (tclStubsPtr->tcl_GetIndexFromObjStruct((interp), (objPtr), (tablePtr), (offset), (msg), (flags)|(int)(sizeof(*(indexPtr))<<1), (indexPtr))) + (tclStubsPtr->tcl_GetIndexFromObjStruct((interp), (objPtr), (tablePtr), (offset), (msg), \ + (flags)|(int)(sizeof(*(indexPtr))<<1), (indexPtr))) #else #define Tcl_GetStringFromObj(objPtr, sizePtr) \ - ((sizeof(*(sizePtr)) <= sizeof(int) && sizeof(int) != sizeof(size_t)) ? (TclGetStringFromObj)(objPtr, (int *)(sizePtr)) : (Tcl_GetStringFromObj)(objPtr, (size_t *)(sizePtr))) + ((sizePtr) && (sizeof(*(sizePtr)) == sizeof(int) && sizeof(int) != sizeof(size_t)) ? \ + (TclGetStringFromObj)(objPtr, (int *)(void *)(sizePtr)) : \ + (Tcl_GetStringFromObj)(objPtr, (size_t *)(void *)(sizePtr))) #define Tcl_GetBytesFromObj(interp, objPtr, sizePtr) \ - ((sizeof(*(sizePtr)) <= sizeof(int) && sizeof(int) != sizeof(size_t)) ? (TclGetBytesFromObj)(interp, objPtr, (int *)(sizePtr)) : (Tcl_GetBytesFromObj)(interp, objPtr, (size_t *)(sizePtr))) + ((sizePtr) && (sizeof(*(sizePtr)) == sizeof(int) && sizeof(int) != sizeof(size_t)) ? \ + (TclGetBytesFromObj)(interp, objPtr, (int *)(void *)(sizePtr)) : \ + (Tcl_GetBytesFromObj)(interp, objPtr, (size_t *)(void *)(sizePtr))) #define Tcl_GetByteArrayFromObj(objPtr, sizePtr) \ - ((sizeof(*(sizePtr)) <= sizeof(int) && sizeof(int) != sizeof(size_t)) ? (TclGetBytesFromObj)(NULL, objPtr, (int *)(sizePtr)) : (Tcl_GetBytesFromObj)(NULL, objPtr, (size_t *)(sizePtr))) + ((sizePtr) && (sizeof(*(sizePtr)) == sizeof(int) && sizeof(int) != sizeof(size_t)) ? \ + (TclGetBytesFromObj)(NULL, objPtr, (int *)(void *)(sizePtr)) : \ + (Tcl_GetBytesFromObj)(NULL, objPtr, (size_t *)(void *)(sizePtr))) #define Tcl_GetUnicodeFromObj(objPtr, sizePtr) \ - ((sizeof(*(sizePtr)) <= sizeof(int) && sizeof(int) != sizeof(size_t)) ? (TclGetUnicodeFromObj)(objPtr, (int *)(sizePtr)) : Tcl_GetUnicodeFromObj(objPtr, (size_t *)(sizePtr))) + ((sizePtr) && (sizeof(*(sizePtr)) == sizeof(int) && sizeof(int) != sizeof(size_t)) ? \ + (TclGetUnicodeFromObj)(objPtr, (int *)(void *)(sizePtr)) : \ + Tcl_GetUnicodeFromObj(objPtr, (size_t *)(void *)(sizePtr))) #define Tcl_GetIndexFromObjStruct(interp, objPtr, tablePtr, offset, msg, flags, indexPtr) \ - ((Tcl_GetIndexFromObjStruct)((interp), (objPtr), (tablePtr), (offset), (msg), (flags)|(int)(sizeof(*(indexPtr))<<1), (indexPtr))) + ((Tcl_GetIndexFromObjStruct)((interp), (objPtr), (tablePtr), (offset), (msg), \ + (flags)|(int)(sizeof(*(indexPtr))<<1), (indexPtr))) #endif #ifdef TCL_MEM_DEBUG -- cgit v0.12 From 326c72a0d919b2c96c48a3df365dc8a7256dacd7 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Sun, 22 May 2022 11:59:15 +0000 Subject: Disable C4090 warning; See: [https://developercommunity.visualstudio.com/t/c-compiler-incorrect-propagation-of-const-qualifie/39071] --- win/rules.vc | 4 ++-- win/tclWinPort.h | 1 + 2 files changed, 3 insertions(+), 2 deletions(-) diff --git a/win/rules.vc b/win/rules.vc index 3107756..47c0742 100644 --- a/win/rules.vc +++ b/win/rules.vc @@ -1470,8 +1470,8 @@ cdebug = $(cdebug) -Zi !endif # $(DEBUG) -# cwarn includes default warning levels, also C4146 is useless. -cwarn = $(WARNINGS) -wd4146 +# cwarn includes default warning levels, also C4090 (buggy) and C4146 is useless. +cwarn = $(WARNINGS) -wd4090 -wd4146 !if "$(MACHINE)" == "AMD64" || "$(MACHINE)" == "ARM64" # Disable pointer<->int warnings related to cast between different sizes diff --git a/win/tclWinPort.h b/win/tclWinPort.h index 0a68abe..5e7f9c3 100644 --- a/win/tclWinPort.h +++ b/win/tclWinPort.h @@ -486,6 +486,7 @@ typedef DWORD_PTR * PDWORD_PTR; * (_MSC_VER is 1200 for VC6, 1300 or 1310 for vc7.net, 1400 for 8.0) */ #if defined(_MSC_VER) +# pragma warning(disable:4090) /* see: https://developercommunity.visualstudio.com/t/c-compiler-incorrect-propagation-of-const-qualifie/390711 */ # pragma warning(disable:4146) # pragma warning(disable:4244) # if _MSC_VER >= 1400 -- cgit v0.12 From 983a154c51cd92b7dba7b6d79ce073721d417a33 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Sun, 22 May 2022 12:23:25 +0000 Subject: 2 more unused 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 8536168..e07ae5e 100644 --- a/generic/tcl.decls +++ b/generic/tcl.decls @@ -2111,7 +2111,7 @@ declare 579 { # ----- BASELINE -- FOR -- 8.5.0 ----- # -declare 673 { +declare 675 { void TclUnusedStubEntry(void) } diff --git a/generic/tclDecls.h b/generic/tclDecls.h index b8b17d2..246e2c9 100644 --- a/generic/tclDecls.h +++ b/generic/tclDecls.h @@ -3505,9 +3505,11 @@ EXTERN void Tcl_AppendPrintfToObj(Tcl_Obj *objPtr, /* Slot 670 is reserved */ /* Slot 671 is reserved */ /* Slot 672 is reserved */ +/* Slot 673 is reserved */ +/* Slot 674 is reserved */ #ifndef TclUnusedStubEntry_TCL_DECLARED #define TclUnusedStubEntry_TCL_DECLARED -/* 673 */ +/* 675 */ EXTERN void TclUnusedStubEntry(void); #endif @@ -4218,7 +4220,9 @@ typedef struct TclStubs { VOID *reserved670; VOID *reserved671; VOID *reserved672; - void (*tclUnusedStubEntry) (void); /* 673 */ + VOID *reserved673; + VOID *reserved674; + void (*tclUnusedStubEntry) (void); /* 675 */ } TclStubs; extern TclStubs *tclStubsPtr; @@ -6664,9 +6668,11 @@ extern TclStubs *tclStubsPtr; /* Slot 670 is reserved */ /* Slot 671 is reserved */ /* Slot 672 is reserved */ +/* Slot 673 is reserved */ +/* Slot 674 is reserved */ #ifndef TclUnusedStubEntry #define TclUnusedStubEntry \ - (tclStubsPtr->tclUnusedStubEntry) /* 673 */ + (tclStubsPtr->tclUnusedStubEntry) /* 675 */ #endif #endif /* defined(USE_TCL_STUBS) && !defined(USE_TCL_STUB_PROCS) */ diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c index e7dc0c1..0bebc15 100644 --- a/generic/tclStubInit.c +++ b/generic/tclStubInit.c @@ -1471,7 +1471,9 @@ TclStubs tclStubs = { NULL, /* 670 */ NULL, /* 671 */ NULL, /* 672 */ - TclUnusedStubEntry, /* 673 */ + NULL, /* 673 */ + NULL, /* 674 */ + TclUnusedStubEntry, /* 675 */ }; /* !END!: Do not edit above this line. */ -- cgit v0.12 From ffda1b67f7a2399cc521a0d808f9b099f0bf26c0 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Sun, 22 May 2022 12:24:27 +0000 Subject: See: [https://github.com/tcltk/tcl/pull/13] --- .github/workflows/linux-build.yml | 2 ++ .github/workflows/mac-build.yml | 2 ++ .github/workflows/win-build.yml | 2 ++ 3 files changed, 6 insertions(+) diff --git a/.github/workflows/linux-build.yml b/.github/workflows/linux-build.yml index 909f407..b94ed97 100644 --- a/.github/workflows/linux-build.yml +++ b/.github/workflows/linux-build.yml @@ -1,5 +1,7 @@ name: Linux on: [push] +permissions: + contents: read jobs: gcc: runs-on: ubuntu-18.04 diff --git a/.github/workflows/mac-build.yml b/.github/workflows/mac-build.yml index 5029794..8593989 100644 --- a/.github/workflows/mac-build.yml +++ b/.github/workflows/mac-build.yml @@ -1,5 +1,7 @@ name: macOS on: [push] +permissions: + contents: read jobs: xcode: runs-on: macos-10.15 diff --git a/.github/workflows/win-build.yml b/.github/workflows/win-build.yml index 8e9f2d5..79a7e68 100644 --- a/.github/workflows/win-build.yml +++ b/.github/workflows/win-build.yml @@ -1,5 +1,7 @@ name: Windows on: [push] +permissions: + contents: read jobs: msvc: runs-on: windows-2019 -- cgit v0.12 From 393936e2b829ec47b742c3225bb29250a8e728b8 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Sun, 22 May 2022 17:11:58 +0000 Subject: Proposed fix for [76ad7aeba3]: boundary case bug in [string is integer]. Missing: more unit-tests --- generic/tclCmdMZ.c | 21 ++++++++++++++------- generic/tclObj.c | 18 +++++++++++++----- tests/get.test | 30 ++++++++++++++---------------- 3 files changed, 41 insertions(+), 28 deletions(-) diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c index c94abbd..8d3eda9 100644 --- a/generic/tclCmdMZ.c +++ b/generic/tclCmdMZ.c @@ -1451,7 +1451,6 @@ StringIsCmd( int (*chcomp)(int) = NULL; /* The UniChar comparison function. */ int i, failat = 0, result = 1, strict = 0, index, length1, length2; Tcl_Obj *objPtr, *failVarObj = NULL; - Tcl_WideInt w; static const char *const isClasses[] = { "alnum", "alpha", "ascii", "control", @@ -1590,9 +1589,13 @@ StringIsCmd( case STR_IS_GRAPH: chcomp = Tcl_UniCharIsGraph; break; - case STR_IS_INT: - if (TCL_OK == TclGetIntFromObj(NULL, objPtr, &i)) { - break; + case STR_IS_INT: { + void *p; + int type; + if (TCL_OK == TclGetNumberFromObj(NULL, objPtr, &p, &type) + && (type == TCL_NUMBER_LONG) && (*(long *)p <= INT_MAX) && (*(long *)p >= INT_MIN)) { + break; + } } goto failedIntParse; case STR_IS_ENTIER: @@ -1640,9 +1643,13 @@ StringIsCmd( failat = 0; } break; - case STR_IS_WIDE: - if (TCL_OK == TclGetWideIntFromObj(NULL, objPtr, &w)) { - break; + case STR_IS_WIDE: { + void *p; + int type; + if (TCL_OK == TclGetNumberFromObj(NULL, objPtr, &p, &type) + && (type == TCL_NUMBER_WIDE)) { + break; + } } failedIntParse: diff --git a/generic/tclObj.c b/generic/tclObj.c index b2fd80b..531a256 100644 --- a/generic/tclObj.c +++ b/generic/tclObj.c @@ -2500,21 +2500,29 @@ Tcl_GetIntFromObj( #if (LONG_MAX == INT_MAX) return TclGetLongFromObj(interp, objPtr, (long *) intPtr); #else - long l; + void *p; + int type; - if (TclGetLongFromObj(interp, objPtr, &l) != TCL_OK) { + if ((TclGetNumberFromObj(NULL, objPtr, &p, &type) != TCL_OK) + || (type == TCL_NUMBER_DOUBLE)) { + if (interp != NULL) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "expected integer but got \"%s\"", Tcl_GetString(objPtr))); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "INTEGER", NULL); + } return TCL_ERROR; } - if ((ULONG_MAX > UINT_MAX) && ((l > UINT_MAX) || (l < -(long)UINT_MAX))) { + if ((type != TCL_NUMBER_LONG) || ((ULONG_MAX > UINT_MAX) + && ((*(long *)p > UINT_MAX) || (*(long *)p < -(long)UINT_MAX)))) { if (interp != NULL) { const char *s = - "integer value too large to represent as non-long integer"; + "integer value too large to represent"; Tcl_SetObjResult(interp, Tcl_NewStringObj(s, -1)); Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW", s, NULL); } return TCL_ERROR; } - *intPtr = (int) l; + *intPtr = (int)*(long *)p; return TCL_OK; #endif } diff --git a/tests/get.test b/tests/get.test index b9a83ac..a7bab5d 100644 --- a/tests/get.test +++ b/tests/get.test @@ -20,8 +20,6 @@ catch [list package require -exact Tcltest [info patchlevel]] testConstraint testgetint [llength [info commands testgetint]] testConstraint testdoubleobj [llength [info commands testdoubleobj]] -testConstraint longIs32bit [expr {int(0x80000000) < 0}] -testConstraint longIs64bit [expr {int(0x8000000000000000) < 0}] test get-1.1 {Tcl_GetInt procedure} testgetint { testgetint 44 { 22} @@ -41,28 +39,28 @@ test get-1.5 {Tcl_GetInt procedure} testgetint { test get-1.6 {Tcl_GetInt procedure} testgetint { list [catch {testgetint 44 {16 x}} msg] $msg } {1 {expected integer but got "16 x"}} -test get-1.7 {Tcl_GetInt procedure} {testgetint longIs64bit} { +test get-1.7 {Tcl_GetInt procedure} testgetint { list [catch {testgetint 44 18446744073709551616} msg] $msg $errorCode } {1 {integer value too large to represent} {ARITH IOVERFLOW {integer value too large to represent}}} -test get-1.8 {Tcl_GetInt procedure} {testgetint longIs64bit} { - list [catch {testgetint 18446744073709551614} msg] $msg -} {0 -2} -test get-1.9 {Tcl_GetInt procedure} {testgetint longIs64bit} { - list [catch {testgetint +18446744073709551614} msg] $msg -} {0 -2} -test get-1.10 {Tcl_GetInt procedure} {testgetint longIs64bit} { - list [catch {testgetint -18446744073709551614} msg] $msg -} {0 2} -test get-1.11 {Tcl_GetInt procedure} {testgetint longIs32bit} { +test get-1.8 {Tcl_GetInt procedure} testgetint { + list [catch {testgetint 18446744073709551614} msg] $msg $errorCode +} {1 {integer value too large to represent} {ARITH IOVERFLOW {integer value too large to represent}}} +test get-1.9 {Tcl_GetInt procedure} testgetint { + list [catch {testgetint +18446744073709551614} msg] $msg $errorCode +} {1 {integer value too large to represent} {ARITH IOVERFLOW {integer value too large to represent}}} +test get-1.10 {Tcl_GetInt procedure} testgetint { + list [catch {testgetint -18446744073709551614} msg] $msg $errorCode +} {1 {integer value too large to represent} {ARITH IOVERFLOW {integer value too large to represent}}} +test get-1.11 {Tcl_GetInt procedure} testgetint { list [catch {testgetint 44 4294967296} msg] $msg $errorCode } {1 {integer value too large to represent} {ARITH IOVERFLOW {integer value too large to represent}}} -test get-1.12 {Tcl_GetInt procedure} {testgetint longIs32bit} { +test get-1.12 {Tcl_GetInt procedure} testgetint { list [catch {testgetint 4294967294} msg] $msg } {0 -2} -test get-1.13 {Tcl_GetInt procedure} {testgetint longIs32bit} { +test get-1.13 {Tcl_GetInt procedure} testgetint { list [catch {testgetint +4294967294} msg] $msg } {0 -2} -test get-1.14 {Tcl_GetInt procedure} {testgetint longIs32bit} { +test get-1.14 {Tcl_GetInt procedure} testgetint { list [catch {testgetint -4294967294} msg] $msg } {0 2} -- cgit v0.12 From a623f528f64f6fbb4a8d8cf347b454d5770d37b4 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 24 May 2022 06:50:32 +0000 Subject: Fix for [f160f9f982]: macOS Aqua : Emoji does not display anymore after TIP #622. (Actually, X11 displayed wrong too!) --- generic/tclDecls.h | 11 +++++++++++ generic/tclStubInit.c | 4 ++++ 2 files changed, 15 insertions(+) diff --git a/generic/tclDecls.h b/generic/tclDecls.h index 503d47e..ee9e02f 100644 --- a/generic/tclDecls.h +++ b/generic/tclDecls.h @@ -4326,6 +4326,17 @@ extern const TclStubs *tclStubsPtr; # define Tcl_UtfToUniChar Tcl_UtfToChar16 # undef Tcl_UniCharLen # define Tcl_UniCharLen Tcl_Char16Len +#elif !defined(BUILD_tcl) +# undef Tcl_NumUtfChars +# define Tcl_NumUtfChars TclNumUtfChars +# undef Tcl_GetCharLength +# define Tcl_GetCharLength TclGetCharLength +# undef Tcl_UtfAtIndex +# define Tcl_UtfAtIndex TclUtfAtIndex +# undef Tcl_GetRange +# define Tcl_GetRange TclGetRange +# undef Tcl_GetUniChar +# define Tcl_GetUniChar TclGetUniChar #endif #if defined(USE_TCL_STUBS) # define Tcl_WCharToUtfDString (sizeof(wchar_t) != sizeof(short) \ diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c index 7d04481..fd06c14 100644 --- a/generic/tclStubInit.c +++ b/generic/tclStubInit.c @@ -78,8 +78,11 @@ #undef Tcl_MacOSXOpenBundleResources #undef TclWinConvertWSAError #undef TclWinConvertError +#undef Tcl_NumUtfChars #undef Tcl_GetCharLength #undef Tcl_UtfAtIndex +#undef Tcl_GetRange +#undef Tcl_GetUniChar #if defined(_WIN32) || defined(__CYGWIN__) #define TclWinConvertWSAError (void (*)(DWORD))(void *)Tcl_WinConvertError @@ -103,6 +106,7 @@ static void uniCodePanic(void) { # define Tcl_UniCharCaseMatch (int(*)(const unsigned short *, const unsigned short *, int))(void *)uniCodePanic # define Tcl_GetRange (Tcl_Obj *(*)(Tcl_Obj *, int, int))(void *)uniCodePanic # define Tcl_GetUniChar (int(*)(Tcl_Obj *, int))(void *)uniCodePanic +# define Tcl_NumUtfChars (int(*)(const char *, int))(void *)uniCodePanic #endif #define TclUtfCharComplete UtfCharComplete -- cgit v0.12 From 089be89dd5b219a8d5156723b99478293c835f9a Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 24 May 2022 12:45:10 +0000 Subject: Compiler warning when USE_DTRACE=1 --- generic/tclProc.c | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/generic/tclProc.c b/generic/tclProc.c index 613225c..cd52cbf 100644 --- a/generic/tclProc.c +++ b/generic/tclProc.c @@ -1692,9 +1692,9 @@ TclNRInterpProcCore( #ifdef USE_DTRACE if (TCL_DTRACE_PROC_ARGS_ENABLED()) { - int l = iPtr->varFramePtr->isProcCallFrame & FRAME_IS_LAMBDA ? 1 : 0; + size_t l = iPtr->varFramePtr->isProcCallFrame & FRAME_IS_LAMBDA ? 1 : 0; const char *a[10]; - int i; + size_t i; for (i = 0 ; i < 10 ; i++) { a[i] = (l < iPtr->varFramePtr->objc ? @@ -1713,7 +1713,7 @@ TclNRInterpProcCore( TclDecrRefCount(info); } if (TCL_DTRACE_PROC_ENTRY_ENABLED()) { - int l = iPtr->varFramePtr->isProcCallFrame & FRAME_IS_LAMBDA ? 1 : 0; + size_t l = iPtr->varFramePtr->isProcCallFrame & FRAME_IS_LAMBDA ? 1 : 0; TCL_DTRACE_PROC_ENTRY(l < iPtr->varFramePtr->objc ? TclGetString(iPtr->varFramePtr->objv[l]) : NULL, @@ -1721,7 +1721,7 @@ TclNRInterpProcCore( (Tcl_Obj **)(iPtr->varFramePtr->objv + l + 1)); } if (TCL_DTRACE_PROC_ENTRY_ENABLED()) { - int l = iPtr->varFramePtr->isProcCallFrame & FRAME_IS_LAMBDA ? 1 : 0; + size_t l = iPtr->varFramePtr->isProcCallFrame & FRAME_IS_LAMBDA ? 1 : 0; TCL_DTRACE_PROC_ENTRY(l < iPtr->varFramePtr->objc ? TclGetString(iPtr->varFramePtr->objv[l]) : NULL, -- cgit v0.12 From ebd247f0bef013b7307aed2d223804205c9c5f70 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 24 May 2022 16:35:18 +0000 Subject: Do all "string" testcases twice: once with and once without bytecode --- tests/string.test | 2529 +++++++++++++++++++++++++++-------------------------- 1 file changed, 1268 insertions(+), 1261 deletions(-) diff --git a/tests/string.test b/tests/string.test index 977e875..172b22d 100644 --- a/tests/string.test +++ b/tests/string.test @@ -6,8 +6,8 @@ # # Copyright (c) 1991-1993 The Regents of the University of California. # Copyright (c) 1994 Sun Microsystems, Inc. -# Copyright (c) 1998-1999 by Scriptics Corporation. -# Copyright (c) 2001 by Kevin B. Kenny. All rights reserved. +# Copyright (c) 1998-1999 Scriptics Corporation. +# Copyright (c) 2001 Kevin B. Kenny. All rights reserved. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. @@ -24,311 +24,316 @@ catch [list package require -exact Tcltest [info patchlevel]] testConstraint testobj [expr {[info commands testobj] != {}}] testConstraint testindexobj [expr {[info commands testindexobj] != {}}] +testConstraint testevalex [expr {[info commands testevalex] != {}}] testConstraint utf16 [expr {[string length \U010000] == 2}] testConstraint testbytestring [llength [info commands testbytestring]] # Used for constraining memory leak tests testConstraint memory [llength [info commands memory]] -test string-1.1 {error conditions} { - list [catch {string gorp a b} msg] $msg -} {1 {unknown or ambiguous subcommand "gorp": must be bytelength, cat, compare, equal, first, index, is, last, length, map, match, range, repeat, replace, reverse, tolower, totitle, toupper, trim, trimleft, trimright, wordend, or wordstart}} -test string-1.2 {error conditions} { - list [catch {string} msg] $msg +foreach noComp {0 1} { + +if {$noComp} { + if {[info commands testevalex] eq {}} { + test string-0.1.$noComp "show testevalex availability" {testevalex} {list} {} + continue + } + interp alias {} run {} testevalex + set constraints testevalex +} else { + interp alias {} run {} try + set constraints {} +} + + +test string-1.1.$noComp {error conditions} -body { + list [catch {run {string gorp a b}} msg] $msg +} -result {1 {unknown or ambiguous subcommand "gorp": must be bytelength, cat, compare, equal, first, index, is, last, length, map, match, range, repeat, replace, reverse, tolower, totitle, toupper, trim, trimleft, trimright, wordend, or wordstart}} +test string-1.2.$noComp {error conditions} { + list [catch {run {string}} msg] $msg } {1 {wrong # args: should be "string subcommand ?arg ...?"}} -test string-2.1 {string compare, not enough args} { - list [catch {string compare a} msg] $msg +test string-2.1.$noComp {string compare, not enough args} { + list [catch {run {string compare a}} msg] $msg } {1 {wrong # args: should be "string compare ?-nocase? ?-length int? string1 string2"}} -test string-2.2 {string compare, bad args} { - list [catch {string compare a b c} msg] $msg +test string-2.2.$noComp {string compare, bad args} { + list [catch {run {string compare a b c}} msg] $msg } {1 {bad option "a": must be -nocase or -length}} -test string-2.3 {string compare, bad args} { - list [catch {string compare -length -nocase str1 str2} msg] $msg +test string-2.3.$noComp {string compare, bad args} { + list [catch {run {string compare -length -nocase str1 str2}} msg] $msg } {1 {expected integer but got "-nocase"}} -test string-2.4 {string compare, too many args} { - list [catch {string compare -length 10 -nocase str1 str2 str3} msg] $msg +test string-2.4.$noComp {string compare, too many args} { + list [catch {run {string compare -length 10 -nocase str1 str2 str3}} msg] $msg } {1 {wrong # args: should be "string compare ?-nocase? ?-length int? string1 string2"}} -test string-2.5 {string compare with length unspecified} { - list [catch {string compare -length 10 10} msg] $msg +test string-2.5.$noComp {string compare with length unspecified} { + list [catch {run {string compare -length 10 10}} msg] $msg } {1 {wrong # args: should be "string compare ?-nocase? ?-length int? string1 string2"}} -test string-2.6 {string compare} { - string compare abcde abdef +test string-2.6.$noComp {string compare} { + run {string compare abcde abdef} } -1 -test string-2.7 {string compare, shortest method name} { - string co abcde ABCDE +test string-2.7.$noComp {string compare, shortest method name} { + run {string co abcde ABCDE} } 1 -test string-2.8 {string compare} { - string compare abcde abcde +test string-2.8.$noComp {string compare} { + run {string compare abcde abcde} } 0 -test string-2.9 {string compare with length} { - string compare -length 2 abcde abxyz +test string-2.9.$noComp {string compare with length} { + run {string compare -length 2 abcde abxyz} } 0 -test string-2.10 {string compare with special index} { - list [catch {string compare -length end-3 abcde abxyz} msg] $msg +test string-2.10.$noComp {string compare with special index} { + list [catch {run {string compare -length end-3 abcde abxyz}} msg] $msg } {1 {expected integer but got "end-3"}} -test string-2.11 {string compare, unicode} { - string compare ab\u7266 ab\u7267 +test string-2.11.$noComp {string compare, unicode} { + run {string compare ab\u7266 ab\u7267} } -1 -test string-2.12 {string compare, high bit} { +test string-2.12.$noComp {string compare, high bit} { # This test will fail if the underlying comparison # is using signed chars instead of unsigned chars. # (like SunOS's default memcmp thus the compat/memcmp.c) - string compare "\x80" "@" + run {string compare "\x80" "@"} # Nb this tests works also in utf-8 space because \x80 is # translated into a 2 or more bytelength but whose first byte has # the high bit set. } 1 -test string-2.13 {string compare -nocase} { - string compare -nocase abcde abdef +test string-2.13.$noComp {string compare -nocase} { + run {string compare -nocase abcde abdef} } -1 -test string-2.14 {string compare -nocase} { - string compare -nocase abcde ABCDE +test string-2.14.$noComp {string compare -nocase} { + run {string compare -nocase abcde ABCDE} } 0 -test string-2.15 {string compare -nocase} { - string compare -nocase abcde abcde +test string-2.15.$noComp {string compare -nocase} { + run {string compare -nocase abcde abcde} } 0 -test string-2.16 {string compare -nocase with length} { - string compare -length 2 -nocase abcde Abxyz +test string-2.16.$noComp {string compare -nocase with length} { + run {string compare -length 2 -nocase abcde Abxyz} } 0 -test string-2.17 {string compare -nocase with length} { - string compare -nocase -length 3 abcde Abxyz +test string-2.17.$noComp {string compare -nocase with length} { + run {string compare -nocase -length 3 abcde Abxyz} } -1 -test string-2.18 {string compare -nocase with length <= 0} { - string compare -nocase -length -1 abcde AbCdEf +test string-2.18.$noComp {string compare -nocase with length <= 0} { + run {string compare -nocase -length -1 abcde AbCdEf} } -1 -test string-2.19 {string compare -nocase with excessive length} { - string compare -nocase -length 50 AbCdEf abcde +test string-2.19.$noComp {string compare -nocase with excessive length} { + run {string compare -nocase -length 50 AbCdEf abcde} } 1 -test string-2.20 {string compare -len unicode} { +test string-2.20.$noComp {string compare -len unicode} { # These are strings that are 6 BYTELENGTH long, but the length # shouldn't make a different because there are actually 3 CHARS long - string compare -len 5 \334\334\334 \334\334\374 + run {string compare -len 5 \334\334\334 \334\334\374} } -1 -test string-2.21 {string compare -nocase with special index} { - list [catch {string compare -nocase -length end-3 Abcde abxyz} msg] $msg +test string-2.21.$noComp {string compare -nocase with special index} { + list [catch {run {string compare -nocase -length end-3 Abcde abxyz}} msg] $msg } {1 {expected integer but got "end-3"}} -test string-2.22 {string compare, null strings} { - string compare "" "" +test string-2.22.$noComp {string compare, null strings} { + run {string compare "" ""} } 0 -test string-2.23 {string compare, null strings} { - string compare "" foo +test string-2.23.$noComp {string compare, null strings} { + run {string compare "" foo} } -1 -test string-2.24 {string compare, null strings} { - string compare foo "" +test string-2.24.$noComp {string compare, null strings} { + run {string compare foo ""} } 1 -test string-2.25 {string compare -nocase, null strings} { - string compare -nocase "" "" +test string-2.25.$noComp {string compare -nocase, null strings} { + run {string compare -nocase "" ""} } 0 -test string-2.26 {string compare -nocase, null strings} { - string compare -nocase "" foo +test string-2.26.$noComp {string compare -nocase, null strings} { + run {string compare -nocase "" foo} } -1 -test string-2.27 {string compare -nocase, null strings} { - string compare -nocase foo "" +test string-2.27.$noComp {string compare -nocase, null strings} { + run {string compare -nocase foo ""} } 1 -test string-2.28 {string compare with length, unequal strings} { - string compare -length 2 abc abde +test string-2.28.$noComp {string compare with length, unequal strings} { + run {string compare -length 2 abc abde} } 0 -test string-2.29 {string compare with length, unequal strings} { - string compare -length 2 ab abde +test string-2.29.$noComp {string compare with length, unequal strings} { + run {string compare -length 2 ab abde} } 0 -test string-2.30 {string compare with NUL character vs. other ASCII} { +test string-2.30.$noComp {string compare with NUL character vs. other ASCII} { # Be careful here, since UTF-8 rep comparison with memcmp() of # these puts chars in the wrong order - string compare \x00 \x01 + run {string compare \x00 \x01} } -1 -test string-2.31 {string compare, high bit} { - proc foo {} {string compare "a\x80" "a@"} - foo +test string-2.31.$noComp {string compare, high bit} { + run {string compare "a\x80" "a@"} } 1 -test string-2.32 {string compare, high bit} { - proc foo {} {string compare "a\x00" "a\x01"} - foo +test string-2.32.$noComp {string compare, high bit} { + run {string compare "a\x00" "a\x01"} } -1 -test string-2.33 {string compare, high bit} { - proc foo {} {string compare "\x00\x00" "\x00\x01"} - foo +test string-2.33.$noComp {string compare, high bit} { + run {string compare "\x00\x00" "\x00\x01"} } -1 -test string-2.34 {string compare, binary equal} { - proc foo {} {string compare [binary format a100 0] [binary format a100 0]} - foo +test string-2.34.$noComp {string compare, binary equal} { + run {string compare [binary format a100 0] [binary format a100 0]} } 0 -test string-2.35 {string compare, binary neq} { - proc foo {} {string compare [binary format a100a 0 1] [binary format a100a 0 0]} - foo +test string-2.35.$noComp {string compare, binary neq} { + run {string compare [binary format a100a 0 1] [binary format a100a 0 0]} } 1 -test string-2.36 {string compare, binary neq unequal length} { - proc foo {} {string compare [binary format a20a 0 1] [binary format a100a 0 0]} - foo +test string-2.36.$noComp {string compare, binary neq unequal length} { + run {string compare [binary format a20a 0 1] [binary format a100a 0 0]} } 1 # only need a few tests on equal, since it uses the same code as # string compare, but just modifies the return output -test string-3.1 {string equal} { - string equal abcde abdef +test string-3.1.$noComp {string equal} { + run {string equal abcde abdef} } 0 -test string-3.2 {string equal} { - string eq abcde ABCDE +test string-3.2.$noComp {string equal} { + run {string eq abcde ABCDE} } 0 -test string-3.3 {string equal} { - string equal abcde abcde +test string-3.3.$noComp {string equal} { + run {string equal abcde abcde} } 1 -test string-3.4 {string equal -nocase} { - string equal -nocase \334\334\334\334\374\374\374\374 \334\334\334\334\334\334\334\334 +test string-3.4.$noComp {string equal -nocase} { + run {string equal -nocase \334\334\334\334\374\374\374\374 \334\334\334\334\334\334\334\334} } 1 -test string-3.5 {string equal -nocase} { - string equal -nocase abcde abdef +test string-3.5.$noComp {string equal -nocase} { + run {string equal -nocase abcde abdef} } 0 -test string-3.6 {string equal -nocase} { - string eq -nocase abcde ABCDE +test string-3.6.$noComp {string equal -nocase} { + run {string eq -nocase abcde ABCDE} } 1 -test string-3.7 {string equal -nocase} { - string equal -nocase abcde abcde +test string-3.7.$noComp {string equal -nocase} { + run {string equal -nocase abcde abcde} } 1 -test string-3.8 {string equal with length, unequal strings} { - string equal -length 2 abc abde +test string-3.8.$noComp {string equal with length, unequal strings} { + run {string equal -length 2 abc abde} } 1 -test string-4.1 {string first, not enough args} { - list [catch {string first a} msg] $msg +test string-4.1.$noComp {string first, not enough args} { + list [catch {run {string first a}} msg] $msg } {1 {wrong # args: should be "string first needleString haystackString ?startIndex?"}} -test string-4.2 {string first, bad args} { - list [catch {string first a b c} msg] $msg +test string-4.2.$noComp {string first, bad args} { + list [catch {run {string first a b c}} msg] $msg } {1 {bad index "c": must be integer?[+-]integer? or end?[+-]integer?}} -test string-4.3 {string first, too many args} { - list [catch {string first a b 5 d} msg] $msg +test string-4.3.$noComp {string first, too many args} { + list [catch {run {string first a b 5 d}} msg] $msg } {1 {wrong # args: should be "string first needleString haystackString ?startIndex?"}} -test string-4.4 {string first} { - string first bq abcdefgbcefgbqrs +test string-4.4.$noComp {string first} { + run {string first bq abcdefgbcefgbqrs} } 12 -test string-4.5 {string first} { - string fir bcd abcdefgbcefgbqrs +test string-4.5.$noComp {string first} { + run {string fir bcd abcdefgbcefgbqrs} } 1 -test string-4.6 {string first} { - string f b abcdefgbcefgbqrs +test string-4.6.$noComp {string first} { + run {string f b abcdefgbcefgbqrs} } 1 -test string-4.7 {string first} { - string first xxx x123xx345xxx789xxx012 +test string-4.7.$noComp {string first} { + run {string first xxx x123xx345xxx789xxx012} } 9 -test string-4.8 {string first} { - string first "" x123xx345xxx789xxx012 +test string-4.8.$noComp {string first} { + run {string first "" x123xx345xxx789xxx012} } -1 -test string-4.9 {string first, unicode} { - string first x abc\u7266x +test string-4.9.$noComp {string first, unicode} { + run {string first x abc\u7266x} } 4 -test string-4.10 {string first, unicode} { - string first \u7266 abc\u7266x -} 3 -test string-4.11 {string first, start index} { - string first \u7266 abc\u7266x 3 +test string-4.10.$noComp {string first, unicode} { + run {string first \u7266 abc\u7266x} } 3 -test string-4.12 {string first, start index} { - string first \u7266 abc\u7266x 4 -} -1 -test string-4.13 {string first, start index} { - string first \u7266 abc\u7266x end-2 +test string-4.11.$noComp {string first, start index} { + run {string first \u7266 abc\u7266x 3} } 3 -test string-4.14 {string first, negative start index} { - string first b abc -1 -} 1 -test string-4.15 {string first, ability to two-byte encoded utf-8 chars} { +test string-4.12.$noComp {string first, start index} -body { + run {string first \u7266 abc\u7266x 4} +} -result -1 +test string-4.13.$noComp {string first, start index} -body { + run {string first \u7266 abc\u7266x end-2} +} -result 3 +test string-4.14.$noComp {string first, negative start index} -body { + run {string first b abc -1} +} -result 1 +test string-4.15.$noComp {string first, ability to two-byte encoded utf-8 chars} -body { # Test for a bug in Tcl 8.3 where test for all-single-byte-encoded # strings was incorrect, leading to an index returned by [string first] # which pointed past the end of the string. set uchar \u057E ;# character with two-byte encoding in utf-8 - string first % %#$uchar$uchar#$uchar$uchar#% 3 -} 8 -test string-4.17 {string first, corner case} { - string first a aaa 4294967295 -} {0} -test string-4.18 {string first, corner case} { - string first a aaa -1 -} {0} -test string-4.19 {string first, corner case} { - string first a aaa end-5 -} {0} -test string-4.20 {string last, corner case} { - string last a aaa 4294967295 -} {-1} -test string-4.21 {string last, corner case} { - string last a aaa -1 -} {-1} -test string-4.22 {string last, corner case} { - string last a aaa end-5 -} {-1} + run {string first % %#$uchar$uchar#$uchar$uchar#% 3} +} -result 8 +test string-4.17.$noComp {string first, corner case} -body { + run {string first a aaa 4294967295} +} -result 0 +test string-4.18.$noComp {string first, corner case} -body { + run {string first a aaa -1} +} -result 0 +test string-4.19.$noComp {string first, corner case} -body { + run {string first a aaa end-5} +} -result 0 +test string-4.20.$noComp {string last, corner case} -body { + run {string last a aaa 4294967295} +} -result -1 +test string-4.21.$noComp {string last, corner case} -body { + run {string last a aaa -1} +} -result -1 +test string-4.22.$noComp {string last, corner case} { + run {string last a aaa end-5} +} -1 -test string-5.1 {string index} { - list [catch {string index} msg] $msg +test string-5.1.$noComp {string index} { + list [catch {run {string index}} msg] $msg } {1 {wrong # args: should be "string index string charIndex"}} -test string-5.2 {string index} { - list [catch {string index a b c} msg] $msg +test string-5.2.$noComp {string index} { + list [catch {run {string index a b c}} msg] $msg } {1 {wrong # args: should be "string index string charIndex"}} -test string-5.3 {string index} { - string index abcde 0 +test string-5.3.$noComp {string index} { + run {string index abcde 0} } a -test string-5.4 {string index} { - string in abcde 4 +test string-5.4.$noComp {string index} { + run {string in abcde 4} } e -test string-5.5 {string index} { - string index abcde 5 +test string-5.5.$noComp {string index} { + run {string index abcde 5} } {} -test string-5.6 {string index} { - list [catch {string index abcde -10} msg] $msg +test string-5.6.$noComp {string index} { + list [catch {run {string index abcde -10}} msg] $msg } {0 {}} -test string-5.7 {string index} { - list [catch {string index a xyz} msg] $msg +test string-5.7.$noComp {string index} { + list [catch {run {string index a xyz}} msg] $msg } {1 {bad index "xyz": must be integer?[+-]integer? or end?[+-]integer?}} -test string-5.8 {string index} { - string index abc end +test string-5.8.$noComp {string index} { + run {string index abc end} } c -test string-5.9 {string index} { - string index abc end-1 +test string-5.9.$noComp {string index} { + run {string index abc end-1} } b -test string-5.10 {string index, unicode} { - string index abc\u7266d 4 +test string-5.10.$noComp {string index, unicode} { + run {string index abc\u7266d 4} } d -test string-5.11 {string index, unicode} { - string index abc\u7266d 3 +test string-5.11.$noComp {string index, unicode} { + run {string index abc\u7266d 3} } \u7266 -test string-5.12 {string index, unicode over char length, under byte length} { - string index \334\374\334\374 6 -} {} -test string-5.13 {string index, bytearray object} { - string index [binary format a5 fuz] 0 +test string-5.12.$noComp {string index, unicode over char length, under byte length} -body { + run {string index \334\374\334\374 6} +} -result {} +test string-5.13.$noComp {string index, bytearray object} { + run {string index [binary format a5 fuz] 0} } f -test string-5.14 {string index, bytearray object} { - string index [binary format I* {0x50515253 0x52}] 3 +test string-5.14.$noComp {string index, bytearray object} { + run {string index [binary format I* {0x50515253 0x52}] 3} } S -test string-5.15 {string index, bytearray object} { +test string-5.15.$noComp {string index, bytearray object} { set b [binary format I* {0x50515253 0x52}] - set i1 [string index $b end-6] - set i2 [string index $b 1] - string compare $i1 $i2 + set i1 [run {string index $b end-6}] + set i2 [run {string index $b 1}] + run {string compare $i1 $i2} } 0 -test string-5.16 {string index, bytearray object with string obj shimmering} { +test string-5.16.$noComp {string index, bytearray object with string obj shimmering} { set str "0123456789\x00 abcdedfghi" binary scan $str H* dump - string compare [string index $str 10] \x00 + run {string compare [run {string index $str 10}] \x00} } 0 -test string-5.17 {string index, bad integer} -body { - list [catch {string index "abc" 0o8} msg] $msg +test string-5.17.$noComp {string index, bad integer} -body { + list [catch {run {string index "abc" 0o8}} msg] $msg } -match glob -result {1 {*invalid octal number*}} -test string-5.18 {string index, bad integer} -body { - list [catch {string index "abc" end-0o0289} msg] $msg +test string-5.18.$noComp {string index, bad integer} -body { + list [catch {run {string index "abc" end-0o0289}} msg] $msg } -match glob -result {1 {*invalid octal number*}} -test string-5.19 {string index, bytearray object out of bounds} { - string index [binary format I* {0x50515253 0x52}] -1 +test string-5.19.$noComp {string index, bytearray object out of bounds} { + run {string index [binary format I* {0x50515253 0x52}] -1} } {} -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 +test string-5.20.$noComp {string index, bytearray object out of bounds} -body { + run {string index [binary format I* {0x50515253 0x52}] 20} +} -result {} +test string-5.22.$noComp {string index} -constraints testbytestring -body { + run {list [scan [string index [testbytestring \xFF] 0] %c var] $var} } -result {1 255} proc largest_int {} { @@ -340,1609 +345,1609 @@ proc largest_int {} { return [expr {$int-1}] } -test string-6.1 {string is, not enough args} { - list [catch {string is} msg] $msg +test string-6.1.$noComp {string is, not enough args} { + list [catch {run {string is}} msg] $msg } {1 {wrong # args: should be "string is class ?-strict? ?-failindex var? str"}} -test string-6.2 {string is, not enough args} { - list [catch {string is alpha} msg] $msg +test string-6.2.$noComp {string is, not enough args} { + list [catch {run {string is alpha}} msg] $msg } {1 {wrong # args: should be "string is class ?-strict? ?-failindex var? str"}} -test string-6.3 {string is, bad args} { - list [catch {string is alpha -failin str} msg] $msg +test string-6.3.$noComp {string is, bad args} { + list [catch {run {string is alpha -failin str}} msg] $msg } {1 {wrong # args: should be "string is alpha ?-strict? ?-failindex var? str"}} -test string-6.4 {string is, too many args} { - list [catch {string is alpha -failin var -strict str more} msg] $msg +test string-6.4.$noComp {string is, too many args} { + list [catch {run {string is alpha -failin var -strict str more}} msg] $msg } {1 {wrong # args: should be "string is class ?-strict? ?-failindex var? str"}} -test string-6.5 {string is, class check} { - list [catch {string is bogus str} msg] $msg +test string-6.5.$noComp {string is, class check} { + list [catch {run {string is bogus str}} msg] $msg } {1 {bad class "bogus": must be alnum, alpha, ascii, control, boolean, digit, double, entier, false, graph, integer, list, lower, print, punct, space, true, upper, wideinteger, wordchar, or xdigit}} -test string-6.6 {string is, ambiguous class} { - list [catch {string is al str} msg] $msg +test string-6.6.$noComp {string is, ambiguous class} { + list [catch {run {string is al str}} msg] $msg } {1 {ambiguous class "al": must be alnum, alpha, ascii, control, boolean, digit, double, entier, false, graph, integer, list, lower, print, punct, space, true, upper, wideinteger, wordchar, or xdigit}} -test string-6.7 {string is alpha, all ok} { - string is alpha -strict -failindex var abc +test string-6.7.$noComp {string is alpha, all ok} { + run {string is alpha -strict -failindex var abc} } 1 -test string-6.8 {string is, error in var} { - list [string is alpha -failindex var abc5def] $var +test string-6.8.$noComp {string is, error in var} { + list [run {string is alpha -failindex var abc5def}] $var } {0 3} -test string-6.9 {string is, var shouldn't get set} { +test string-6.9.$noComp {string is, var shouldn't get set} { catch {unset var} - list [catch {string is alpha -failindex var abc; set var} msg] $msg + list [catch {run {string is alpha -failindex var abc; set var}} msg] $msg } {1 {can't read "var": no such variable}} -test string-6.10 {string is, ok on empty} { - string is alpha {} +test string-6.10.$noComp {string is, ok on empty} { + run {string is alpha {}} } 1 -test string-6.11 {string is, -strict check against empty} { - string is alpha -strict {} +test string-6.11.$noComp {string is, -strict check against empty} { + run {string is alpha -strict {}} } 0 -test string-6.12 {string is alnum, true} { - string is alnum abc123 +test string-6.12.$noComp {string is alnum, true} { + run {string is alnum abc123} } 1 -test string-6.13 {string is alnum, false} { - list [string is alnum -failindex var abc1.23] $var +test string-6.13.$noComp {string is alnum, false} { + list [run {string is alnum -failindex var abc1.23}] $var } {0 4} -test string-6.14 {string is alnum, unicode} "string is alnum abc\xfc" 1 -test string-6.15 {string is alpha, true} { - string is alpha abc +test string-6.14.$noComp {string is alnum, unicode} "run {string is alnum abc\xfc}" 1 +test string-6.15.$noComp {string is alpha, true} { + run {string is alpha abc} } 1 -test string-6.16 {string is alpha, false} { - list [string is alpha -fail var a1bcde] $var +test string-6.16.$noComp {string is alpha, false} { + list [run {string is alpha -fail var a1bcde}] $var } {0 1} -test string-6.17 {string is alpha, unicode} { - string is alpha abc\374 +test string-6.17.$noComp {string is alpha, unicode} { + run {string is alpha abc\374} } 1 -test string-6.18 {string is ascii, true} { - string is ascii abc\u007Fend\u0000 +test string-6.18.$noComp {string is ascii, true} { + run {string is ascii abc\x7Fend\x00} } 1 -test string-6.19 {string is ascii, false} { - list [string is ascii -fail var abc\u0000def\u0080more] $var +test string-6.19.$noComp {string is ascii, false} { + list [run {string is ascii -fail var abc\x00def\x80more}] $var } {0 7} -test string-6.20 {string is boolean, true} { - string is boolean true +test string-6.20.$noComp {string is boolean, true} { + run {string is boolean true} } 1 -test string-6.21 {string is boolean, true} { - string is boolean f +test string-6.21.$noComp {string is boolean, true} { + run {string is boolean f} } 1 -test string-6.22 {string is boolean, true based on type} { - string is bool [string compare a a] +test string-6.22.$noComp {string is boolean, true based on type} { + run {string is bool [run {string compare a a}]} } 1 -test string-6.23 {string is boolean, false} { - list [string is bool -fail var yada] $var +test string-6.23.$noComp {string is boolean, false} { + list [run {string is bool -fail var yada}] $var } {0 0} -test string-6.24 {string is digit, true} { - string is digit 0123456789 +test string-6.24.$noComp {string is digit, true} { + run {string is digit 0123456789} } 1 -test string-6.25 {string is digit, false} { - list [string is digit -fail var 0123\u00DC567] $var +test string-6.25.$noComp {string is digit, false} { + list [run {string is digit -fail var 0123\xDC567}] $var } {0 4} -test string-6.26 {string is digit, false} { - list [string is digit -fail var +123567] $var +test string-6.26.$noComp {string is digit, false} { + list [run {string is digit -fail var +123567}] $var } {0 0} -test string-6.27 {string is double, true} { - string is double 1 +test string-6.27.$noComp {string is double, true} { + run {string is double 1} } 1 -test string-6.28 {string is double, true} { - string is double [expr {double(1)}] +test string-6.28.$noComp {string is double, true} { + run {string is double [expr {double(1)}]} } 1 -test string-6.29 {string is double, true} { - string is double 1.0 +test string-6.29.$noComp {string is double, true} { + run {string is double 1.0} } 1 -test string-6.30 {string is double, true} { - string is double [string compare a a] +test string-6.30.$noComp {string is double, true} { + run {string is double [run {string compare a a}]} } 1 -test string-6.31 {string is double, true} { - string is double " +1.0e-1 " +test string-6.31.$noComp {string is double, true} { + run {string is double " +1.0e-1 "} } 1 -test string-6.32 {string is double, true} { - string is double "\n1.0\v" +test string-6.32.$noComp {string is double, true} { + run {string is double "\n1.0\v"} } 1 -test string-6.33 {string is double, false} { - list [string is double -fail var 1abc] $var +test string-6.33.$noComp {string is double, false} { + list [run {string is double -fail var 1abc}] $var } {0 1} -test string-6.34 {string is double, false} { - list [string is double -fail var abc] $var +test string-6.34.$noComp {string is double, false} { + list [run {string is double -fail var abc}] $var } {0 0} -test string-6.35 {string is double, false} { - list [string is double -fail var " 1.0e4e4 "] $var +test string-6.35.$noComp {string is double, false} { + list [run {string is double -fail var " 1.0e4e4 "}] $var } {0 8} -test string-6.36 {string is double, false} { - list [string is double -fail var "\n"] $var +test string-6.36.$noComp {string is double, false} { + list [run {string is double -fail var "\n"}] $var } {0 0} -test string-6.37 {string is double, false on int overflow} -setup { +test string-6.37.$noComp {string is double, false on int overflow} -setup { set var priorValue } -body { # Make it the largest int recognizable, with one more digit for overflow # Since bignums arrived in Tcl 8.5, the sense of this test changed. # Now integer values that exceed native limits become bignums, and # bignums can convert to doubles without error. - list [string is double -fail var [largest_int]0] $var + list [run {string is double -fail var [largest_int]0}] $var } -result {1 priorValue} # string-6.38 removed, underflow on input is no longer an error. -test string-6.39 {string is double, false} { +test string-6.39.$noComp {string is double, false} { # This test is non-portable because IRIX thinks # that .e1 is a valid double - this is really a bug # on IRIX as .e1 should NOT be a valid double # # Portable now. Tcl 8.5 does its own double parsing. - list [string is double -fail var .e1] $var + list [run {string is double -fail var .e1}] $var } {0 0} -test string-6.40 {string is false, true} { - string is false false +test string-6.40.$noComp {string is false, true} { + run {string is false false} } 1 -test string-6.41 {string is false, true} { - string is false FaLsE +test string-6.41.$noComp {string is false, true} { + run {string is false FaLsE} } 1 -test string-6.42 {string is false, true} { - string is false N +test string-6.42.$noComp {string is false, true} { + run {string is false N} } 1 -test string-6.43 {string is false, true} { - string is false 0 +test string-6.43.$noComp {string is false, true} { + run {string is false 0} } 1 -test string-6.44 {string is false, true} { - string is false off +test string-6.44.$noComp {string is false, true} { + run {string is false off} } 1 -test string-6.45 {string is false, false} { - list [string is false -fail var abc] $var +test string-6.45.$noComp {string is false, false} { + list [run {string is false -fail var abc}] $var } {0 0} -test string-6.46 {string is false, false} { +test string-6.46.$noComp {string is false, false} { catch {unset var} - list [string is false -fail var Y] $var + list [run {string is false -fail var Y}] $var } {0 0} -test string-6.47 {string is false, false} { +test string-6.47.$noComp {string is false, false} { catch {unset var} - list [string is false -fail var offensive] $var + list [run {string is false -fail var offensive}] $var } {0 0} -test string-6.48 {string is integer, true} { - string is integer +1234567890 +test string-6.48.$noComp {string is integer, true} { + run {string is integer +1234567890} } 1 -test string-6.49 {string is integer, true on type} { - string is integer [expr {int(50.0)}] +test string-6.49.$noComp {string is integer, true on type} { + run {string is integer [expr {int(50.0)}]} } 1 -test string-6.50 {string is integer, true} { - string is integer [list -10] +test string-6.50.$noComp {string is integer, true} { + run {string is integer [list -10]} } 1 -test string-6.51 {string is integer, true as hex} { - string is integer 0xabcdef +test string-6.51.$noComp {string is integer, true as hex} { + run {string is integer 0xabcdef} } 1 -test string-6.52 {string is integer, true as octal} { - string is integer 012345 +test string-6.52.$noComp {string is integer, true as octal} { + run {string is integer 012345} } 1 -test string-6.53 {string is integer, true with whitespace} { - string is integer " \n1234\v" +test string-6.53.$noComp {string is integer, true with whitespace} { + run {string is integer " \n1234\v"} } 1 -test string-6.54 {string is integer, false} { - list [string is integer -fail var 123abc] $var +test string-6.54.$noComp {string is integer, false} { + list [run {string is integer -fail var 123abc}] $var } {0 3} -test string-6.55 {string is integer, false on overflow} { - list [string is integer -fail var +[largest_int]0] $var +test string-6.55.$noComp {string is integer, false on overflow} { + list [run {string is integer -fail var +[largest_int]0}] $var } {0 -1} -test string-6.56 {string is integer, false} { - list [string is integer -fail var [expr {double(1)}]] $var +test string-6.56.$noComp {string is integer, false} { + list [run {string is integer -fail var [expr {double(1)}]}] $var } {0 1} -test string-6.57 {string is integer, false} { - list [string is integer -fail var " "] $var +test string-6.57.$noComp {string is integer, false} { + list [run {string is integer -fail var " "}] $var } {0 0} -test string-6.58 {string is integer, false on bad octal} { - list [string is integer -fail var 0o36963] $var +test string-6.58.$noComp {string is integer, false on bad octal} { + list [run {string is integer -fail var 0o36963}] $var } {0 4} -test string-6.58.1 {string is integer, false on bad octal} { - list [string is integer -fail var 0o36963] $var +test string-6.58.1.$noComp {string is integer, false on bad octal} { + list [run {string is integer -fail var 0o36963}] $var } {0 4} -test string-6.59 {string is integer, false on bad hex} { - list [string is integer -fail var 0X345XYZ] $var +test string-6.59.$noComp {string is integer, false on bad hex} { + list [run {string is integer -fail var 0X345XYZ}] $var } {0 5} -test string-6.60 {string is lower, true} { - string is lower abc +test string-6.60.$noComp {string is lower, true} { + run {string is lower abc} } 1 -test string-6.61 {string is lower, unicode true} { - string is lower abc\u00FCue +test string-6.61.$noComp {string is lower, unicode true} { + run {string is lower abc\xFCue} } 1 -test string-6.62 {string is lower, false} { - list [string is lower -fail var aBc] $var +test string-6.62.$noComp {string is lower, false} { + list [run {string is lower -fail var aBc}] $var } {0 1} -test string-6.63 {string is lower, false} { - list [string is lower -fail var abc1] $var +test string-6.63.$noComp {string is lower, false} { + list [run {string is lower -fail var abc1}] $var } {0 3} -test string-6.64 {string is lower, unicode false} { - list [string is lower -fail var ab\u00DCUE] $var +test string-6.64.$noComp {string is lower, unicode false} { + list [run {string is lower -fail var ab\xDCUE}] $var } {0 2} -test string-6.65 {string is space, true} { - string is space " \t\n\v\f" +test string-6.65.$noComp {string is space, true} { + run {string is space " \t\n\v\f"} } 1 -test string-6.66 {string is space, false} { - list [string is space -fail var " \t\n\v1\f"] $var +test string-6.66.$noComp {string is space, false} { + list [run {string is space -fail var " \t\n\v1\f"}] $var } {0 4} -test string-6.67 {string is true, true} { - string is true true +test string-6.67.$noComp {string is true, true} { + run {string is true true} } 1 -test string-6.68 {string is true, true} { - string is true TrU +test string-6.68.$noComp {string is true, true} { + run {string is true TrU} } 1 -test string-6.69 {string is true, true} { - string is true ye +test string-6.69.$noComp {string is true, true} { + run {string is true ye} } 1 -test string-6.70 {string is true, true} { - string is true 1 +test string-6.70.$noComp {string is true, true} { + run {string is true 1} } 1 -test string-6.71 {string is true, true} { - string is true on +test string-6.71.$noComp {string is true, true} { + run {string is true on} } 1 -test string-6.72 {string is true, false} { - list [string is true -fail var onto] $var +test string-6.72.$noComp {string is true, false} { + list [run {string is true -fail var onto}] $var } {0 0} -test string-6.73 {string is true, false} { +test string-6.73.$noComp {string is true, false} { catch {unset var} - list [string is true -fail var 25] $var + list [run {string is true -fail var 25}] $var } {0 0} -test string-6.74 {string is true, false} { +test string-6.74.$noComp {string is true, false} { catch {unset var} - list [string is true -fail var no] $var + list [run {string is true -fail var no}] $var } {0 0} -test string-6.75 {string is upper, true} { - string is upper ABC +test string-6.75.$noComp {string is upper, true} { + run {string is upper ABC} } 1 -test string-6.76 {string is upper, unicode true} { - string is upper ABC\u00DCUE +test string-6.76.$noComp {string is upper, unicode true} { + run {string is upper ABC\xDCUE} } 1 -test string-6.77 {string is upper, false} { - list [string is upper -fail var AbC] $var +test string-6.77.$noComp {string is upper, false} { + list [run {string is upper -fail var AbC}] $var } {0 1} -test string-6.78 {string is upper, false} { - list [string is upper -fail var AB2C] $var +test string-6.78.$noComp {string is upper, false} { + list [run {string is upper -fail var AB2C}] $var } {0 2} -test string-6.79 {string is upper, unicode false} { - list [string is upper -fail var ABC\u00FCue] $var +test string-6.79.$noComp {string is upper, unicode false} { + list [run {string is upper -fail var ABC\xFCue}] $var } {0 3} -test string-6.80 {string is wordchar, true} { - string is wordchar abc_123 +test string-6.80.$noComp {string is wordchar, true} { + run {string is wordchar abc_123} } 1 -test string-6.81 {string is wordchar, unicode true} { - string is wordchar abc\u00FCab\u00DCAB\u5001 +test string-6.81.$noComp {string is wordchar, unicode true} { + run {string is wordchar abc\xFCab\xDCAB\u5001} } 1 -test string-6.82 {string is wordchar, false} { - list [string is wordchar -fail var abcd.ef] $var +test string-6.82.$noComp {string is wordchar, false} { + list [run {string is wordchar -fail var abcd.ef}] $var } {0 4} -test string-6.83 {string is wordchar, unicode false} { - list [string is wordchar -fail var abc\u0080def] $var +test string-6.83.$noComp {string is wordchar, unicode false} { + list [run {string is wordchar -fail var abc\x80def}] $var } {0 3} -test string-6.84 {string is control} { +test string-6.84.$noComp {string is control} { ## Control chars are in the ranges ## 00..1F && 7F..9F - list [string is control -fail var \x00\x01\x10\x1F\x7F\x80\x9F\x60] $var + list [run {string is control -fail var \x00\x01\x10\x1F\x7F\x80\x9F\x60}] $var } {0 7} -test string-6.85 {string is control} { - string is control \u0100 +test string-6.85.$noComp {string is control} { + run {string is control \u0100} } 0 -test string-6.86 {string is graph} { +test string-6.86.$noComp {string is graph} { ## graph is any print char, except space - list [string is gra -fail var "0123abc!@#\$\u0100\UE0100\UE01EF "] $var + list [run {string is gra -fail var "0123abc!@#\$\u0100\UE0100\UE01EF "}] $var } {0 14} -test string-6.87 {string is print} { +test string-6.87.$noComp {string is print} { ## basically any printable char - list [string is print -fail var "0123abc!@#\$\u0100 \UE0100\UE01EF\u0010"] $var + list [run {string is print -fail var "0123abc!@#\$\u0100 \UE0100\UE01EF\x10"}] $var } {0 15} -test string-6.88 {string is punct} { +test string-6.88.$noComp {string is punct} { ## any graph char that isn't alnum - list [string is punct -fail var "_!@#\u00BEq0"] $var + list [run {string is punct -fail var "_!@#\xBEq0"}] $var } {0 4} -test string-6.89 {string is xdigit} { - list [string is xdigit -fail var 0123456789\u0061bcdefABCDEFg] $var +test string-6.89.$noComp {string is xdigit} { + list [run {string is xdigit -fail var 0123456789\x61bcdefABCDEFg}] $var } {0 22} -test string-6.90 {string is integer, bad integers} { +test string-6.90.$noComp {string is integer, bad integers} { # SF bug #634856 set result "" set numbers [list 1 +1 ++1 +-1 -+1 -1 --1 "- +1"] foreach num $numbers { - lappend result [string is int -strict $num] + lappend result [run {string is int -strict $num}] } return $result } {1 1 0 0 0 1 0 0} -test string-6.91 {string is double, bad doubles} { +test string-6.91.$noComp {string is double, bad doubles} { set result "" set numbers [list 1.0 +1.0 ++1.0 +-1.0 -+1.0 -1.0 --1.0 "- +1.0"] foreach num $numbers { - lappend result [string is double -strict $num] + lappend result [run {string is double -strict $num}] } return $result } {1 1 0 0 0 1 0 0} -test string-6.92 {string is integer, 32-bit overflow} { +test string-6.92.$noComp {string is integer, 32-bit overflow} { # Bug 718878 set x 0x100000000 - list [string is integer -failindex var $x] $var + list [run {string is integer -failindex var $x}] $var } {0 -1} -test string-6.93 {string is integer, 32-bit overflow} { +test string-6.93.$noComp {string is integer, 32-bit overflow} { # Bug 718878 set x 0x100000000 append x "" - list [string is integer -failindex var $x] $var + list [run {string is integer -failindex var $x}] $var } {0 -1} -test string-6.94 {string is integer, 32-bit overflow} { +test string-6.94.$noComp {string is integer, 32-bit overflow} { # Bug 718878 set x 0x100000000 - list [string is integer -failindex var [expr {$x}]] $var + list [run {string is integer -failindex var [expr {$x}]}] $var } {0 -1} -test string-6.95 {string is wideinteger, true} { - string is wideinteger +1234567890 +test string-6.95.$noComp {string is wideinteger, true} { + run {string is wideinteger +1234567890} } 1 -test string-6.96 {string is wideinteger, true on type} { - string is wideinteger [expr {wide(50.0)}] +test string-6.96.$noComp {string is wideinteger, true on type} { + run {string is wideinteger [expr {wide(50.0)}]} } 1 -test string-6.97 {string is wideinteger, true} { - string is wideinteger [list -10] +test string-6.97.$noComp {string is wideinteger, true} { + run {string is wideinteger [list -10]} } 1 -test string-6.98 {string is wideinteger, true as hex} { - string is wideinteger 0xabcdef +test string-6.98.$noComp {string is wideinteger, true as hex} { + run {string is wideinteger 0xabcdef} } 1 -test string-6.99 {string is wideinteger, true as octal} { - string is wideinteger 0123456 +test string-6.99.$noComp {string is wideinteger, true as octal} { + run {string is wideinteger 0123456} } 1 -test string-6.100 {string is wideinteger, true with whitespace} { - string is wideinteger " \n1234\v" +test string-6.100.$noComp {string is wideinteger, true with whitespace} { + run {string is wideinteger " \n1234\v"} } 1 -test string-6.101 {string is wideinteger, false} { - list [string is wideinteger -fail var 123abc] $var +test string-6.101.$noComp {string is wideinteger, false} { + list [run {string is wideinteger -fail var 123abc}] $var } {0 3} -test string-6.102 {string is wideinteger, false on overflow} { - list [string is wideinteger -fail var +[largest_int]0] $var +test string-6.102.$noComp {string is wideinteger, false on overflow} { + list [run {string is wideinteger -fail var +[largest_int]0}] $var } {0 -1} -test string-6.103 {string is wideinteger, false} { - list [string is wideinteger -fail var [expr {double(1)}]] $var +test string-6.103.$noComp {string is wideinteger, false} { + list [run {string is wideinteger -fail var [expr {double(1)}]}] $var } {0 1} -test string-6.104 {string is wideinteger, false} { - list [string is wideinteger -fail var " "] $var +test string-6.104.$noComp {string is wideinteger, false} { + list [run {string is wideinteger -fail var " "}] $var } {0 0} -test string-6.105 {string is wideinteger, false on bad octal} { - list [string is wideinteger -fail var 0o36963] $var +test string-6.105.$noComp {string is wideinteger, false on bad octal} { + list [run {string is wideinteger -fail var 0o36963}] $var } {0 4} -test string-6.105.1 {string is wideinteger, false on bad octal} { - list [string is wideinteger -fail var 0o36963] $var +test string-6.105.1.$noComp {string is wideinteger, false on bad octal} { + list [run {string is wideinteger -fail var 0o36963}] $var } {0 4} -test string-6.106 {string is wideinteger, false on bad hex} { - list [string is wideinteger -fail var 0X345XYZ] $var +test string-6.106.$noComp {string is wideinteger, false on bad hex} { + list [run {string is wideinteger -fail var 0X345XYZ}] $var } {0 5} -test string-6.107 {string is integer, bad integers} { +test string-6.107.$noComp {string is integer, bad integers} { # SF bug #634856 set result "" set numbers [list 1 +1 ++1 +-1 -+1 -1 --1 "- +1"] foreach num $numbers { - lappend result [string is wideinteger -strict $num] + lappend result [run {string is wideinteger -strict $num}] } return $result } {1 1 0 0 0 1 0 0} -test string-6.108 {string is double, Bug 1382287} { +test string-6.108.$noComp {string is double, Bug 1382287} { set x 2turtledoves - string is double $x - string is double $x + run {string is double $x} + run {string is double $x} } 0 -test string-6.109 {string is double, Bug 1360532} { - string is double 1\u00A0 +test string-6.109.$noComp {string is double, Bug 1360532} { + run {string is double 1\xA0} } 0 -test string-6.110 {string is entier, true} { - string is entier +1234567890 +test string-6.110.$noComp {string is entier, true} { + run {string is entier +1234567890} } 1 -test string-6.111 {string is entier, true on type} { - string is entier [expr {wide(50.0)}] +test string-6.111.$noComp {string is entier, true on type} { + run {string is entier [expr {wide(50.0)}]} } 1 -test string-6.112 {string is entier, true} { - string is entier [list -10] +test string-6.112.$noComp {string is entier, true} { + run {string is entier [list -10]} } 1 -test string-6.113 {string is entier, true as hex} { - string is entier 0xabcdef +test string-6.113.$noComp {string is entier, true as hex} { + run {string is entier 0xabcdef} } 1 -test string-6.114 {string is entier, true as octal} { - string is entier 0123456 +test string-6.114.$noComp {string is entier, true as octal} { + run {string is entier 0123456} } 1 -test string-6.115 {string is entier, true with whitespace} { - string is entier " \n1234\v" +test string-6.115.$noComp {string is entier, true with whitespace} { + run {string is entier " \n1234\v"} } 1 -test string-6.116 {string is entier, false} { - list [string is entier -fail var 123abc] $var +test string-6.116.$noComp {string is entier, false} { + list [run {string is entier -fail var 123abc}] $var } {0 3} -test string-6.117 {string is entier, false} { - list [string is entier -fail var 123123123123123123123123123123123123123123123123123123123123123123123123123123123123abc] $var +test string-6.117.$noComp {string is entier, false} { + list [run {string is entier -fail var 123123123123123123123123123123123123123123123123123123123123123123123123123123123123abc}] $var } {0 84} -test string-6.118 {string is entier, false} { - list [string is entier -fail var [expr {double(1)}]] $var +test string-6.118.$noComp {string is entier, false} { + list [run {string is entier -fail var [expr {double(1)}]}] $var } {0 1} -test string-6.119 {string is entier, false} { - list [string is entier -fail var " "] $var +test string-6.119.$noComp {string is entier, false} { + list [run {string is entier -fail var " "}] $var } {0 0} -test string-6.120 {string is entier, false on bad octal} { - list [string is entier -fail var 0o36963] $var +test string-6.120.$noComp {string is entier, false on bad octal} { + list [run {string is entier -fail var 0o36963}] $var } {0 4} -test string-6.121.1 {string is entier, false on bad octal} { - list [string is entier -fail var 0o36963] $var +test string-6.121.1.$noComp {string is entier, false on bad octal} { + list [run {string is entier -fail var 0o36963}] $var } {0 4} -test string-6.122 {string is entier, false on bad hex} { - list [string is entier -fail var 0X345XYZ] $var +test string-6.122.$noComp {string is entier, false on bad hex} { + list [run {string is entier -fail var 0X345XYZ}] $var } {0 5} -test string-6.123 {string is entier, bad integers} { +test string-6.123.$noComp {string is entier, bad integers} { # SF bug #634856 set result "" set numbers [list 1 +1 ++1 +-1 -+1 -1 --1 "- +1"] foreach num $numbers { - lappend result [string is entier -strict $num] + lappend result [run {string is entier -strict $num}] } return $result } {1 1 0 0 0 1 0 0} -test string-6.124 {string is entier, true} { - string is entier +1234567890123456789012345678901234567890 +test string-6.124.$noComp {string is entier, true} { + run {string is entier +1234567890123456789012345678901234567890} } 1 -test string-6.125 {string is entier, true} { - string is entier [list -10000000000000000000000000000000000000000000000000000000000000000000000000000000000000] +test string-6.125.$noComp {string is entier, true} { + run {string is entier [list -10000000000000000000000000000000000000000000000000000000000000000000000000000000000000]} } 1 -test string-6.126 {string is entier, true as hex} { - string is entier 0xabcdefabcdefabcdefabcdefabcdefabcdefabcdefabcdefabcdefabcdefabcdefabcdefabcdefabcdef +test string-6.126.$noComp {string is entier, true as hex} { + run {string is entier 0xabcdefabcdefabcdefabcdefabcdefabcdefabcdefabcdefabcdefabcdefabcdefabcdefabcdefabcdef} } 1 -test string-6.127 {string is entier, true as octal} { - string is entier 0123456112341234561234565623456123456123456123456123456123456123456123456123456123456 +test string-6.127.$noComp {string is entier, true as octal} { + run {string is entier 0123456112341234561234565623456123456123456123456123456123456123456123456123456123456} } 1 -test string-6.128 {string is entier, true with whitespace} { - string is entier " \n12340000000000000000000000000000000000000000000000000000000000000000000000000000000000000\v" +test string-6.128.$noComp {string is entier, true with whitespace} { + run {string is entier " \n12340000000000000000000000000000000000000000000000000000000000000000000000000000000000000\v"} } 1 -test string-6.129 {string is entier, false on bad octal} { - list [string is entier -fail var 0o1234561123412345612345656234561234561234561234561234561234561234561234561234561234536963] $var +test string-6.129.$noComp {string is entier, false on bad octal} { + list [run {string is entier -fail var 0o1234561123412345612345656234561234561234561234561234561234561234561234561234561234536963}] $var } {0 87} -test string-6.130.1 {string is entier, false on bad octal} { - list [string is entier -fail var 0o1234561123412345612345656234561234561234561234561234561234561234561234561234561234536963] $var +test string-6.130.1.$noComp {string is entier, false on bad octal} { + list [run {string is entier -fail var 0o1234561123412345612345656234561234561234561234561234561234561234561234561234561234536963}] $var } {0 87} -test string-6.131 {string is entier, false on bad hex} { - list [string is entier -fail var 0X12345611234123456123456562345612345612345612345612345612345612345612345612345612345345XYZ] $var +test string-6.131.$noComp {string is entier, false on bad hex} { + list [run {string is entier -fail var 0X12345611234123456123456562345612345612345612345612345612345612345612345612345612345345XYZ}] $var } {0 88} catch {rename largest_int {}} -test string-7.1 {string last, not enough args} { - list [catch {string last a} msg] $msg +test string-7.1.$noComp {string last, not enough args} { + list [catch {run {string last a}} msg] $msg } {1 {wrong # args: should be "string last needleString haystackString ?startIndex?"}} -test string-7.2 {string last, bad args} { - list [catch {string last a b c} msg] $msg +test string-7.2.$noComp {string last, bad args} { + list [catch {run {string last a b c}} msg] $msg } {1 {bad index "c": must be integer?[+-]integer? or end?[+-]integer?}} -test string-7.3 {string last, too many args} { - list [catch {string last a b c d} msg] $msg +test string-7.3.$noComp {string last, too many args} { + list [catch {run {string last a b c d}} msg] $msg } {1 {wrong # args: should be "string last needleString haystackString ?startIndex?"}} -test string-7.4 {string last} { - string la xxx xxxx123xx345x678 +test string-7.4.$noComp {string last} { + run {string la xxx xxxx123xx345x678} } 1 -test string-7.5 {string last} { - string last xx xxxx123xx345x678 +test string-7.5.$noComp {string last} { + run {string last xx xxxx123xx345x678} } 7 -test string-7.6 {string last} { - string las x xxxx123xx345x678 +test string-7.6.$noComp {string last} { + run {string las x xxxx123xx345x678} } 12 -test string-7.7 {string last, unicode} { - string las x xxxx12\u7266xx345x678 +test string-7.7.$noComp {string last, unicode} { + run {string las x xxxx12\u7266xx345x678} } 12 -test string-7.8 {string last, unicode} { - string las \u7266 xxxx12\u7266xx345x678 +test string-7.8.$noComp {string last, unicode} { + run {string las \u7266 xxxx12\u7266xx345x678} } 6 -test string-7.9 {string last, stop index} { - string las \u7266 xxxx12\u7266xx345x678 +test string-7.9.$noComp {string last, stop index} { + run {string las \u7266 xxxx12\u7266xx345x678} } 6 -test string-7.10 {string last, unicode} { - string las \u7266 xxxx12\u7266xx345x678 +test string-7.10.$noComp {string last, unicode} { + run {string las \u7266 xxxx12\u7266xx345x678} } 6 -test string-7.11 {string last, start index} { - string last \u7266 abc\u7266x 3 +test string-7.11.$noComp {string last, start index} { + run {string last \u7266 abc\u7266x 3} } 3 -test string-7.12 {string last, start index} { - string last \u7266 abc\u7266x 2 +test string-7.12.$noComp {string last, start index} { + run {string last \u7266 abc\u7266x 2} } -1 -test string-7.13 {string last, start index} { +test string-7.13.$noComp {string last, start index} { ## Constrain to last 'a' should work - string last ba badbad end-1 + run {string last ba badbad end-1} } 3 -test string-7.14 {string last, start index} { +test string-7.14.$noComp {string last, start index} { ## Constrain to last 'b' should skip last 'ba' - string last ba badbad end-2 + run {string last ba badbad end-2} } 0 -test string-7.15 {string last, start index} { - string last \334a \334ad\334ad 0 +test string-7.15.$noComp {string last, start index} { + run {string last \334a \334ad\334ad 0} } -1 -test string-7.16 {string last, start index} { - string last \334a \334ad\334ad end-1 +test string-7.16.$noComp {string last, start index} { + run {string last \334a \334ad\334ad end-1} } 3 -test string-8.1 {string bytelength} { - list [catch {string bytelength} msg] $msg +test string-8.1.$noComp {string bytelength} { + list [catch {run {string bytelength}} msg] $msg } {1 {wrong # args: should be "string bytelength string"}} -test string-8.2 {string bytelength} { - list [catch {string bytelength a b} msg] $msg +test string-8.2.$noComp {string bytelength} { + list [catch {run {string bytelength a b}} msg] $msg } {1 {wrong # args: should be "string bytelength string"}} -test string-8.3 {string bytelength} { - string bytelength "\u00c7" +test string-8.3.$noComp {string bytelength} { + run {string bytelength "\xC7"} } 2 -test string-8.4 {string bytelength} { - string b "" +test string-8.4.$noComp {string bytelength} { + run {string b ""} } 0 -test string-9.1 {string length} { - list [catch {string length} msg] $msg +test string-9.1.$noComp {string length} { + list [catch {run {string length}} msg] $msg } {1 {wrong # args: should be "string length string"}} -test string-9.2 {string length} { - list [catch {string length a b} msg] $msg +test string-9.2.$noComp {string length} { + list [catch {run {string length a b}} msg] $msg } {1 {wrong # args: should be "string length string"}} -test string-9.3 {string length} { - string length "a little string" +test string-9.3.$noComp {string length} { + run {string length "a little string"} } 15 -test string-9.4 {string length} { - string le "" +test string-9.4.$noComp {string length} { + run {string le ""} } 0 -test string-9.5 {string length, unicode} { - string le "abcd\u7266" +test string-9.5.$noComp {string length, unicode} { + run {string le "abcd\u7266"} } 5 -test string-9.6 {string length, bytearray object} { - string length [binary format a5 foo] +test string-9.6.$noComp {string length, bytearray object} { + run {string length [binary format a5 foo]} } 5 -test string-9.7 {string length, bytearray object} { - string length [binary format I* {0x50515253 0x52}] +test string-9.7.$noComp {string length, bytearray object} { + run {string length [binary format I* {0x50515253 0x52}]} } 8 -test string-10.1 {string map, not enough args} { - list [catch {string map} msg] $msg +test string-10.1.$noComp {string map, not enough args} { + list [catch {run {string map}} msg] $msg } {1 {wrong # args: should be "string map ?-nocase? charMap string"}} -test string-10.2 {string map, bad args} { - list [catch {string map {a b} abba oops} msg] $msg +test string-10.2.$noComp {string map, bad args} { + list [catch {run {string map {a b} abba oops}} msg] $msg } {1 {bad option "a b": must be -nocase}} -test string-10.3 {string map, too many args} { - list [catch {string map -nocase {a b} str1 str2} msg] $msg +test string-10.3.$noComp {string map, too many args} { + list [catch {run {string map -nocase {a b} str1 str2}} msg] $msg } {1 {wrong # args: should be "string map ?-nocase? charMap string"}} -test string-10.4 {string map} { - string map {a b} abba +test string-10.4.$noComp {string map} { + run {string map {a b} abba} } {bbbb} -test string-10.5 {string map} { - string map {a b} a +test string-10.5.$noComp {string map} { + run {string map {a b} a} } {b} -test string-10.6 {string map -nocase} { - string map -nocase {a b} Abba +test string-10.6.$noComp {string map -nocase} { + run {string map -nocase {a b} Abba} } {bbbb} -test string-10.7 {string map} { - string map {abc 321 ab * a A} aabcabaababcab +test string-10.7.$noComp {string map} { + run {string map {abc 321 ab * a A} aabcabaababcab} } {A321*A*321*} -test string-10.8 {string map -nocase} { - string map -nocase {aBc 321 Ab * a A} aabcabaababcab +test string-10.8.$noComp {string map -nocase} { + run {string map -nocase {aBc 321 Ab * a A} aabcabaababcab} } {A321*A*321*} -test string-10.9 {string map -nocase} { - string map -no {abc 321 Ab * a A} aAbCaBaAbAbcAb +test string-10.9.$noComp {string map -nocase} { + run {string map -no {abc 321 Ab * a A} aAbCaBaAbAbcAb} } {A321*A*321*} -test string-10.10 {string map} { - list [catch {string map {a b c} abba} msg] $msg +test string-10.10.$noComp {string map} { + list [catch {run {string map {a b c} abba}} msg] $msg } {1 {char map list unbalanced}} -test string-10.11 {string map, nulls} { - string map {\x00 NULL blah \x00nix} {qwerty} +test string-10.11.$noComp {string map, nulls} { + run {string map {\x00 NULL blah \x00nix} {qwerty}} } {qwerty} -test string-10.12 {string map, unicode} { - string map [list \374 ue UE \334] "a\374ueUE\000EU" -} aueue\334\0EU -test string-10.13 {string map, -nocase unicode} { - string map -nocase [list \374 ue UE \334] "a\374ueUE\000EU" -} aue\334\334\0EU -test string-10.14 {string map, -nocase null arguments} { - string map -nocase {{} abc} foo +test string-10.12.$noComp {string map, unicode} { + run {string map [list \374 ue UE \334] "a\374ueUE\x00EU"} +} aueue\334\x00EU +test string-10.13.$noComp {string map, -nocase unicode} { + run {string map -nocase [list \374 ue UE \334] "a\374ueUE\x00EU"} +} aue\334\334\x00EU +test string-10.14.$noComp {string map, -nocase null arguments} { + run {string map -nocase {{} abc} foo} } foo -test string-10.15 {string map, one pair case} { - string map -nocase {abc 32} aAbCaBaAbAbcAb +test string-10.15.$noComp {string map, one pair case} { + run {string map -nocase {abc 32} aAbCaBaAbAbcAb} } {a32aBaAb32Ab} -test string-10.16 {string map, one pair case} { - string map -nocase {ab 4321} aAbCaBaAbAbcAb +test string-10.16.$noComp {string map, one pair case} { + run {string map -nocase {ab 4321} aAbCaBaAbAbcAb} } {a4321C4321a43214321c4321} -test string-10.17 {string map, one pair case} { - string map {Ab 4321} aAbCaBaAbAbcAb +test string-10.17.$noComp {string map, one pair case} { + run {string map {Ab 4321} aAbCaBaAbAbcAb} } {a4321CaBa43214321c4321} -test string-10.18 {string map, empty argument} { - string map -nocase {{} abc} foo +test string-10.18.$noComp {string map, empty argument} { + run {string map -nocase {{} abc} foo} } foo -test string-10.19 {string map, empty arguments} { - string map -nocase {{} abc f bar {} def} foo +test string-10.19.$noComp {string map, empty arguments} { + run {string map -nocase {{} abc f bar {} def} foo} } baroo -test string-10.20 {string map, dictionaries don't alter map ordering} { +test string-10.20.$noComp {string map, dictionaries don't alter map ordering} { set map {aa X a Y} - list [string map [dict create aa X a Y] aaa] [string map $map aaa] [dict size $map] [string map $map aaa] + list [run {string map [dict create aa X a Y] aaa}] [run {string map $map aaa}] [dict size $map] [run {string map $map aaa}] } {XY XY 2 XY} -test string-10.20.1 {string map, dictionaries don't alter map ordering} { +test string-10.20.1.$noComp {string map, dictionaries don't alter map ordering} { set map {a X b Y a Z} - list [string map [dict create a X b Y a Z] aaa] [string map $map aaa] [dict size $map] [string map $map aaa] + list [run {string map [dict create a X b Y a Z] aaa}] [run {string map $map aaa}] [dict size $map] [run {string map $map aaa}] } {ZZZ XXX 2 XXX} -test string-10.21 {string map, ABR checks} { - string map {longstring foob} long +test string-10.21.$noComp {string map, ABR checks} { + run {string map {longstring foob} long} } long -test string-10.22 {string map, ABR checks} { - string map {long foob} long +test string-10.22.$noComp {string map, ABR checks} { + run {string map {long foob} long} } foob -test string-10.23 {string map, ABR checks} { - string map {lon foob} long +test string-10.23.$noComp {string map, ABR checks} { + run {string map {lon foob} long} } foobg -test string-10.24 {string map, ABR checks} { - string map {lon foob} longlo +test string-10.24.$noComp {string map, ABR checks} { + run {string map {lon foob} longlo} } foobglo -test string-10.25 {string map, ABR checks} { - string map {lon foob} longlon +test string-10.25.$noComp {string map, ABR checks} { + run {string map {lon foob} longlon} } foobgfoob -test string-10.26 {string map, ABR checks} { - string map {longstring foob longstring bar} long +test string-10.26.$noComp {string map, ABR checks} { + run {string map {longstring foob longstring bar} long} } long -test string-10.27 {string map, ABR checks} { - string map {long foob longstring bar} long +test string-10.27.$noComp {string map, ABR checks} { + run {string map {long foob longstring bar} long} } foob -test string-10.28 {string map, ABR checks} { - string map {lon foob longstring bar} long +test string-10.28.$noComp {string map, ABR checks} { + run {string map {lon foob longstring bar} long} } foobg -test string-10.29 {string map, ABR checks} { - string map {lon foob longstring bar} longlo +test string-10.29.$noComp {string map, ABR checks} { + run {string map {lon foob longstring bar} longlo} } foobglo -test string-10.30 {string map, ABR checks} { - string map {lon foob longstring bar} longlon +test string-10.30.$noComp {string map, ABR checks} { + run {string map {lon foob longstring bar} longlon} } foobgfoob -test string-10.31 {string map, nasty sharing crash from [Bug 1018562]} { +test string-10.31.$noComp {string map, nasty sharing crash from [Bug 1018562]} { set a {a b} - string map $a $a + run {string map $a $a} } {b b} -test string-11.1 {string match, not enough args} { - list [catch {string match a} msg] $msg +test string-11.1.$noComp {string match, not enough args} { + list [catch {run {string match a}} msg] $msg } {1 {wrong # args: should be "string match ?-nocase? pattern string"}} -test string-11.2 {string match, too many args} { - list [catch {string match a b c d} msg] $msg +test string-11.2.$noComp {string match, too many args} { + list [catch {run {string match a b c d}} msg] $msg } {1 {wrong # args: should be "string match ?-nocase? pattern string"}} -test string-11.3 {string match} { - string match abc abc +test string-11.3.$noComp {string match} { + run {string match abc abc} } 1 -test string-11.4 {string match} { - string mat abc abd +test string-11.4.$noComp {string match} { + run {string mat abc abd} } 0 -test string-11.5 {string match} { - string match ab*c abc +test string-11.5.$noComp {string match} { + run {string match ab*c abc} } 1 -test string-11.6 {string match} { - string match ab**c abc +test string-11.6.$noComp {string match} { + run {string match ab**c abc} } 1 -test string-11.7 {string match} { - string match ab* abcdef +test string-11.7.$noComp {string match} { + run {string match ab* abcdef} } 1 -test string-11.8 {string match} { - string match *c abc +test string-11.8.$noComp {string match} { + run {string match *c abc} } 1 -test string-11.9 {string match} { - string match *3*6*9 0123456789 +test string-11.9.$noComp {string match} { + run {string match *3*6*9 0123456789} } 1 -test string-11.9.1 {string match} { - string match *3*6*89 0123456789 +test string-11.9.1.$noComp {string match} { + run {string match *3*6*89 0123456789} } 1 -test string-11.9.2 {string match} { - string match *3*456*89 0123456789 +test string-11.9.2.$noComp {string match} { + run {string match *3*456*89 0123456789} } 1 -test string-11.9.3 {string match} { - string match *3*6* 0123456789 +test string-11.9.3.$noComp {string match} { + run {string match *3*6* 0123456789} } 1 -test string-11.9.4 {string match} { - string match *3*56* 0123456789 +test string-11.9.4.$noComp {string match} { + run {string match *3*56* 0123456789} } 1 -test string-11.9.5 {string match} { - string match *3*456*** 0123456789 +test string-11.9.5.$noComp {string match} { + run {string match *3*456*** 0123456789} } 1 -test string-11.9.6 {string match} { - string match **3*456** 0123456789 +test string-11.9.6.$noComp {string match} { + run {string match **3*456** 0123456789} } 1 -test string-11.9.7 {string match} { - string match *3***456* 0123456789 +test string-11.9.7.$noComp {string match} { + run {string match *3***456* 0123456789} } 1 -test string-11.9.8 {string match} { - string match *3***\[456]* 0123456789 +test string-11.9.8.$noComp {string match} { + run {string match *3***\[456]* 0123456789} } 1 -test string-11.9.9 {string match} { - string match *3***\[4-6]* 0123456789 +test string-11.9.9.$noComp {string match} { + run {string match *3***\[4-6]* 0123456789} } 1 -test string-11.9.10 {string match} { - string match *3***\[4-6] 0123456789 +test string-11.9.10.$noComp {string match} { + run {string match *3***\[4-6] 0123456789} } 0 -test string-11.9.11 {string match} { - string match *3***\[4-6] 0123456 +test string-11.9.11.$noComp {string match} { + run {string match *3***\[4-6] 0123456} } 1 -test string-11.10 {string match} { - string match *3*6*9 01234567890 +test string-11.10.$noComp {string match} { + run {string match *3*6*9 01234567890} } 0 -test string-11.10.1 {string match} { - string match *3*6*89 01234567890 +test string-11.10.1.$noComp {string match} { + run {string match *3*6*89 01234567890} } 0 -test string-11.10.2 {string match} { - string match *3*456*89 01234567890 +test string-11.10.2.$noComp {string match} { + run {string match *3*456*89 01234567890} } 0 -test string-11.10.3 {string match} { - string match **3*456*89 01234567890 +test string-11.10.3.$noComp {string match} { + run {string match **3*456*89 01234567890} } 0 -test string-11.10.4 {string match} { - string match *3*456***89 01234567890 +test string-11.10.4.$noComp {string match} { + run {string match *3*456***89 01234567890} } 0 -test string-11.11 {string match} { - string match a?c abc +test string-11.11.$noComp {string match} { + run {string match a?c abc} } 1 -test string-11.12 {string match} { - string match a??c abc +test string-11.12.$noComp {string match} { + run {string match a??c abc} } 0 -test string-11.13 {string match} { - string match ?1??4???8? 0123456789 +test string-11.13.$noComp {string match} { + run {string match ?1??4???8? 0123456789} } 1 -test string-11.14 {string match} { - string match {[abc]bc} abc +test string-11.14.$noComp {string match} { + run {string match {[abc]bc} abc} } 1 -test string-11.15 {string match} { - string match {a[abc]c} abc +test string-11.15.$noComp {string match} { + run {string match {a[abc]c} abc} } 1 -test string-11.16 {string match} { - string match {a[xyz]c} abc +test string-11.16.$noComp {string match} { + run {string match {a[xyz]c} abc} } 0 -test string-11.17 {string match} { - string match {12[2-7]45} 12345 +test string-11.17.$noComp {string match} { + run {string match {12[2-7]45} 12345} } 1 -test string-11.18 {string match} { - string match {12[ab2-4cd]45} 12345 +test string-11.18.$noComp {string match} { + run {string match {12[ab2-4cd]45} 12345} } 1 -test string-11.19 {string match} { - string match {12[ab2-4cd]45} 12b45 +test string-11.19.$noComp {string match} { + run {string match {12[ab2-4cd]45} 12b45} } 1 -test string-11.20 {string match} { - string match {12[ab2-4cd]45} 12d45 +test string-11.20.$noComp {string match} { + run {string match {12[ab2-4cd]45} 12d45} } 1 -test string-11.21 {string match} { - string match {12[ab2-4cd]45} 12145 +test string-11.21.$noComp {string match} { + run {string match {12[ab2-4cd]45} 12145} } 0 -test string-11.22 {string match} { - string match {12[ab2-4cd]45} 12545 +test string-11.22.$noComp {string match} { + run {string match {12[ab2-4cd]45} 12545} } 0 -test string-11.23 {string match} { - string match {a\*b} a*b +test string-11.23.$noComp {string match} { + run {string match {a\*b} a*b} } 1 -test string-11.24 {string match} { - string match {a\*b} ab +test string-11.24.$noComp {string match} { + run {string match {a\*b} ab} } 0 -test string-11.25 {string match} { - string match {a\*\?\[\]\\\x} "a*?\[\]\\x" +test string-11.25.$noComp {string match} { + run {string match {a\*\?\[\]\\\x} "a*?\[\]\\x"} } 1 -test string-11.26 {string match} { - string match ** "" +test string-11.26.$noComp {string match} { + run {string match ** ""} } 1 -test string-11.27 {string match} { - string match *. "" +test string-11.27.$noComp {string match} { + run {string match *. ""} } 0 -test string-11.28 {string match} { - string match "" "" +test string-11.28.$noComp {string match} { + run {string match "" ""} } 1 -test string-11.29 {string match} { - string match \[a a +test string-11.29.$noComp {string match} { + run {string match \[a a} } 1 -test string-11.30 {string match, bad args} { - list [catch {string match - b c} msg] $msg +test string-11.30.$noComp {string match, bad args} { + list [catch {run {string match - b c}} msg] $msg } {1 {bad option "-": must be -nocase}} -test string-11.31 {string match case} { - string match a A +test string-11.31.$noComp {string match case} { + run {string match a A} } 0 -test string-11.32 {string match nocase} { - string match -n a A +test string-11.32.$noComp {string match nocase} { + run {string match -n a A} } 1 -test string-11.33 {string match nocase} { - string match -nocase a\334 A\374 +test string-11.33.$noComp {string match nocase} { + run {string match -nocase a\334 A\374} } 1 -test string-11.34 {string match nocase} { - string match -nocase a*f ABCDEf +test string-11.34.$noComp {string match nocase} { + run {string match -nocase a*f ABCDEf} } 1 -test string-11.35 {string match case, false hope} { +test string-11.35.$noComp {string match case, false hope} { # This is true because '_' lies between the A-Z and a-z ranges - string match {[A-z]} _ + run {string match {[A-z]} _} } 1 -test string-11.36 {string match nocase range} { +test string-11.36.$noComp {string match nocase range} { # This is false because although '_' lies between the A-Z and a-z ranges, # we lower case the end points before checking the ranges. - string match -nocase {[A-z]} _ + run {string match -nocase {[A-z]} _} } 0 -test string-11.37 {string match nocase} { - string match -nocase {[A-fh-Z]} g +test string-11.37.$noComp {string match nocase} { + run {string match -nocase {[A-fh-Z]} g} } 0 -test string-11.38 {string match case, reverse range} { - string match {[A-fh-Z]} g +test string-11.38.$noComp {string match case, reverse range} { + run {string match {[A-fh-Z]} g} } 1 -test string-11.39 {string match, *\ case} { - string match {*\abc} abc +test string-11.39.$noComp {string match, *\ case} { + run {string match {*\abc} abc} } 1 -test string-11.39.1 {string match, *\ case} { - string match {*ab\c} abc +test string-11.39.1.$noComp {string match, *\ case} { + run {string match {*ab\c} abc} } 1 -test string-11.39.2 {string match, *\ case} { - string match {*ab\*} ab* +test string-11.39.2.$noComp {string match, *\ case} { + run {string match {*ab\*} ab*} } 1 -test string-11.39.3 {string match, *\ case} { - string match {*ab\*} abc +test string-11.39.3.$noComp {string match, *\ case} { + run {string match {*ab\*} abc} } 0 -test string-11.39.4 {string match, *\ case} { - string match {*ab\\*} {ab\c} +test string-11.39.4.$noComp {string match, *\ case} { + run {string match {*ab\\*} {ab\c}} } 1 -test string-11.39.5 {string match, *\ case} { - string match {*ab\\*} {ab\*} +test string-11.39.5.$noComp {string match, *\ case} { + run {string match {*ab\\*} {ab\*}} } 1 -test string-11.40 {string match, *special case} { - string match {*[ab]} abc +test string-11.40.$noComp {string match, *special case} { + run {string match {*[ab]} abc} } 0 -test string-11.41 {string match, *special case} { - string match {*[ab]*} abc +test string-11.41.$noComp {string match, *special case} { + run {string match {*[ab]*} abc} } 1 -test string-11.42 {string match, *special case} { - string match "*\\" "\\" +test string-11.42.$noComp {string match, *special case} { + run {string match "*\\" "\\"} } 0 -test string-11.43 {string match, *special case} { - string match "*\\\\" "\\" +test string-11.43.$noComp {string match, *special case} { + run {string match "*\\\\" "\\"} } 1 -test string-11.44 {string match, *special case} { - string match "*???" "12345" +test string-11.44.$noComp {string match, *special case} { + run {string match "*???" "12345"} } 1 -test string-11.45 {string match, *special case} { - string match "*???" "12" +test string-11.45.$noComp {string match, *special case} { + run {string match "*???" "12"} } 0 -test string-11.46 {string match, *special case} { - string match "*\\*" "abc*" +test string-11.46.$noComp {string match, *special case} { + run {string match "*\\*" "abc*"} } 1 -test string-11.47 {string match, *special case} { - string match "*\\*" "*" +test string-11.47.$noComp {string match, *special case} { + run {string match "*\\*" "*"} } 1 -test string-11.48 {string match, *special case} { - string match "*\\*" "*abc" +test string-11.48.$noComp {string match, *special case} { + run {string match "*\\*" "*abc"} } 0 -test string-11.49 {string match, *special case} { - string match "?\\*" "a*" +test string-11.49.$noComp {string match, *special case} { + run {string match "?\\*" "a*"} } 1 -test string-11.50 {string match, *special case} { - string match "\\" "\\" +test string-11.50.$noComp {string match, *special case} { + run {string match "\\" "\\"} } 0 -test string-11.51 {string match; *, -nocase and UTF-8} { - string match -nocase [binary format I 717316707] \ - [binary format I 2028036707] +test string-11.51.$noComp {string match; *, -nocase and UTF-8} { + run {string match -nocase [binary format I 717316707] \ + [binary format I 2028036707]} } 1 -test string-11.52 {string match, null char in string} { +test string-11.52.$noComp {string match, null char in string} { set out "" set ptn "*abc*" - foreach elem [list "\u0000@abc" "@abc" "\u0000@abc\u0000" "blahabcblah"] { - lappend out [string match $ptn $elem] + foreach elem [list "\x00@abc" "@abc" "\x00@abc\x00" "blahabcblah"] { + lappend out [run {string match $ptn $elem}] } set out } {1 1 1 1} -test string-11.53 {string match, null char in pattern} { +test string-11.53.$noComp {string match, null char in pattern} { set out "" foreach {ptn elem} [list \ - "*\u0000abc\u0000" "\u0000abc\u0000" \ - "*\u0000abc\u0000" "\u0000abc\u0000ef" \ - "*\u0000abc\u0000*" "\u0000abc\u0000ef" \ - "*\u0000abc\u0000" "@\u0000abc\u0000ef" \ - "*\u0000abc\u0000*" "@\u0000abc\u0000ef" \ + "*\x00abc\x00" "\x00abc\x00" \ + "*\x00abc\x00" "\x00abc\x00ef" \ + "*\x00abc\x00*" "\x00abc\x00ef" \ + "*\x00abc\x00" "@\x00abc\x00ef" \ + "*\x00abc\x00*" "@\x00abc\x00ef" \ ] { - lappend out [string match $ptn $elem] + lappend out [run {string match $ptn $elem}] } set out } {1 0 1 0 1} -test string-11.54 {string match, failure} { +test string-11.54.$noComp {string match, failure} { set longString "" for {set i 0} {$i < 10} {incr i} { - append longString "abcdefghijklmnopqrstuvwxy\u0000z01234567890123" + append longString "abcdefghijklmnopqrstuvwxy\x00z01234567890123" } - string first $longString 123 - list [string match *cba* $longString] \ - [string match *a*l*\u0000* $longString] \ - [string match *a*l*\u0000*123 $longString] \ - [string match *a*l*\u0000*123* $longString] \ - [string match *a*l*\u0000*cba* $longString] \ - [string match *===* $longString] + run {string first $longString 123} + list [run {string match *cba* $longString}] \ + [run {string match *a*l*\x00* $longString}] \ + [run {string match *a*l*\x00*123 $longString}] \ + [run {string match *a*l*\x00*123* $longString}] \ + [run {string match *a*l*\x00*cba* $longString}] \ + [run {string match *===* $longString}] } {0 1 1 1 0 0} -test string-11.55 {string match, invalid binary optimization} { +test string-11.55.$noComp {string match, invalid binary optimization} { [format string] match \u0141 [binary format c 65] } 0 -test string-12.1 {string range} { - list [catch {string range} msg] $msg +test string-12.1.$noComp {string range} { + list [catch {run {string range}} msg] $msg } {1 {wrong # args: should be "string range string first last"}} -test string-12.2 {string range} { - list [catch {string range a 1} msg] $msg +test string-12.2.$noComp {string range} { + list [catch {run {string range a 1}} msg] $msg } {1 {wrong # args: should be "string range string first last"}} -test string-12.3 {string range} { - list [catch {string range a 1 2 3} msg] $msg +test string-12.3.$noComp {string range} { + list [catch {run {string range a 1 2 3}} msg] $msg } {1 {wrong # args: should be "string range string first last"}} -test string-12.4 {string range} { - string range abcdefghijklmnop 2 14 +test string-12.4.$noComp {string range} { + run {string range abcdefghijklmnop 2 14} } {cdefghijklmno} -test string-12.5 {string range, last > length} { - string range abcdefghijklmnop 7 1000 +test string-12.5.$noComp {string range, last > length} { + run {string range abcdefghijklmnop 7 1000} } {hijklmnop} -test string-12.6 {string range} { - string range abcdefghijklmnop 10 end +test string-12.6.$noComp {string range} { + run {string range abcdefghijklmnop 10 end} } {klmnop} -test string-12.7 {string range, last < first} { - string range abcdefghijklmnop 10 9 +test string-12.7.$noComp {string range, last < first} { + run {string range abcdefghijklmnop 10 9} } {} -test string-12.8 {string range, first < 0} { - string range abcdefghijklmnop -3 2 +test string-12.8.$noComp {string range, first < 0} { + run {string range abcdefghijklmnop -3 2} } {abc} -test string-12.9 {string range} { - string range abcdefghijklmnop -3 -2 +test string-12.9.$noComp {string range} { + run {string range abcdefghijklmnop -3 -2} } {} -test string-12.10 {string range} { - string range abcdefghijklmnop 1000 1010 +test string-12.10.$noComp {string range} { + run {string range abcdefghijklmnop 1000 1010} } {} -test string-12.11 {string range} { - string range abcdefghijklmnop -100 end +test string-12.11.$noComp {string range} { + run {string range abcdefghijklmnop -100 end} } {abcdefghijklmnop} -test string-12.12 {string range} { - list [catch {string range abc abc 1} msg] $msg +test string-12.12.$noComp {string range} { + list [catch {run {string range abc abc 1}} msg] $msg } {1 {bad index "abc": must be integer?[+-]integer? or end?[+-]integer?}} -test string-12.13 {string range} { - list [catch {string range abc 1 eof} msg] $msg +test string-12.13.$noComp {string range} { + list [catch {run {string range abc 1 eof}} msg] $msg } {1 {bad index "eof": must be integer?[+-]integer? or end?[+-]integer?}} -test string-12.14 {string range} { - string range abcdefghijklmnop end-1 end +test string-12.14.$noComp {string range} { + run {string range abcdefghijklmnop end-1 end} } {op} -test string-12.15 {string range} { - string range abcdefghijklmnop end 1000 +test string-12.15.$noComp {string range} { + run {string range abcdefghijklmnop end 1000} } {p} -test string-12.16 {string range} { - string range abcdefghijklmnop end end-1 +test string-12.16.$noComp {string range} { + run {string range abcdefghijklmnop end end-1} } {} -test string-12.17 {string range, unicode} { - string range ab\u7266cdefghijklmnop 5 5 +test string-12.17.$noComp {string range, unicode} { + run {string range ab\u7266cdefghijklmnop 5 5} } e -test string-12.18 {string range, unicode} { - string range ab\u7266cdefghijklmnop 2 3 +test string-12.18.$noComp {string range, unicode} { + run {string range ab\u7266cdefghijklmnop 2 3} } \u7266c -test string-12.19 {string range, bytearray object} { +test string-12.19.$noComp {string range, bytearray object} { set b [binary format I* {0x50515253 0x52}] - set r1 [string range $b 1 end-1] - set r2 [string range $b 1 6] - string equal $r1 $r2 + set r1 [run {string range $b 1 end-1}] + set r2 [run {string range $b 1 6}] + run {string equal $r1 $r2} } 1 -test string-12.20 {string range, out of bounds indices} { - string range \u00FF 0 1 -} \u00FF +test string-12.20.$noComp {string range, out of bounds indices} { + run {string range \xFF 0 1} +} \xFF # Bug 1410553 -test string-12.21 {string range, regenerates correct reps, bug 1410553} { +test string-12.21.$noComp {string range, regenerates correct reps, bug 1410553} { set bytes "\x00 \x03 \x41" set rxBuffer {} foreach ch $bytes { append rxBuffer $ch if {$ch eq "\x03"} { - string length $rxBuffer + run {string length $rxBuffer} } } - set rxCRC [string range $rxBuffer end-1 end] + set rxCRC [run {string range $rxBuffer end-1 end}] binary scan [join $bytes {}] "H*" input_hex binary scan $rxBuffer "H*" rxBuffer_hex binary scan $rxCRC "H*" rxCRC_hex list $input_hex $rxBuffer_hex $rxCRC_hex } {000341 000341 0341} -test string-12.22 {string range, shimmering binary/index} { +test string-12.22.$noComp {string range, shimmering binary/index} { set s 0000000001 binary scan $s a* x - string range $s $s end + run {string range $s $s end} } 000000001 -test string-12.23 {string range, surrogates, bug [11ae2be95dac9417]} utf16 { - list [string range a\U100000b 1 1] [string range a\U100000b 2 2] [string range a\U100000b 3 3] +test string-12.23.$noComp {string range, surrogates, bug [11ae2be95dac9417]} utf16 { + run {list [string range a\U100000b 1 1] [string range a\U100000b 2 2] [string range a\U100000b 3 3]} } [list \U100000 {} b] -test string-13.1 {string repeat} { - list [catch {string repeat} msg] $msg +test string-13.1.$noComp {string repeat} { + list [catch {run {string repeat}} msg] $msg } {1 {wrong # args: should be "string repeat string count"}} -test string-13.2 {string repeat} { - list [catch {string repeat abc 10 oops} msg] $msg +test string-13.2.$noComp {string repeat} { + list [catch {run {string repeat abc 10 oops}} msg] $msg } {1 {wrong # args: should be "string repeat string count"}} -test string-13.3 {string repeat} { - string repeat {} 100 +test string-13.3.$noComp {string repeat} { + run {string repeat {} 100} } {} -test string-13.4 {string repeat} { - string repeat { } 5 +test string-13.4.$noComp {string repeat} { + run {string repeat { } 5} } { } -test string-13.5 {string repeat} { - string repeat abc 3 +test string-13.5.$noComp {string repeat} { + run {string repeat abc 3} } {abcabcabc} -test string-13.6 {string repeat} { - string repeat abc -1 +test string-13.6.$noComp {string repeat} { + run {string repeat abc -1} } {} -test string-13.7 {string repeat} { - list [catch {string repeat abc end} msg] $msg +test string-13.7.$noComp {string repeat} { + list [catch {run {string repeat abc end}} msg] $msg } {1 {expected integer but got "end"}} -test string-13.8 {string repeat} { - string repeat {} -1000 +test string-13.8.$noComp {string repeat} { + run {string repeat {} -1000} } {} -test string-13.9 {string repeat} { - string repeat {} 0 +test string-13.9.$noComp {string repeat} { + run {string repeat {} 0} } {} -test string-13.10 {string repeat} { - string repeat def 0 +test string-13.10.$noComp {string repeat} { + run {string repeat def 0} } {} -test string-13.11 {string repeat} { - string repeat def 1 +test string-13.11.$noComp {string repeat} { + run {string repeat def 1} } def -test string-13.12 {string repeat} { - string repeat ab\u7266cd 3 +test string-13.12.$noComp {string repeat} { + run {string repeat ab\u7266cd 3} } ab\u7266cdab\u7266cdab\u7266cd -test string-13.13 {string repeat} { - string repeat \x00 3 +test string-13.13.$noComp {string repeat} { + run {string repeat \x00 3} } \x00\x00\x00 -test string-13.14 {string repeat} { +test string-13.14.$noComp {string repeat} { # The string range will ensure us that string repeat gets a unicode string - string repeat [string range ab\u7266cd 2 3] 3 + run {string repeat [run {string range ab\u7266cd 2 3}] 3} } \u7266c\u7266c\u7266c -test string-14.1 {string replace} { - list [catch {string replace} msg] $msg +test string-14.1.$noComp {string replace} { + list [catch {run {string replace}} msg] $msg } {1 {wrong # args: should be "string replace string first last ?string?"}} -test string-14.2 {string replace} { - list [catch {string replace a 1} msg] $msg +test string-14.2.$noComp {string replace} { + list [catch {run {string replace a 1}} msg] $msg } {1 {wrong # args: should be "string replace string first last ?string?"}} -test string-14.3 {string replace} { - list [catch {string replace a 1 2 3 4} msg] $msg +test string-14.3.$noComp {string replace} { + list [catch {run {string replace a 1 2 3 4}} msg] $msg } {1 {wrong # args: should be "string replace string first last ?string?"}} -test string-14.4 {string replace} { +test string-14.4.$noComp {string replace} { } {} -test string-14.5 {string replace} { - string replace abcdefghijklmnop 2 14 +test string-14.5.$noComp {string replace} { + run {string replace abcdefghijklmnop 2 14} } {abp} -test string-14.6 {string replace} { - string replace abcdefghijklmnop 7 1000 -} {abcdefg} -test string-14.7 {string replace} { - string replace abcdefghijklmnop 10 end -} {abcdefghij} -test string-14.8 {string replace} { - string replace abcdefghijklmnop 10 9 -} {abcdefghijklmnop} -test string-14.9 {string replace} { - string replace abcdefghijklmnop -3 2 -} {defghijklmnop} -test string-14.10 {string replace} { - string replace abcdefghijklmnop -3 -2 -} {abcdefghijklmnop} -test string-14.11 {string replace} { - string replace abcdefghijklmnop 1000 1010 -} {abcdefghijklmnop} -test string-14.12 {string replace} { - string replace abcdefghijklmnop -100 end +test string-14.6.$noComp {string replace} -body { + run {string replace abcdefghijklmnop 7 1000} +} -result abcdefg +test string-14.7.$noComp {string replace} { + run {string replace abcdefghijklmnop 10 end} +} abcdefghij +test string-14.8.$noComp {string replace} { + run {string replace abcdefghijklmnop 10 9} +} abcdefghijklmnop +test string-14.9.$noComp {string replace} { + run {string replace abcdefghijklmnop -3 2} +} defghijklmnop +test string-14.10.$noComp {string replace} { + run {string replace abcdefghijklmnop -3 -2} +} abcdefghijklmnop +test string-14.11.$noComp {string replace} -body { + run {string replace abcdefghijklmnop 1000 1010} +} -result abcdefghijklmnop +test string-14.12.$noComp {string replace} { + run {string replace abcdefghijklmnop -100 end} } {} -test string-14.13 {string replace} { - list [catch {string replace abc abc 1} msg] $msg +test string-14.13.$noComp {string replace} { + list [catch {run {string replace abc abc 1}} msg] $msg } {1 {bad index "abc": must be integer?[+-]integer? or end?[+-]integer?}} -test string-14.14 {string replace} { - list [catch {string replace abc 1 eof} msg] $msg +test string-14.14.$noComp {string replace} { + list [catch {run {string replace abc 1 eof}} msg] $msg } {1 {bad index "eof": must be integer?[+-]integer? or end?[+-]integer?}} -test string-14.15 {string replace} { - string replace abcdefghijklmnop end-10 end-2 NEW +test string-14.15.$noComp {string replace} { + run {string replace abcdefghijklmnop end-10 end-2 NEW} } {abcdeNEWop} -test string-14.16 {string replace} { - string replace abcdefghijklmnop 0 end foo +test string-14.16.$noComp {string replace} { + run {string replace abcdefghijklmnop 0 end foo} } {foo} -test string-14.17 {string replace} { - string replace abcdefghijklmnop end end-1 +test string-14.17.$noComp {string replace} { + run {string replace abcdefghijklmnop end end-1} } {abcdefghijklmnop} -test string-14.18 {string replace} { - string replace abcdefghijklmnop 10 9 XXX +test string-14.18.$noComp {string replace} { + run {string replace abcdefghijklmnop 10 9 XXX} } {abcdefghijklmnop} -test string-14.19 {string replace} { - string replace {} -1 0 A +test string-14.19.$noComp {string replace} { + run {string replace {} -1 0 A} } A -test string-15.1 {string tolower not enough args} { - list [catch {string tolower} msg] $msg +test string-15.1.$noComp {string tolower not enough args} { + list [catch {run {string tolower}} msg] $msg } {1 {wrong # args: should be "string tolower string ?first? ?last?"}} -test string-15.2 {string tolower bad args} { - list [catch {string tolower a b} msg] $msg +test string-15.2.$noComp {string tolower bad args} { + list [catch {run {string tolower a b}} msg] $msg } {1 {bad index "b": must be integer?[+-]integer? or end?[+-]integer?}} -test string-15.3 {string tolower too many args} { - list [catch {string tolower ABC 1 end oops} msg] $msg +test string-15.3.$noComp {string tolower too many args} { + list [catch {run {string tolower ABC 1 end oops}} msg] $msg } {1 {wrong # args: should be "string tolower string ?first? ?last?"}} -test string-15.4 {string tolower} { - string tolower ABCDeF +test string-15.4.$noComp {string tolower} { + run {string tolower ABCDeF} } {abcdef} -test string-15.5 {string tolower} { - string tolower "ABC XyZ" +test string-15.5.$noComp {string tolower} { + run {string tolower "ABC XyZ"} } {abc xyz} -test string-15.6 {string tolower} { - string tolower {123#$&*()} +test string-15.6.$noComp {string tolower} { + run {string tolower {123#$&*()}} } {123#$&*()} -test string-15.7 {string tolower} { - string tolower ABC 1 +test string-15.7.$noComp {string tolower} { + run {string tolower ABC 1} } AbC -test string-15.8 {string tolower} { - string tolower ABC 1 end +test string-15.8.$noComp {string tolower} { + run {string tolower ABC 1 end} } Abc -test string-15.9 {string tolower} { - string tolower ABC 0 end-1 +test string-15.9.$noComp {string tolower} { + run {string tolower ABC 0 end-1} } abC -test string-15.10 {string tolower, unicode} { - string tolower ABCabc\xc7\xe7 -} "abcabc\xe7\xe7" -test string-15.11 {string tolower, compiled} { - lindex [string tolower [list A B [list C]]] 1 +test string-15.10.$noComp {string tolower, unicode} { + run {string tolower ABCabc\xC7\xE7} +} "abcabc\xE7\xE7" +test string-15.11.$noComp {string tolower, compiled} { + lindex [run {string tolower [list A B [list C]]}] 1 } b -test string-16.1 {string toupper} { - list [catch {string toupper} msg] $msg +test string-16.1.$noComp {string toupper} { + list [catch {run {string toupper}} msg] $msg } {1 {wrong # args: should be "string toupper string ?first? ?last?"}} -test string-16.2 {string toupper} { - list [catch {string toupper a b} msg] $msg +test string-16.2.$noComp {string toupper} { + list [catch {run {string toupper a b}} msg] $msg } {1 {bad index "b": must be integer?[+-]integer? or end?[+-]integer?}} -test string-16.3 {string toupper} { - list [catch {string toupper a 1 end oops} msg] $msg +test string-16.3.$noComp {string toupper} { + list [catch {run {string toupper a 1 end oops}} msg] $msg } {1 {wrong # args: should be "string toupper string ?first? ?last?"}} -test string-16.4 {string toupper} { - string toupper abCDEf +test string-16.4.$noComp {string toupper} { + run {string toupper abCDEf} } {ABCDEF} -test string-16.5 {string toupper} { - string toupper "abc xYz" +test string-16.5.$noComp {string toupper} { + run {string toupper "abc xYz"} } {ABC XYZ} -test string-16.6 {string toupper} { - string toupper {123#$&*()} +test string-16.6.$noComp {string toupper} { + run {string toupper {123#$&*()}} } {123#$&*()} -test string-16.7 {string toupper} { - string toupper abc 1 +test string-16.7.$noComp {string toupper} { + run {string toupper abc 1} } aBc -test string-16.8 {string toupper} { - string toupper abc 1 end +test string-16.8.$noComp {string toupper} { + run {string toupper abc 1 end} } aBC -test string-16.9 {string toupper} { - string toupper abc 0 end-1 +test string-16.9.$noComp {string toupper} { + run {string toupper abc 0 end-1} } ABc -test string-16.10 {string toupper, unicode} { - string toupper ABCabc\xc7\xe7 -} "ABCABC\xc7\xc7" -test string-16.11 {string toupper, compiled} { - lindex [string toupper [list a b [list c]]] 1 +test string-16.10.$noComp {string toupper, unicode} { + run {string toupper ABCabc\xC7\xE7} +} "ABCABC\xC7\xC7" +test string-16.11.$noComp {string toupper, compiled} { + lindex [run {string toupper [list a b [list c]]}] 1 } B -test string-17.1 {string totitle} { - list [catch {string totitle} msg] $msg +test string-17.1.$noComp {string totitle} { + list [catch {run {string totitle}} msg] $msg } {1 {wrong # args: should be "string totitle string ?first? ?last?"}} -test string-17.2 {string totitle} { - list [catch {string totitle a b} msg] $msg +test string-17.2.$noComp {string totitle} { + list [catch {run {string totitle a b}} msg] $msg } {1 {bad index "b": must be integer?[+-]integer? or end?[+-]integer?}} -test string-17.3 {string totitle} { - string totitle abCDEf +test string-17.3.$noComp {string totitle} { + run {string totitle abCDEf} } {Abcdef} -test string-17.4 {string totitle} { - string totitle "abc xYz" +test string-17.4.$noComp {string totitle} { + run {string totitle "abc xYz"} } {Abc xyz} -test string-17.5 {string totitle} { - string totitle {123#$&*()} +test string-17.5.$noComp {string totitle} { + run {string totitle {123#$&*()}} } {123#$&*()} -test string-17.6 {string totitle, unicode} { - string totitle ABCabc\xC7\xE7 +test string-17.6.$noComp {string totitle, unicode} { + run {string totitle ABCabc\xC7\xE7} } "Abcabc\xE7\xE7" -test string-17.7 {string totitle, unicode} { - string totitle \u01F3BCabc\xc7\xe7 -} "\u01F2bcabc\xe7\xe7" -test string-17.8 {string totitle, compiled} { - lindex [string totitle [list aa bb [list cc]]] 0 +test string-17.7.$noComp {string totitle, unicode} { + run {string totitle \u01F3BCabc\xC7\xE7} +} "\u01F2bcabc\xE7\xE7" +test string-17.8.$noComp {string totitle, compiled} { + lindex [run {string totitle [list aa bb [list cc]]}] 0 } Aa -test string-18.1 {string trim} { - list [catch {string trim} msg] $msg +test string-18.1.$noComp {string trim} { + list [catch {run {string trim}} msg] $msg } {1 {wrong # args: should be "string trim string ?chars?"}} -test string-18.2 {string trim} { - list [catch {string trim a b c} msg] $msg +test string-18.2.$noComp {string trim} { + list [catch {run {string trim a b c}} msg] $msg } {1 {wrong # args: should be "string trim string ?chars?"}} -test string-18.3 {string trim} { - string trim " XYZ " +test string-18.3.$noComp {string trim} { + run {string trim " XYZ "} } {XYZ} -test string-18.4 {string trim} { - string trim "\t\nXYZ\t\n\r\n" +test string-18.4.$noComp {string trim} { + run {string trim "\t\nXYZ\t\n\r\n"} } {XYZ} -test string-18.5 {string trim} { - string trim " A XYZ A " +test string-18.5.$noComp {string trim} { + run {string trim " A XYZ A "} } {A XYZ A} -test string-18.6 {string trim} { - string trim "XXYYZZABC XXYYZZ" ZYX +test string-18.6.$noComp {string trim} { + run {string trim "XXYYZZABC XXYYZZ" ZYX} } {ABC } -test string-18.7 {string trim} { - string trim " \t\r " +test string-18.7.$noComp {string trim} { + run {string trim " \t\r "} } {} -test string-18.8 {string trim} { - string trim {abcdefg} {} +test string-18.8.$noComp {string trim} { + run {string trim {abcdefg} {}} } {abcdefg} -test string-18.9 {string trim} { - string trim {} +test string-18.9.$noComp {string trim} { + run {string trim {}} } {} -test string-18.10 {string trim} { - string trim ABC DEF +test string-18.10.$noComp {string trim} { + run {string trim ABC DEF} } {ABC} -test string-18.11 {string trim, unicode} { - string trim "\xe7\xe8 AB\xe7C \xe8\xe7" \xe7\xe8 -} " AB\xe7C " -test string-18.12 {string trim, unicode default} { - string trim \uFEFF\x00\u0085\u00A0\u1680\u180EABC\u1361\u2000\u2001\u2002\u2003\u2004\u2005\u2006\u2007\u2008\u2009\u200A\u200B\u2028\u2029\u202F\u205F\u3000 +test string-18.11.$noComp {string trim, unicode} { + run {string trim "\xE7\xE8 AB\xE7C \xE8\xE7" \xE7\xE8} +} " AB\xE7C " +test string-18.12.$noComp {string trim, unicode default} { + run {string trim \uFEFF\x00\x85\xA0\u1680\u180EABC\u1361\u2000\u2001\u2002\u2003\u2004\u2005\u2006\u2007\u2008\u2009\u200A\u200B\u2028\u2029\u202F\u205F\u3000} } ABC\u1361 -test string-19.1 {string trimleft} { - list [catch {string trimleft} msg] $msg +test string-19.1.$noComp {string trimleft} { + list [catch {run {string trimleft}} msg] $msg } {1 {wrong # args: should be "string trimleft string ?chars?"}} -test string-19.2 {string trimleft} { - string trimleft " XYZ " +test string-19.2.$noComp {string trimleft} { + run {string trimleft " XYZ "} } {XYZ } -test string-19.3 {string trimleft, unicode default} { - string trimleft \uFEFF\u0085\u00A0\x00\u1680\u180E\u2000\u2001\u2002\u2003\u2004\u2005\u2006\u2007\u2008\u2009\u200A\u200B\u2028\u2029\u202F\u205F\u3000\u1361ABC +test string-19.3.$noComp {string trimleft, unicode default} { + run {string trimleft \uFEFF\x85\xA0\x00\u1680\u180E\u2000\u2001\u2002\u2003\u2004\u2005\u2006\u2007\u2008\u2009\u200A\u200B\u2028\u2029\u202F\u205F\u3000\u1361ABC} } \u1361ABC -test string-20.1 {string trimright errors} { - list [catch {string trimright} msg] $msg +test string-20.1.$noComp {string trimright errors} { + list [catch {run {string trimright}} msg] $msg } {1 {wrong # args: should be "string trimright string ?chars?"}} -test string-20.2 {string trimright errors} { - list [catch {string trimg a} msg] $msg -} {1 {unknown or ambiguous subcommand "trimg": must be bytelength, cat, compare, equal, first, index, is, last, length, map, match, range, repeat, replace, reverse, tolower, totitle, toupper, trim, trimleft, trimright, wordend, or wordstart}} -test string-20.3 {string trimright} { - string trimright " XYZ " +test string-20.2.$noComp {string trimright errors} -body { + list [catch {run {string trimg a}} msg] $msg +} -result {1 {unknown or ambiguous subcommand "trimg": must be bytelength, cat, compare, equal, first, index, is, last, length, map, match, range, repeat, replace, reverse, tolower, totitle, toupper, trim, trimleft, trimright, wordend, or wordstart}} +test string-20.3.$noComp {string trimright} { + run {string trimright " XYZ "} } { XYZ} -test string-20.4 {string trimright} { - string trimright " " +test string-20.4.$noComp {string trimright} { + run {string trimright " "} } {} -test string-20.5 {string trimright} { - string trimright "" +test string-20.5.$noComp {string trimright} { + run {string trimright ""} } {} -test string-20.6 {string trimright, unicode default} { - string trimright ABC\u1361\u0085\x00\u00A0\u1680\u180E\u2000\u2001\u2002\u2003\u2004\u2005\u2006\u2007\u2008\u2009\u200A\u200B\u2028\u2029\u202F\u205F\u3000 +test string-20.6.$noComp {string trimright, unicode default} { + run {string trimright ABC\u1361\x85\x00\xA0\u1680\u180E\u2000\u2001\u2002\u2003\u2004\u2005\u2006\u2007\u2008\u2009\u200A\u200B\u2028\u2029\u202F\u205F\u3000} } ABC\u1361 -test string-20.7 {string trim on not valid utf-8 sequence (consider NTS as continuation char), bug [c61818e4c9]} testbytestring { +test string-20.7.$noComp {string trim on not valid utf-8 sequence (consider NTS as continuation char), bug [c61818e4c9]} testbytestring { set result {} - set a [testbytestring \xc0\x80\xA0] + set a [testbytestring \xC0\x80\xA0] set b foo$a - set m [list \u0000 U \xA0 V [testbytestring \xA0] W] + set m [list \x00 U \xA0 V [testbytestring \xA0] W] lappend result [string map $m $b] - lappend result [string map $m [string trimright $b x]] - lappend result [string map $m [string trimright $b \u0000]] - lappend result [string map $m [string trimleft $b fox]] - lappend result [string map $m [string trimleft $b fo\u0000]] - lappend result [string map $m [string trim $b fox]] - lappend result [string map $m [string trim $b fo\u0000]] + lappend result [string map $m [run {string trimright $b x}]] + lappend result [string map $m [run {string trimright $b \x00}]] + lappend result [string map $m [run {string trimleft $b fox}]] + lappend result [string map $m [run {string trimleft $b fo\x00}]] + lappend result [string map $m [run {string trim $b fox}]] + lappend result [string map $m [run {string trim $b fo\x00}]] } [list {*}[lrepeat 3 fooUV] {*}[lrepeat 2 UV V]] -test string-20.8 {[c61818e4c9] [string trimright] fails when UtfPrev is ok} testbytestring { +test string-20.8.$noComp {[c61818e4c9] [string trimright] fails when UtfPrev is ok} testbytestring { set result {} set a [testbytestring \xE8\xA0] set b foo$a set m [list \xE8 U \xA0 V [testbytestring \xE8] W [testbytestring \xA0] X]] lappend result [string map $m $b] - lappend result [string map $m [string trimright $b x]] - lappend result [string map $m [string trimright $b \xE8]] - lappend result [string map $m [string trimright $b [bytestring \xE8]]] - lappend result [string map $m [string trimright $b \xA0]] - lappend result [string map $m [string trimright $b [bytestring \xA0]]] - lappend result [string map $m [string trimright $b \xE8\xA0]] - lappend result [string map $m [string trimright $b [bytestring \xE8\xA0]]] - lappend result [string map $m [string trimright $b \u0000]] + lappend result [string map $m [run {string trimright $b x}]] + lappend result [string map $m [run {string trimright $b \xE8}]] + lappend result [string map $m [run {string trimright $b [bytestring \xE8]}]] + lappend result [string map $m [run {string trimright $b \xA0}]] + lappend result [string map $m [run {string trimright $b [bytestring \xA0]}]] + lappend result [string map $m [run {string trimright $b \xE8\xA0}]] + lappend result [string map $m [run {string trimright $b [bytestring \xE8\xA0]}]] + lappend result [string map $m [run {string trimright $b \x00}]] } [list {*}[lrepeat 4 fooUV] {*}[lrepeat 2 fooU] {*}[lrepeat 2 foo] fooUV] -test string-21.1 {string wordend} { - list [catch {string wordend a} msg] $msg -} {1 {wrong # args: should be "string wordend string index"}} -test string-21.2 {string wordend} { - list [catch {string wordend a b c} msg] $msg -} {1 {wrong # args: should be "string wordend string index"}} -test string-21.3 {string wordend} { - list [catch {string wordend a gorp} msg] $msg -} {1 {bad index "gorp": must be integer?[+-]integer? or end?[+-]integer?}} -test string-21.4 {string wordend} { - string wordend abc. -1 -} 3 -test string-21.5 {string wordend} { - string wordend abc. 100 -} 4 -test string-21.6 {string wordend} { - string wordend "word_one two three" 2 -} 8 -test string-21.7 {string wordend} { - string wordend "one .&# three" 5 -} 6 -test string-21.8 {string wordend} { - string worde "x.y" 0 -} 1 -test string-21.9 {string wordend} { - string worde "x.y" end-1 -} 2 -test string-21.10 {string wordend, unicode} { - string wordend "xyz\u00C7de fg" 0 -} 6 -test string-21.11 {string wordend, unicode} { - string wordend "xyz\uC700de fg" 0 -} 6 -test string-21.12 {string wordend, unicode} { - string wordend "xyz\u203Fde fg" 0 -} 6 -test string-21.13 {string wordend, unicode} { - string wordend "xyz\u2045de fg" 0 -} 3 -test string-21.14 {string wordend, unicode} { - string wordend "\uC700\uC700 abc" 8 -} 6 -test string-21.17 {string trim, unicode} { - string trim "\uD83D\uDE02Hello world!\uD83D\uDE02" \uD83D\uDE02 +test string-21.1.$noComp {string wordend} -body { + list [catch {run {string wordend a}} msg] $msg +} -result {1 {wrong # args: should be "string wordend string index"}} +test string-21.2.$noComp {string wordend} -body { + list [catch {run {string wordend a b c}} msg] $msg +} -result {1 {wrong # args: should be "string wordend string index"}} +test string-21.3.$noComp {string wordend} -body { + list [catch {run {string wordend a gorp}} msg] $msg +} -result {1 {bad index "gorp": must be integer?[+-]integer? or end?[+-]integer?}} +test string-21.4.$noComp {string wordend} -body { + run {string wordend abc. -1} +} -result 3 +test string-21.5.$noComp {string wordend} -body { + run {string wordend abc. 100} +} -result 4 +test string-21.6.$noComp {string wordend} -body { + run {string wordend "word_one two three" 2} +} -result 8 +test string-21.7.$noComp {string wordend} -body { + run {string wordend "one .&# three" 5} +} -result 6 +test string-21.8.$noComp {string wordend} -body { + run {string worde "x.y" 0} +} -result 1 +test string-21.9.$noComp {string wordend} -body { + run {string worde "x.y" end-1} +} -result 2 +test string-21.10.$noComp {string wordend, unicode} -body { + run {string wordend "xyz\xC7de fg" 0} +} -result 6 +test string-21.11.$noComp {string wordend, unicode} -body { + run {string wordend "xyz\uC700de fg" 0} +} -result 6 +test string-21.12.$noComp {string wordend, unicode} -body { + run {string wordend "xyz\u203Fde fg" 0} +} -result 6 +test string-21.13.$noComp {string wordend, unicode} -body { + run {string wordend "xyz\u2045de fg" 0} +} -result 3 +test string-21.14.$noComp {string wordend, unicode} -body { + run {string wordend "\uC700\uC700 abc" 8} +} -result 6 +test string-21.17.$noComp {string trim, unicode} { + run {string trim "\uD83D\uDE02Hello world!\uD83D\uDE02" \uD83D\uDE02} } "Hello world!" -test string-21.18 {string trimleft, unicode} { - string trimleft "\uD83D\uDE02Hello world!\uD83D\uDE02" \uD83D\uDE02 +test string-21.18.$noComp {string trimleft, unicode} { + run {string trimleft "\uD83D\uDE02Hello world!\uD83D\uDE02" \uD83D\uDE02} } "Hello world!\uD83D\uDE02" -test string-21.19 {string trimright, unicode} { - string trimright "\uD83D\uDE02Hello world!\uD83D\uDE02" \uD83D\uDE02 +test string-21.19.$noComp {string trimright, unicode} { + run {string trimright "\uD83D\uDE02Hello world!\uD83D\uDE02" \uD83D\uDE02} } "\uD83D\uDE02Hello world!" -test string-21.20 {string trim, unicode} { - string trim "\uF602Hello world!\uF602" \uD83D\uDE02 +test string-21.20.$noComp {string trim, unicode} { + run {string trim "\uF602Hello world!\uF602" \uD83D\uDE02} } "\uF602Hello world!\uF602" -test string-21.21 {string trimleft, unicode} { - string trimleft "\uF602Hello world!\uF602" \uD83D\uDE02 +test string-21.21.$noComp {string trimleft, unicode} { + run {string trimleft "\uF602Hello world!\uF602" \uD83D\uDE02} } "\uF602Hello world!\uF602" -test string-21.22 {string trimright, unicode} { - string trimright "\uF602Hello world!\uF602" \uD83D\uDE02 +test string-21.22.$noComp {string trimright, unicode} { + run {string trimright "\uF602Hello world!\uF602" \uD83D\uDE02} } "\uF602Hello world!\uF602" -test string-21.23 {string trim, unicode} { - string trim "\uD83D\uDE02Hello world!\uD83D\uDE02" \uD93D\uDE02 +test string-21.23.$noComp {string trim, unicode} { + run {string trim "\uD83D\uDE02Hello world!\uD83D\uDE02" \uD93D\uDE02} } "\uD83D\uDE02Hello world!\uD83D\uDE02" -test string-21.24 {string trimleft, unicode} { - string trimleft "\uD83D\uDE02Hello world!\uD83D\uDE02" \uD93D\uDE02 +test string-21.24.$noComp {string trimleft, unicode} { + run {string trimleft "\uD83D\uDE02Hello world!\uD83D\uDE02" \uD93D\uDE02} } "\uD83D\uDE02Hello world!\uD83D\uDE02" -test string-21.25 {string trimright, unicode} { - string trimright "\uD83D\uDE02Hello world!\uD83D\uDE02" \uD93D\uDE02 +test string-21.25.$noComp {string trimright, unicode} { + run {string trimright "\uD83D\uDE02Hello world!\uD83D\uDE02" \uD93D\uDE02} } "\uD83D\uDE02Hello world!\uD83D\uDE02" -test string-22.1 {string wordstart} { - list [catch {string word a} msg] $msg -} {1 {unknown or ambiguous subcommand "word": must be bytelength, cat, compare, equal, first, index, is, last, length, map, match, range, repeat, replace, reverse, tolower, totitle, toupper, trim, trimleft, trimright, wordend, or wordstart}} -test string-22.2 {string wordstart} { - list [catch {string wordstart a} msg] $msg -} {1 {wrong # args: should be "string wordstart string index"}} -test string-22.3 {string wordstart} { - list [catch {string wordstart a b c} msg] $msg -} {1 {wrong # args: should be "string wordstart string index"}} -test string-22.4 {string wordstart} { - list [catch {string wordstart a gorp} msg] $msg -} {1 {bad index "gorp": must be integer?[+-]integer? or end?[+-]integer?}} -test string-22.5 {string wordstart} { - string wordstart "one two three_words" 400 -} 8 -test string-22.6 {string wordstart} { - string wordstart "one two three_words" 2 -} 0 -test string-22.7 {string wordstart} { - string wordstart "one two three_words" -2 -} 0 -test string-22.8 {string wordstart} { - string wordstart "one .*&^ three" 6 -} 6 -test string-22.9 {string wordstart} { - string wordstart "one two three" 4 -} 4 -test string-22.10 {string wordstart} { - string wordstart "one two three" end-5 -} 7 -test string-22.11 {string wordstart, unicode} { - string wordstart "one tw\u00C7o three" 7 -} 4 -test string-22.12 {string wordstart, unicode} { - string wordstart "ab\uC700\uC700 cdef ghi" 12 -} 10 -test string-22.13 {string wordstart, unicode} { - string wordstart "\uC700\uC700 abc" 8 -} 3 -test string-22.14 {string wordstart, invalid UTF-8} testbytestring { +test string-22.1.$noComp {string wordstart} -body { + list [catch {run {string word a}} msg] $msg +} -result {1 {unknown or ambiguous subcommand "word": must be bytelength, cat, compare, equal, first, index, is, last, length, map, match, range, repeat, replace, reverse, tolower, totitle, toupper, trim, trimleft, trimright, wordend, or wordstart}} +test string-22.2.$noComp {string wordstart} -body { + list [catch {run {string wordstart a}} msg] $msg +} -result {1 {wrong # args: should be "string wordstart string index"}} +test string-22.3.$noComp {string wordstart} -body { + list [catch {run {string wordstart a b c}} msg] $msg +} -result {1 {wrong # args: should be "string wordstart string index"}} +test string-22.4.$noComp {string wordstart} -body { + list [catch {run {string wordstart a gorp}} msg] $msg +} -result {1 {bad index "gorp": must be integer?[+-]integer? or end?[+-]integer?}} +test string-22.5.$noComp {string wordstart} -body { + run {string wordstart "one two three_words" 400} +} -result 8 +test string-22.6.$noComp {string wordstart} -body { + run {string wordstart "one two three_words" 2} +} -result 0 +test string-22.7.$noComp {string wordstart} -body { + run {string wordstart "one two three_words" -2} +} -result 0 +test string-22.8.$noComp {string wordstart} -body { + run {string wordstart "one .*&^ three" 6} +} -result 6 +test string-22.9.$noComp {string wordstart} -body { + run {string wordstart "one two three" 4} +} -result 4 +test string-22.10.$noComp {string wordstart} -body { + run {string wordstart "one two three" end-5} +} -result 7 +test string-22.11.$noComp {string wordstart, unicode} -body { + run {string wordstart "one tw\xC7o three" 7} +} -result 4 +test string-22.12.$noComp {string wordstart, unicode} -body { + run {string wordstart "ab\uC700\uC700 cdef ghi" 12} +} -result 10 +test string-22.13.$noComp {string wordstart, unicode} -body { + run {string wordstart "\uC700\uC700 abc" 8} +} -result 3 +test string-22.14.$noComp {string wordstart, invalid UTF-8} -constraints testbytestring -body { # See Bug c61818e4c9 set demo [testbytestring "abc def\xE0\xA9ghi"] - string index $demo [string wordstart $demo 10] -} g + run {string index $demo [string wordstart $demo 10]} +} -result g -test string-23.0 {string is boolean, Bug 1187123} testindexobj { +test string-23.0.$noComp {string is boolean, Bug 1187123} testindexobj { set x 5 catch {testindexobj $x foo bar soom} - string is boolean $x + run {string is boolean $x} } 0 -test string-23.1 {string is command with empty string} { +test string-23.1.$noComp {string is command with empty string} { set s "" list \ - [string is alnum $s] \ - [string is alpha $s] \ - [string is ascii $s] \ - [string is control $s] \ - [string is boolean $s] \ - [string is digit $s] \ - [string is double $s] \ - [string is false $s] \ - [string is graph $s] \ - [string is integer $s] \ - [string is lower $s] \ - [string is print $s] \ - [string is punct $s] \ - [string is space $s] \ - [string is true $s] \ - [string is upper $s] \ - [string is wordchar $s] \ - [string is xdigit $s] \ + [run {string is alnum $s}] \ + [run {string is alpha $s}] \ + [run {string is ascii $s}] \ + [run {string is control $s}] \ + [run {string is boolean $s}] \ + [run {string is digit $s}] \ + [run {string is double $s}] \ + [run {string is false $s}] \ + [run {string is graph $s}] \ + [run {string is integer $s}] \ + [run {string is lower $s}] \ + [run {string is print $s}] \ + [run {string is punct $s}] \ + [run {string is space $s}] \ + [run {string is true $s}] \ + [run {string is upper $s}] \ + [run {string is wordchar $s}] \ + [run {string is xdigit $s}] \ } {1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1} -test string-23.2 {string is command with empty string} { +test string-23.2.$noComp {string is command with empty string} { set s "" list \ - [string is alnum -strict $s] \ - [string is alpha -strict $s] \ - [string is ascii -strict $s] \ - [string is control -strict $s] \ - [string is boolean -strict $s] \ - [string is digit -strict $s] \ - [string is double -strict $s] \ - [string is false -strict $s] \ - [string is graph -strict $s] \ - [string is integer -strict $s] \ - [string is lower -strict $s] \ - [string is print -strict $s] \ - [string is punct -strict $s] \ - [string is space -strict $s] \ - [string is true -strict $s] \ - [string is upper -strict $s] \ - [string is wordchar -strict $s] \ - [string is xdigit -strict $s] \ + [run {string is alnum -strict $s}] \ + [run {string is alpha -strict $s}] \ + [run {string is ascii -strict $s}] \ + [run {string is control -strict $s}] \ + [run {string is boolean -strict $s}] \ + [run {string is digit -strict $s}] \ + [run {string is double -strict $s}] \ + [run {string is false -strict $s}] \ + [run {string is graph -strict $s}] \ + [run {string is integer -strict $s}] \ + [run {string is lower -strict $s}] \ + [run {string is print -strict $s}] \ + [run {string is punct -strict $s}] \ + [run {string is space -strict $s}] \ + [run {string is true -strict $s}] \ + [run {string is upper -strict $s}] \ + [run {string is wordchar -strict $s}] \ + [run {string is xdigit -strict $s}] \ } {0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0} -test string-24.1 {string reverse command} -body { - string reverse +test string-24.1.$noComp {string reverse command} -body { + run {string reverse} } -returnCodes error -result "wrong # args: should be \"string reverse string\"" -test string-24.2 {string reverse command} -body { - string reverse a b +test string-24.2.$noComp {string reverse command} -body { + run {string reverse a b} } -returnCodes error -result "wrong # args: should be \"string reverse string\"" -test string-24.3 {string reverse command - shared string} { +test string-24.3.$noComp {string reverse command - shared string} { set x abcde - string reverse $x + run {string reverse $x} } edcba -test string-24.4 {string reverse command - unshared string} { +test string-24.4.$noComp {string reverse command - unshared string} { set x abc set y de - string reverse $x$y + run {string reverse $x$y} } edcba -test string-24.5 {string reverse command - shared unicode string} { +test string-24.5.$noComp {string reverse command - shared unicode string} { set x abcde\uD0AD - string reverse $x + run {string reverse $x} } \uD0ADedcba -test string-24.6 {string reverse command - unshared string} { +test string-24.6.$noComp {string reverse command - unshared string} { set x abc set y de\uD0AD - string reverse $x$y + run {string reverse $x$y} } \uD0ADedcba -test string-24.7 {string reverse command - simple case} { - string reverse a +test string-24.7.$noComp {string reverse command - simple case} { + run {string reverse a} } a -test string-24.8 {string reverse command - simple case} { - string reverse \uD0AD +test string-24.8.$noComp {string reverse command - simple case} { + run {string reverse \uD0AD} } \uD0AD -test string-24.9 {string reverse command - simple case} { - string reverse {} +test string-24.9.$noComp {string reverse command - simple case} { + run {string reverse {}} } {} -test string-24.10 {string reverse command - corner case} { +test string-24.10.$noComp {string reverse command - corner case} { set x \uBEEF\uD0AD - string reverse $x + run {string reverse $x} } \uD0AD\uBEEF -test string-24.11 {string reverse command - corner case} { +test string-24.11.$noComp {string reverse command - corner case} { set x \uBEEF set y \uD0AD - string reverse $x$y + run {string reverse $x$y} } \uD0AD\uBEEF -test string-24.12 {string reverse command - corner case} { +test string-24.12.$noComp {string reverse command - corner case} { set x \uBEEF set y \uD0AD - string is ascii [string reverse $x$y] + run {string is ascii [run {string reverse $x$y}]} } 0 -test string-24.13 {string reverse command - pure Unicode string} { - string reverse [string range \uBEEF\uD0AD\uBEEF\uD0AD\uBEEF\uD0AD 1 5] +test string-24.13.$noComp {string reverse command - pure Unicode string} { + run {string reverse [run {string range \uBEEF\uD0AD\uBEEF\uD0AD\uBEEF\uD0AD 1 5}]} } \uD0AD\uBEEF\uD0AD\uBEEF\uD0AD -test string-24.14 {string reverse command - pure bytearray} { - binary scan [string reverse [binary format H* 010203]] H* x +test string-24.14.$noComp {string reverse command - pure bytearray} { + binary scan [run {string reverse [binary format H* 010203]}] H* x set x } 030201 -test string-24.15 {string reverse command - pure bytearray} { - binary scan [tcl::string::reverse [binary format H* 010203]] H* x +test string-24.15.$noComp {string reverse command - pure bytearray} { + binary scan [run {tcl::string::reverse [binary format H* 010203]}] H* x set x } 030201 -test string-24.16 {string reverse command - surrogates} { - string reverse \u0444bulb\uD83D\uDE02 +test string-24.16.$noComp {string reverse command - surrogates} { + run {string reverse \u0444bulb\uD83D\uDE02} } \uD83D\uDE02blub\u0444 -test string-24.17 {string reverse command - surrogates} { - string reverse \uD83D\uDE02hello\uD83D\uDE02 +test string-24.17.$noComp {string reverse command - surrogates} { + run {string reverse \uD83D\uDE02hello\uD83D\uDE02} } \uD83D\uDE02olleh\uD83D\uDE02 -test string-24.18 {string reverse command - surrogates} { +test string-24.18.$noComp {string reverse command - surrogates} { set s \u0444bulb\uD83D\uDE02 # shim shimmery ... string index $s 0 - string reverse $s + run {string reverse $s} } \uD83D\uDE02blub\u0444 -test string-24.19 {string reverse command - surrogates} { +test string-24.19.$noComp {string reverse command - surrogates} { set s \uD83D\uDE02hello\uD83D\uDE02 # shim shimmery ... string index $s 0 - string reverse $s + run {string reverse $s} } \uD83D\uDE02olleh\uD83D\uDE02 -test string-25.1 {string is list} { - string is list {a b c} +test string-25.1.$noComp {string is list} { + run {string is list {a b c}} } 1 -test string-25.2 {string is list} { - string is list "a \{b c" +test string-25.2.$noComp {string is list} { + run {string is list "a \{b c"} } 0 -test string-25.3 {string is list} { - string is list {a {b c}d e} +test string-25.3.$noComp {string is list} { + run {string is list {a {b c}d e}} } 0 -test string-25.4 {string is list} { - string is list {} +test string-25.4.$noComp {string is list} { + run {string is list {}} } 1 -test string-25.5 {string is list} { - string is list -strict {a b c} +test string-25.5.$noComp {string is list} { + run {string is list -strict {a b c}} } 1 -test string-25.6 {string is list} { - string is list -strict "a \{b c" +test string-25.6.$noComp {string is list} { + run {string is list -strict "a \{b c"} } 0 -test string-25.7 {string is list} { - string is list -strict {a {b c}d e} +test string-25.7.$noComp {string is list} { + run {string is list -strict {a {b c}d e}} } 0 -test string-25.8 {string is list} { - string is list -strict {} +test string-25.8.$noComp {string is list} { + run {string is list -strict {}} } 1 -test string-25.9 {string is list} { +test string-25.9.$noComp {string is list} { set x {} - list [string is list -failindex x {a b c}] $x + list [run {string is list -failindex x {a b c}}] $x } {1 {}} -test string-25.10 {string is list} { +test string-25.10.$noComp {string is list} { set x {} - list [string is list -failindex x "a \{b c"] $x + list [run {string is list -failindex x "a \{b c"}] $x } {0 2} -test string-25.11 {string is list} { +test string-25.11.$noComp {string is list} { set x {} - list [string is list -failindex x {a b {b c}d e}] $x + list [run {string is list -failindex x {a b {b c}d e}}] $x } {0 4} -test string-25.12 {string is list} { +test string-25.12.$noComp {string is list} { set x {} - list [string is list -failindex x {}] $x + list [run {string is list -failindex x {}}] $x } {1 {}} -test string-25.13 {string is list} { +test string-25.13.$noComp {string is list} { set x {} - list [string is list -failindex x { {b c}d e}] $x + list [run {string is list -failindex x { {b c}d e}}] $x } {0 2} -test string-25.14 {string is list} { +test string-25.14.$noComp {string is list} { set x {} - list [string is list -failindex x "\uABCD {b c}d e"] $x + list [run {string is list -failindex x "\uABCD {b c}d e"}] $x } {0 2} -test string-26.1 {tcl::prefix, not enough args} -body { +test string-26.1.$noComp {tcl::prefix, not enough args} -body { tcl::prefix match a } -returnCodes 1 -result {wrong # args: should be "tcl::prefix match ?options? table string"} -test string-26.2 {tcl::prefix, bad args} -body { +test string-26.2.$noComp {tcl::prefix, bad args} -body { tcl::prefix match a b c } -returnCodes 1 -result {bad option "a": must be -error, -exact, or -message} -test string-26.2.1 {tcl::prefix, empty table} -body { +test string-26.2.1.$noComp {tcl::prefix, empty table} -body { tcl::prefix match {} foo } -returnCodes 1 -result {bad option "foo": no valid options} -test string-26.3 {tcl::prefix, bad args} -body { +test string-26.3.$noComp {tcl::prefix, bad args} -body { tcl::prefix match -error "{}x" -exact str1 str2 } -returnCodes 1 -result {list element in braces followed by "x" instead of space} -test string-26.3.1 {tcl::prefix, bad args} -body { +test string-26.3.1.$noComp {tcl::prefix, bad args} -body { tcl::prefix match -error "x" -exact str1 str2 } -returnCodes 1 -result {error options must have an even number of elements} -test string-26.3.2 {tcl::prefix, bad args} -body { +test string-26.3.2.$noComp {tcl::prefix, bad args} -body { tcl::prefix match -error str1 str2 } -returnCodes 1 -result {missing value for -error} -test string-26.4 {tcl::prefix, bad args} -body { +test string-26.4.$noComp {tcl::prefix, bad args} -body { tcl::prefix match -message str1 str2 } -returnCodes 1 -result {missing value for -message} -test string-26.5 {tcl::prefix} { +test string-26.5.$noComp {tcl::prefix} { tcl::prefix match {apa bepa cepa depa} cepa } cepa -test string-26.6 {tcl::prefix} { +test string-26.6.$noComp {tcl::prefix} { tcl::prefix match {apa bepa cepa depa} be } bepa -test string-26.7 {tcl::prefix} -body { +test string-26.7.$noComp {tcl::prefix} -body { tcl::prefix match -exact {apa bepa cepa depa} be } -returnCodes 1 -result {bad option "be": must be apa, bepa, cepa, or depa} -test string-26.8 {tcl::prefix} -body { +test string-26.8.$noComp {tcl::prefix} -body { tcl::prefix match -message wombat {apa bepa bear depa} be } -returnCodes 1 -result {ambiguous wombat "be": must be apa, bepa, bear, or depa} -test string-26.9 {tcl::prefix} -body { +test string-26.9.$noComp {tcl::prefix} -body { tcl::prefix match -error {} {apa bepa bear depa} be } -returnCodes 0 -result {} -test string-26.10 {tcl::prefix} -body { +test string-26.10.$noComp {tcl::prefix} -body { tcl::prefix match -error {-level 1} {apa bepa bear depa} be } -returnCodes 2 -result {ambiguous option "be": must be apa, bepa, bear, or depa} -test string-26.10.1 {tcl::prefix} -setup { +test string-26.10.1.$noComp {tcl::prefix} -setup { proc _testprefix {args} { array set opts {-a x -b y -c y} foreach {opt val} $args { @@ -1978,7 +1983,7 @@ proc MemStress {args} { return $res } -test string-26.11 {tcl::prefix: testing for leaks} -body { +test string-26.11.$noComp {tcl::prefix: testing for leaks} -body { # This test is made to stress object reference management MemStress { set table {hejj miff gurk} @@ -1999,7 +2004,7 @@ test string-26.11 {tcl::prefix: testing for leaks} -body { } } -constraints memory -result {0 0 0} -test string-26.12 {tcl::prefix: testing for leaks} -body { +test string-26.12.$noComp {tcl::prefix: testing for leaks} -body { # This is a memory leak test in a form that might actually happen # in real code. The shared literal "miff" causes a connection # between the item and the table. @@ -2017,7 +2022,7 @@ test string-26.12 {tcl::prefix: testing for leaks} -body { } } -constraints memory -result 0 -test string-26.13 {tcl::prefix: testing for leaks} -body { +test string-26.13.$noComp {tcl::prefix: testing for leaks} -body { # This test is made to stress object reference management MemStress { set table [list hejj miff] @@ -2030,108 +2035,110 @@ test string-26.13 {tcl::prefix: testing for leaks} -body { } } -constraints memory -result {0} -test string-27.1 {tcl::prefix all, not enough args} -body { +test string-27.1.$noComp {tcl::prefix all, not enough args} -body { tcl::prefix all a } -returnCodes 1 -result {wrong # args: should be "tcl::prefix all table string"} -test string-27.2 {tcl::prefix all, bad args} -body { +test string-27.2.$noComp {tcl::prefix all, bad args} -body { tcl::prefix all a b c } -returnCodes 1 -result {wrong # args: should be "tcl::prefix all table string"} -test string-27.3 {tcl::prefix all, bad args} -body { +test string-27.3.$noComp {tcl::prefix all, bad args} -body { tcl::prefix all "{}x" str2 } -returnCodes 1 -result {list element in braces followed by "x" instead of space} -test string-27.4 {tcl::prefix all} { +test string-27.4.$noComp {tcl::prefix all} { tcl::prefix all {apa bepa cepa depa} c } cepa -test string-27.5 {tcl::prefix all} { +test string-27.5.$noComp {tcl::prefix all} { tcl::prefix all {apa bepa cepa depa} cepa } cepa -test string-27.6 {tcl::prefix all} { +test string-27.6.$noComp {tcl::prefix all} { tcl::prefix all {apa bepa cepa depa} cepax } {} -test string-27.7 {tcl::prefix all} { +test string-27.7.$noComp {tcl::prefix all} { tcl::prefix all {apa aska appa} a } {apa aska appa} -test string-27.8 {tcl::prefix all} { +test string-27.8.$noComp {tcl::prefix all} { tcl::prefix all {apa aska appa} ap } {apa appa} -test string-27.9 {tcl::prefix all} { +test string-27.9.$noComp {tcl::prefix all} { tcl::prefix all {apa aska appa} p } {} -test string-27.10 {tcl::prefix all} { +test string-27.10.$noComp {tcl::prefix all} { tcl::prefix all {apa aska appa} {} } {apa aska appa} -test string-28.1 {tcl::prefix longest, not enough args} -body { +test string-28.1.$noComp {tcl::prefix longest, not enough args} -body { tcl::prefix longest a } -returnCodes 1 -result {wrong # args: should be "tcl::prefix longest table string"} -test string-28.2 {tcl::prefix longest, bad args} -body { +test string-28.2.$noComp {tcl::prefix longest, bad args} -body { tcl::prefix longest a b c } -returnCodes 1 -result {wrong # args: should be "tcl::prefix longest table string"} -test string-28.3 {tcl::prefix longest, bad args} -body { +test string-28.3.$noComp {tcl::prefix longest, bad args} -body { tcl::prefix longest "{}x" str2 } -returnCodes 1 -result {list element in braces followed by "x" instead of space} -test string-28.4 {tcl::prefix longest} { +test string-28.4.$noComp {tcl::prefix longest} { tcl::prefix longest {apa bepa cepa depa} c } cepa -test string-28.5 {tcl::prefix longest} { +test string-28.5.$noComp {tcl::prefix longest} { tcl::prefix longest {apa bepa cepa depa} cepa } cepa -test string-28.6 {tcl::prefix longest} { +test string-28.6.$noComp {tcl::prefix longest} { tcl::prefix longest {apa bepa cepa depa} cepax } {} -test string-28.7 {tcl::prefix longest} { +test string-28.7.$noComp {tcl::prefix longest} { tcl::prefix longest {apa aska appa} a } a -test string-28.8 {tcl::prefix longest} { +test string-28.8.$noComp {tcl::prefix longest} { tcl::prefix longest {apa aska appa} ap } ap -test string-28.9 {tcl::prefix longest} { +test string-28.9.$noComp {tcl::prefix longest} { tcl::prefix longest {apa bska appa} a } ap -test string-28.10 {tcl::prefix longest} { +test string-28.10.$noComp {tcl::prefix longest} { tcl::prefix longest {apa bska appa} {} } {} -test string-28.11 {tcl::prefix longest} { +test string-28.11.$noComp {tcl::prefix longest} { tcl::prefix longest {{} bska appa} {} } {} -test string-28.12 {tcl::prefix longest} { +test string-28.12.$noComp {tcl::prefix longest} { tcl::prefix longest {apa {} appa} {} } {} -test string-28.13 {tcl::prefix longest} { +test string-28.13.$noComp {tcl::prefix longest} { # Test utf-8 handling tcl::prefix longest {ax\x90 bep ax\x91} a } ax -test string-29.1 {string cat, no arg} { - string cat +test string-29.1.$noComp {string cat, no arg} { + run {string cat} } "" -test string-29.2 {string cat, single arg} { +test string-29.2.$noComp {string cat, single arg} { set x FOO - string compare $x [string cat $x] + run {string compare $x [run {string cat $x}]} } 0 -test string-29.3 {string cat, two args} { +test string-29.3.$noComp {string cat, two args} { set x FOO - string compare $x$x [string cat $x $x] + run {string compare $x$x [run {string cat $x $x}]} } 0 -test string-29.4 {string cat, many args} { +test string-29.4.$noComp {string cat, many args} { set x FOO set n 260 - set xx [string repeat $x $n] - set vv [string repeat {$x} $n] - set vvs [string repeat {$x } $n] - set r1 [string compare $xx [subst $vv]] - set r2 [string compare $xx [eval "string cat $vvs"]] + set xx [run {string repeat $x $n}] + set vv [run {string repeat {$x} $n}] + set vvs [run {string repeat {$x } $n}] + set r1 [run {string compare $xx [subst $vv]}] + set r2 [run {string compare $xx [eval "run {string cat $vvs}"]}] list $r1 $r2 } {0 0} -test string-30.1.1 {[Bug ba921a8d98]: string cat} { - string cat [set data [binary format a* hello]] [encoding convertto $data] [unset data] +test string-30.1.1.$noComp {[Bug ba921a8d98]: string cat} { + run {string cat [set data [binary format a* hello]] [encoding convertto $data] [unset data]} } hellohello -test string-30.1.2 {[Bug ba921a8d98]: inplace cat by subst (compiled to "strcat" instruction)} { - set x "[set data [binary format a* hello]][encoding convertto $data][unset data]" +test string-30.1.2.$noComp {[Bug ba921a8d98]: inplace cat by subst (compiled to "strcat" instruction)} { + run {set x "[set data [binary format a* hello]][encoding convertto $data][unset data]"} } hellohello +}; # foreach noComp {0 1} + # cleanup rename MemStress {} catch {rename foo {}} -- cgit v0.12 From 4c6744bbc91eece7df6882c12efce282ad149ed7 Mon Sep 17 00:00:00 2001 From: apnadkarni Date: Tue, 24 May 2022 17:20:33 +0000 Subject: TIP 625 - Re-implementation of lists --- generic/tclCmdIL.c | 52 +- generic/tclExecute.c | 4 +- generic/tclInt.h | 204 +++- generic/tclInterp.c | 14 +- generic/tclListObj.c | 2967 ++++++++++++++++++++++++++++++++++---------------- generic/tclUtil.c | 1 + 6 files changed, 2238 insertions(+), 1004 deletions(-) diff --git a/generic/tclCmdIL.c b/generic/tclCmdIL.c index f32fd98..3d6b470 100644 --- a/generic/tclCmdIL.c +++ b/generic/tclCmdIL.c @@ -19,6 +19,7 @@ #include "tclInt.h" #include "tclRegexp.h" +#include /* * During execution of the "lsort" command, structures of the following type @@ -2898,10 +2899,15 @@ Tcl_LrepeatObjCmd( listPtr = Tcl_NewListObj(totalElems, NULL); if (totalElems) { - List *listRepPtr = ListRepPtr(listPtr); - - listRepPtr->elemCount = elementCount*objc; - dataArray = &listRepPtr->elements; + ListRep listRep; + ListObjGetRep(listPtr, &listRep); + dataArray = ListRepElementsBase(&listRep); + listRep.storePtr->numUsed = totalElems; + if (listRep.spanPtr) { + /* Future proofing in case Tcl_NewListObj returns a span */ + listRep.spanPtr->spanStart = listRep.storePtr->firstUsed; + listRep.spanPtr->spanLength = listRep.storePtr->numUsed; + } } /* @@ -3081,14 +3087,21 @@ Tcl_LreverseObjCmd( } if (Tcl_IsShared(objv[1]) - || (ListRepPtr(objv[1])->refCount > 1)) { /* Bug 1675044 */ + || ListObjRepIsShared(objv[1])) { /* Bug 1675044 */ Tcl_Obj *resultObj, **dataArray; - List *listRepPtr; + ListRep listRep; resultObj = Tcl_NewListObj(elemc, NULL); - listRepPtr = ListRepPtr(resultObj); - listRepPtr->elemCount = elemc; - dataArray = &listRepPtr->elements; + + /* Modify the internal rep in-place */ + ListObjGetRep(resultObj, &listRep); + listRep.storePtr->numUsed = elemc; + dataArray = ListRepElementsBase(&listRep); + if (listRep.spanPtr) { + /* Future proofing */ + listRep.spanPtr->spanStart = listRep.storePtr->firstUsed; + listRep.spanPtr->spanLength = listRep.storePtr->numUsed; + } for (i=0,j=elemc-1 ; ielements; + ListObjGetRep(resultPtr, &listRep); + newArray = ListRepElementsBase(&listRep); if (group) { for (i=0; elementPtr!=NULL ; elementPtr=elementPtr->nextPtr) { idx = elementPtr->payload.index; @@ -4430,20 +4444,26 @@ Tcl_LsortObjCmd( } } } - } else if (indices) { + } + else if (indices) { for (i=0; elementPtr != NULL ; elementPtr = elementPtr->nextPtr) { TclNewIndexObj(objPtr, elementPtr->payload.index); newArray[i++] = objPtr; Tcl_IncrRefCount(objPtr); } - } else { + } + else { for (i=0; elementPtr != NULL ; elementPtr = elementPtr->nextPtr) { objPtr = elementPtr->payload.objPtr; newArray[i++] = objPtr; Tcl_IncrRefCount(objPtr); } } - listRepPtr->elemCount = i; + listRep.storePtr->numUsed = i; + if (listRep.spanPtr) { + listRep.spanPtr->spanStart = listRep.storePtr->firstUsed; + listRep.spanPtr->spanLength = listRep.storePtr->numUsed; + } Tcl_SetObjResult(interp, resultPtr); } diff --git a/generic/tclExecute.c b/generic/tclExecute.c index 027b8f3..0b1a956 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -3514,7 +3514,7 @@ TEBCresume( varPtr->value.objPtr = objResultPtr = newValue; Tcl_IncrRefCount(newValue); } - if (Tcl_ListObjReplace(interp, objResultPtr, len, 0, objc, objv) + if (TclListObjAppendElements(interp, objResultPtr, objc, objv) != TCL_OK) { TRACE_ERROR(interp); goto gotError; @@ -3572,7 +3572,7 @@ TEBCresume( } else { valueToAssign = objResultPtr; } - if (Tcl_ListObjReplace(interp, valueToAssign, len, 0, + if (TclListObjAppendElements(interp, valueToAssign, objc, objv) != TCL_OK) { if (createdNewObj) { TclDecrRefCount(valueToAssign); diff --git a/generic/tclInt.h b/generic/tclInt.h index 59106cd..1f55132 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -2423,59 +2423,177 @@ typedef enum TclEolTranslation { #define TCL_INVOKE_NO_TRACEBACK (1<<2) /* - * The structure used as the internal representation of Tcl list objects. This - * struct is grown (reallocated and copied) as necessary to hold all the - * list's element pointers. The struct might contain more slots than currently - * used to hold all element pointers. This is done to make append operations - * faster. + * A Tcl list's internal representation is defined through three structures. + * + * A ListStore struct is a structure that includes a variable size array that + * serves as storage for a Tcl list. A contiguous sequence of slots in the + * array, the "in-use" area, holds valid pointers to Tcl_Obj values that + * belong to one or more Tcl lists. The unused slots before and after these + * are free slots that may be used to prepend and append without having to + * reallocate the struct. The ListStore may be shared amongst multiple lists + * and reference counted. + * + * A ListSpan struct defines a sequence of slots within a ListStore. This sequence + * always lies within the "in-use" area of the ListStore. Like ListStore, the + * structure may be shared among multiple lists and is reference counted. + * + * A ListRep struct holds the internal representation of a Tcl list as stored + * in a Tcl_Obj. It is composed of a ListStore and a ListSpan that together + * define the content of the list. The ListSpan specifies the range of slots + * within the ListStore that hold elements for this list. The ListSpan is + * optional in which case the list includes all the "in-use" slots of the + * ListStore. + * */ +typedef struct ListStore { + int refCount; + int firstUsed; /* Index of first slot in use within the slots[] array */ + int numUsed; /* Number of slots in use (starting at index firstUsed) */ + int numAllocated; /* Total number of slots[] array slots. */ + int flags; /* LISTSTORE_* flags */ + Tcl_Obj *slots[1]; /* Variable size array. The struct is grown as needed */ +} ListStore; -typedef struct List { - unsigned int refCount; - int maxElemCount; /* Total number of element array slots. */ - int 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 - * all.*/ - Tcl_Obj *elements; /* First list element; the struct is grown to - * accommodate all elements. */ -} List; +#define LISTSTORE_CANONICAL 0x1 /* All Tcl_Obj's referencing this + store have their string representation + derived from the list representation */ +/* TODO - should the limit not be based on INT_MAX and not UINT_MAX? */ #define LIST_MAX \ - (1 + (int)(((size_t)UINT_MAX - sizeof(List))/sizeof(Tcl_Obj *))) -#define LIST_SIZE(numElems) \ - (unsigned)(sizeof(List) + (((numElems) - 1) * sizeof(Tcl_Obj *))) + (1 + (int)(((size_t)UINT_MAX - sizeof(ListStore))/sizeof(Tcl_Obj *))) +#define LIST_SIZE(numSlots_) \ + (unsigned)(sizeof(ListStore) + (((numSlots_) - 1) * sizeof(Tcl_Obj *))) + +/* See comments above */ +typedef struct ListSpan { + int refCount; /* Count of references to this span record */ + int spanStart; /* Starting index within parentList where the span */ + int spanLength; /* Number of elements in the span */ +} ListSpan; + +/* See comments above */ +typedef struct ListRep { + ListStore *storePtr;/* element array shared amongst different lists */ + ListSpan *spanPtr; /* If not NULL, the span holds the range of slots + within *storePtr that contain this list elements. */ +} ListRep; + +/* + * Macros used to get access list internal representations. + * + * Naming conventions: + * ListRep* - expect a pointer to a valid ListRep + * ListObj* - expect a pointer to a Tcl_Obj whose internal type is known to + * be a list (tclListType). Will crash otherwise. + * TclListObj* - expect a pointer to a Tcl_Obj whose internal type may or may not + * be tclListType. These will convert as needed and return error if + * conversion not possible. + */ + +/* Returns the starting slot for this listRep in the contained ListStore */ +#define ListRepStart(listRepPtr_) \ + ((listRepPtr_)->spanPtr ? (listRepPtr_)->spanPtr->spanStart \ + : (listRepPtr_)->storePtr->firstUsed) + +/* Returns the number of elements in this listRep */ +#define ListRepLength(listRepPtr_) \ + ((listRepPtr_)->spanPtr ? (listRepPtr_)->spanPtr->spanLength \ + : (listRepPtr_)->storePtr->numUsed) + +/* Returns a pointer to the first slot containing this ListRep elements */ +#define ListRepElementsBase(listRepPtr_) \ + (&(listRepPtr_)->storePtr->slots[ListRepStart(listRepPtr_)]) + +/* Stores the number of elements and base address of the element array */ +#define ListRepElements(listRepPtr_, objc_, objv_) \ + (((objv_) = ListRepElementsBase(listRepPtr_)), \ + ((objc_) = ListRepLength(listRepPtr_))) + +/* Returns 1/0 whether the ListRep's ListStore is shared. */ +#define ListRepIsShared(listRepPtr_) ((listRepPtr_)->storePtr->refCount > 1) + +/* Returns a pointer to the ListStore component */ +#define ListObjStorePtr(listObj_) \ + ((ListStore *)((listObj_)->internalRep.twoPtrValue.ptr1)) + +/* Returns a pointer to the ListSpan component */ +#define ListObjSpanPtr(listObj_) \ + ((ListSpan *)((listObj_)->internalRep.twoPtrValue.ptr2)) + +/* Returns the ListRep internal representaton in a Tcl_Obj */ +#define ListObjGetRep(listObj_, listRepPtr_) \ + do { \ + (listRepPtr_)->storePtr = ListObjStorePtr(listObj_); \ + (listRepPtr_)->spanPtr = ListObjSpanPtr(listObj_); \ + } while (0) -/* - * Macro used to get the elements of a list object. - */ +/* Returns the length of the list */ +#define ListObjLength(listObj_, len_) \ + ((len_) = ListObjSpanPtr(listObj_) ? ListObjSpanPtr(listObj_)->spanLength \ + : ListObjStorePtr(listObj_)->numUsed) -#define ListRepPtr(listPtr) \ - ((List *) (listPtr)->internalRep.twoPtrValue.ptr1) +/* Returns the starting slot index of this list's elements in the ListStore */ +#define ListObjStart(listObj_) \ + (ListObjSpanPtr(listObj_) ? ListObjSpanPtr(listObj_)->spanStart \ + : ListObjStorePtr(listObj_)->firstUsed) -#define ListObjGetElements(listPtr, objc, objv) \ - ((objv) = &(ListRepPtr(listPtr)->elements), \ - (objc) = ListRepPtr(listPtr)->elemCount) +/* Stores the element count and base address of this list's elements */ +#define ListObjGetElements(listObj_, objc_, objv_) \ + (((objv_) = &ListObjStorePtr(listObj_)->slots[ListObjStart(listObj_)]), \ + (ListObjLength(listObj_, (objc_)))) -#define ListObjLength(listPtr, len) \ - ((len) = ListRepPtr(listPtr)->elemCount) +/* + * Returns 1/0 whether the internal representation (not the Tcl_Obj itself) + * is shared. Note by intent this only checks for sharing of ListStore, + * not spans. + */ +#define ListObjRepIsShared(listObj_) (ListObjStorePtr(listObj_)->refCount > 1) -#define ListObjIsCanonical(listPtr) \ - (((listPtr)->bytes == NULL) || ListRepPtr(listPtr)->canonicalFlag) +/* + * Certain commands like concat are optimized if an existing string + * representation of a list object is known to be in canonical format (i.e. + * generated from the list representation). There are three conditions when + * this will be the case: + * (1) No string representation exists which means it will obviously have + * to be generated from the list representation when needed + * (2) The ListStore flags is marked canonical. This is done at the time + * the string representation is generated from the list IF the list + * representation does not have a span (see comments in UpdateStringOfList). + * (3) The list representation does not have a span component. This is + * because list Tcl_Obj's with spans are always created from existing lists + * and never from strings (see SetListFromAny) and thus their string + * representation will always be canonical. + */ +#define ListObjIsCanonical(listObj_) \ + (((listObj_)->bytes == NULL) \ + || (ListObjStorePtr(listObj_)->flags & LISTSTORE_CANONICAL) \ + || ListObjSpanPtr(listObj_) != NULL) -#define TclListObjGetElementsM(interp, listPtr, objcPtr, objvPtr) \ - (((listPtr)->typePtr == &tclListType) \ - ? ((ListObjGetElements((listPtr), *(objcPtr), *(objvPtr))), TCL_OK)\ - : Tcl_ListObjGetElements((interp), (listPtr), (objcPtr), (objvPtr))) +/* + * Converts the Tcl_Obj to a list if it isn't one and stores the element + * count and base address of this list's elements in objcPtr_ and objvPtr_. + * Return TCL_OK on success or TCL_ERROR if the Tcl_Obj cannot be + * converted to a list. + */ +#define TclListObjGetElementsM(interp_, listObj_, objcPtr_, objvPtr_) \ + (((listObj_)->typePtr == &tclListType) \ + ? ((ListObjGetElements((listObj_), *(objcPtr_), *(objvPtr_))), \ + TCL_OK) \ + : Tcl_ListObjGetElements( \ + (interp_), (listObj_), (objcPtr_), (objvPtr_))) -#define TclListObjLengthM(interp, listPtr, lenPtr) \ - (((listPtr)->typePtr == &tclListType) \ - ? ((ListObjLength((listPtr), *(lenPtr))), TCL_OK)\ - : Tcl_ListObjLength((interp), (listPtr), (lenPtr))) +/* + * Converts the Tcl_Obj to a list if it isn't one and stores the element + * count in lenPtr_. Returns TCL_OK on success or TCL_ERROR if the + * Tcl_Obj cannot be converted to a list. + */ +#define TclListObjLengthM(interp_, listObj_, lenPtr_) \ + (((listObj_)->typePtr == &tclListType) \ + ? ((ListObjLength((listObj_), *(lenPtr_))), TCL_OK) \ + : Tcl_ListObjLength((interp_), (listObj_), (lenPtr_))) -#define TclListObjIsCanonical(listPtr) \ - (((listPtr)->typePtr == &tclListType) ? ListObjIsCanonical((listPtr)) : 0) +#define TclListObjIsCanonical(listObj_) \ + (((listObj_)->typePtr == &tclListType) ? ListObjIsCanonical((listObj_)) : 0) /* * Modes for collecting (or not) in the implementations of TclNRForeachCmd, @@ -3092,6 +3210,9 @@ MODULE_SCOPE void TclListLines(Tcl_Obj *listObj, int line, int n, MODULE_SCOPE Tcl_Obj * TclListObjCopy(Tcl_Interp *interp, Tcl_Obj *listPtr); MODULE_SCOPE Tcl_Obj * TclListObjRange(Tcl_Obj *listPtr, int fromIdx, int toIdx); +MODULE_SCOPE int TclListObjAppendElements(Tcl_Interp *interp, + Tcl_Obj *toObj, int elemCount, + Tcl_Obj *const elemObjv[]); MODULE_SCOPE Tcl_Obj * TclLsetList(Tcl_Interp *interp, Tcl_Obj *listPtr, Tcl_Obj *indexPtr, Tcl_Obj *valuePtr); MODULE_SCOPE Tcl_Obj * TclLsetFlat(Tcl_Interp *interp, Tcl_Obj *listPtr, @@ -5208,6 +5329,7 @@ typedef struct NRE_callback { #include "tclIntDecls.h" #include "tclIntPlatDecls.h" + #if !defined(USE_TCL_STUBS) && !defined(TCL_MEM_DEBUG) #define Tcl_AttemptAlloc(size) TclpAlloc(size) #define Tcl_AttemptRealloc(ptr, size) TclpRealloc((ptr), (size)) diff --git a/generic/tclInterp.c b/generic/tclInterp.c index b87bf7c..d51b289 100644 --- a/generic/tclInterp.c +++ b/generic/tclInterp.c @@ -12,6 +12,7 @@ */ #include "tclInt.h" +#include /* * A pointer to a string that holds an initialization script that if non-NULL @@ -1822,7 +1823,7 @@ AliasNRCmd( int prefc, cmdc, i; Tcl_Obj **prefv, **cmdv; Tcl_Obj *listPtr; - List *listRep; + ListRep listRep; int flags = TCL_EVAL_INVOKE; /* @@ -1834,10 +1835,15 @@ AliasNRCmd( prefv = &aliasPtr->objPtr; cmdc = prefc + objc - 1; + /* TODO - encapsulate this into tclListObj.c */ listPtr = Tcl_NewListObj(cmdc, NULL); - listRep = ListRepPtr(listPtr); - listRep->elemCount = cmdc; - cmdv = &listRep->elements; + ListObjGetRep(listPtr, &listRep); + cmdv = ListRepElementsBase(&listRep); + listRep.storePtr->numUsed = cmdc; + if (listRep.spanPtr) { + listRep.spanPtr->spanStart = listRep.storePtr->firstUsed; + listRep.spanPtr->spanLength = listRep.storePtr->numUsed; + } prefv = &aliasPtr->objPtr; memcpy(cmdv, prefv, prefc * sizeof(Tcl_Obj *)); diff --git a/generic/tclListObj.c b/generic/tclListObj.c index 597ab4a..71a8190 100644 --- a/generic/tclListObj.c +++ b/generic/tclListObj.c @@ -3,24 +3,102 @@ * * This file contains functions that implement the Tcl list object type. * - * Copyright © 1995-1997 Sun Microsystems, Inc. - * Copyright © 1998 Scriptics Corporation. - * Copyright © 2001 Kevin B. Kenny. All rights reserved. + * Copyright © 2022 Ashok P. Nadkarni. All rights reserved. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ +/* TODO - disable/configure asserts */ + +/* TODO - control these macros at build time */ +//#undef NDEBUG +//#define ENABLE_LIST_INVARIANT_CHECKS + +#ifndef NDEBUG +#define ENABLE_LIST_ASSERTS +#endif + #include "tclInt.h" #include +/* TODO - memmove is very fast. Measure at what size we should use that + (for unshared objects only) in lieu of range operations */ + +/* + * Macros for validation and bug checking. + */ +/* TODO - control these macros at build time */ +#ifdef ENABLE_LIST_ASSERTS +#define LIST_ASSERT(cond_) assert(cond_) /* TODO */ +#else +#define LIST_ASSERT(cond_) ((void) 0) +#endif + +#define LIST_ASSERT_TYPE(listObj_) \ + LIST_ASSERT((listObj_)->typePtr == &tclListType); + +#ifdef ENABLE_LIST_INVARIANT_CHECKS +#define LISTREP_CHECK(listRepPtr_) ListRepValidate(listRepPtr_) +#else +#define LISTREP_CHECK(listRepPtr_) (void) 0 +#endif + +#if defined(TCL_MEM_DEBUG) && !defined(LIST_MEM_DEBUG) +# define LIST_MEM_DEBUG +#endif + +#undef LIST_MEM_DEBUG /* List memory debug not implemented yet */ + +/* + * Flags used for controlling behavior of allocation of list + * internal representations. + * + * If the LISTREP_PANIC_ON_FAIL bit is set, the function will panic if + * list is too large or memory cannot be allocated. Without the flag + * a NULL pointer is returned. + * + * The LISTREP_SPACE_FAVOR_NONE, LISTREP_SPACE_FAVOR_FRONT, + * LISTREP_SPACE_FAVOR_BACK, LISTREP_SPACE_ONLY_BACK flags are used to + * control additional space when allocating. If none of these is present, + * the exact space requested is allocated, nothing more. Otherwise, If only + * LISTREP_FAVOR_FRONT is present, extra space is allocated with more + * towards the front. Conversely, if LISTREP_FAVOR_BACK is present extra + * space is allocated with more to the back. If both flags are present (or + * LISTREP_SPACE_FAVOR_NONE), the extra space is equally apportioned. + * Finally if LISTREP_SPACE_ONLY_BACK is present, ALL extra space is at the + * back. + */ +#define LISTREP_PANIC_ON_FAIL 0x00000001 +#define LISTREP_SPACE_FAVOR_FRONT 0x00000002 +#define LISTREP_SPACE_FAVOR_BACK 0x00000004 +#define LISTREP_SPACE_ONLY_BACK 0x00000008 +#define LISTREP_SPACE_FAVOR_NONE \ + (LISTREP_SPACE_FAVOR_FRONT | LISTREP_SPACE_FAVOR_BACK) +#define LISTREP_SPACE_FLAGS \ + (LISTREP_SPACE_FAVOR_FRONT | LISTREP_SPACE_FAVOR_BACK \ + | LISTREP_SPACE_ONLY_BACK) + /* - * Prototypes for functions defined later in this file: + * Prototypes for non-inline static functions defined later in this file: */ +static int MemoryAllocationError(Tcl_Interp *, int size); +static int ListLimitExceededError(Tcl_Interp *); +static ListStore *ListStoreNew(int objc, Tcl_Obj *const objv[], int flags); +static int ListRepInit(int objc, Tcl_Obj *const objv[], int flags, ListRep *); +static int ListRepInitAttempt(Tcl_Interp *, int objc, Tcl_Obj *const objv[], + ListRep *); +static void ListRepClone(ListRep *fromRepPtr, ListRep *toRepPtr, int flags); +static void ListRepUnsharedFreeZombies(const ListRep *repPtr); +static int TclListObjGetRep(Tcl_Interp *, Tcl_Obj *listPtr, ListRep *repPtr); +static void ListRepRange(ListRep *srcRepPtr, int rangeStart, int rangeEnd, + int preserveSrcRep, ListRep *rangeRepPtr); + +static ListStore *ListStoreReallocate(ListStore *storePtr, int numSlots); +#ifdef ENABLE_LIST_ASSERTS /* Else gcc complains about unused static */ +static void ListRepValidate(const ListRep *repPtr); +#endif -static List * AttemptNewList(Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -static List * NewListInternalRep(int objc, Tcl_Obj *const objv[], int 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); @@ -30,13 +108,7 @@ static void UpdateStringOfList(Tcl_Obj *listPtr); * The structure below defines the list Tcl object type by means of functions * that can be invoked by generic object code. * - * The internal representation of a list object is a two-pointer - * representation. The first pointer designates a List structure that contains - * an array of pointers to the element objects, together with integers that - * represent the current element count and the allocated size of the array. - * The second pointer is normally NULL; during execution of functions in this - * file that operate on nested sublists, it is occasionally used as working - * storage to avoid an auxiliary stack. + * The internal representation of a list object is ListRep defined in tcl.h. */ const Tcl_ObjType tclListType = { @@ -48,63 +120,599 @@ const Tcl_ObjType tclListType = { }; /* Macros to manipulate the List internal rep */ +#define ListRepIncrRefs(repPtr_) \ + do { \ + (repPtr_)->storePtr->refCount++; \ + if ((repPtr_)->spanPtr) \ + (repPtr_)->spanPtr->refCount++; \ + } while (0) + +/* Returns number of free unused slots at the back of the ListRep's ListStore */ +#define ListRepNumFreeTail(repPtr_) \ + ((repPtr_)->storePtr->numAllocated \ + - ((repPtr_)->storePtr->firstUsed + (repPtr_)->storePtr->numUsed)) + +/* Returns number of free unused slots at the front of the ListRep's ListStore */ +#define ListRepNumFreeHead(repPtr_) ((repPtr_)->storePtr->firstUsed) -#define ListSetInternalRep(objPtr, listRepPtr) \ - do { \ - Tcl_ObjInternalRep ir; \ - ir.twoPtrValue.ptr1 = (listRepPtr); \ - ir.twoPtrValue.ptr2 = NULL; \ - (listRepPtr)->refCount++; \ - Tcl_StoreInternalRep((objPtr), &tclListType, &ir); \ +/* Returns a pointer to the slot corresponding to list index listIdx_ */ +#define ListRepSlotPtr(repPtr_, listIdx_) \ + (&(repPtr_)->storePtr->slots[ListRepStart(repPtr_) + (listIdx_)]) + +/* + * Macros to replace the internal representation in a Tcl_Obj. There are + * subtle differences in each so make sure to use the right one to avoid + * memory leaks, access to freed memory and the like. + * + * ListObjStompRep - assumes the Tcl_Obj internal representation can be + * overwritten AND that the passed ListRep already has reference counts that + * include the reference from the Tcl_Obj. Basically just copies the pointers + * and sets the internal Tcl_Obj type to list + * + * ListObjOverwriteRep - like ListObjOverwriteRep but additionally + * increments reference counts on the passed ListRep. Generally used when + * the string representation of the Tcl_Obj is not to be modified. + * + * ListObjReplaceRepAndInvalidate - Like ListObjOverwriteRep but additionally + * assumes the Tcl_Obj internal rep is valid (and possibly even same as + * passed ListRep) and frees it first. Additionally invalidates the string + * representation. Generally used when modifying a Tcl_Obj value. + */ +#define ListObjStompRep(objPtr_, repPtr_) \ + do { \ + (objPtr_)->internalRep.twoPtrValue.ptr1 = (repPtr_)->storePtr; \ + (objPtr_)->internalRep.twoPtrValue.ptr2 = (repPtr_)->spanPtr; \ + (objPtr_)->typePtr = &tclListType; \ } while (0) -#define ListGetInternalRep(objPtr, listRepPtr) \ - do { \ - const Tcl_ObjInternalRep *irPtr; \ - irPtr = TclFetchInternalRep((objPtr), &tclListType); \ - (listRepPtr) = irPtr ? (List *)irPtr->twoPtrValue.ptr1 : NULL; \ +#define ListObjOverwriteRep(objPtr_, repPtr_) \ + do { \ + ListRepIncrRefs(repPtr_); \ + ListObjStompRep(objPtr_, repPtr_); \ } while (0) -#define ListResetInternalRep(objPtr, listRepPtr) \ - TclFetchInternalRep((objPtr), &tclListType)->twoPtrValue.ptr1 = (listRepPtr) +#define ListObjReplaceRepAndInvalidate(objPtr_, repPtr_) \ + do { \ + /* Note order important, don't use ListObjOverwriteRep! */ \ + ListRepIncrRefs(repPtr_); \ + TclFreeInternalRep(objPtr_); \ + TclInvalidateStringRep(objPtr_); \ + ListObjStompRep(objPtr_, repPtr_); \ + } while (0) +/* TODO - currently not used anywhere. Originally used in realloc code */ #ifndef TCL_MIN_ELEMENT_GROWTH -#define TCL_MIN_ELEMENT_GROWTH TCL_MIN_GROWTH/sizeof(Tcl_Obj *) +#define TCL_MIN_ELEMENT_GROWTH (TCL_MIN_GROWTH/sizeof(Tcl_Obj *)) #endif - + +/* + *------------------------------------------------------------------------ + * + * ListSpanNew -- + * + * Allocates and initializes memory for a new ListSpan. The reference + * count on the returned struct is 0. + * + * Results: + * Non-NULL pointer to the allocated ListSpan. + * + * Side effects: + * The function will panic on memory allocation failure. + * + *------------------------------------------------------------------------ + */ +static inline ListSpan * +ListSpanNew( + int firstSlot, /* Starting slot index of the span */ + int numSlots) /* Number of slots covered by the span */ +{ + ListSpan *spanPtr = (ListSpan *) ckalloc(sizeof(*spanPtr)); + spanPtr->refCount = 0; + spanPtr->spanStart = firstSlot; + spanPtr->spanLength = numSlots; + return spanPtr; +} + +/* + *------------------------------------------------------------------------ + * + * ListSpanIncrRefs -- + * + * Increments the reference count on the spanPtr + * + * Results: + * None. + * + * Side effects: + * The obvious. + * + *------------------------------------------------------------------------ + */ + +static inline void +ListSpanIncrRefs(ListSpan *spanPtr) +{ + spanPtr->refCount += 1; +} + +/* + *------------------------------------------------------------------------ + * + * ListSpanDecrRefs -- + * + * Decrements the reference count on a span, freeing the memory if + * it drops to zero or less. + * + * Results: + * None. + * + * Side effects: + * The memory may be freed. + * + *------------------------------------------------------------------------ + */ + +static inline void +ListSpanDecrRefs(ListSpan *spanPtr) +{ + if (spanPtr->refCount <= 1) { + ckfree(spanPtr); + } + else { + spanPtr->refCount -= 1; + } +} + +/* + *------------------------------------------------------------------------ + * + * ListSpanMerited -- + * + * Creation of a new list may sometimes be done as a span on existing + * storage instead of allocating new. The tradeoff is that if the + * original list is released, the new span-based list may hold on to + * more memory than desired. This function implements heuristics for + * deciding which option is better. + * + * Results: + * Returns non-0 if a span-based list is likely to be more optimal + * and 0 if not. + * + * Side effects: + * None. + * + *------------------------------------------------------------------------ + */ + +static inline int +ListSpanMerited( + int length, /* Length of the proposed span */ + int usedStorageLength, /* Number of slots currently in used */ + int allocatedStorageLength) /* Size of the currently allocated storage */ +{ + /* + TODO + - heuristics thresholds need to be determined + - currently, information about the sharing (ref count) of existing + storage is not passed. Perhaps it should be. For example if the + existing storage has a "large" ref count, then it might make sense + to do even a small span. + */ +#ifndef TCL_LIST_SPAN_MINSIZE /* May be set on build line */ +#define TCL_LIST_SPAN_MINSIZE 10 +#endif + + if (length < TCL_LIST_SPAN_MINSIZE) + return 0;/* No span for small lists */ + if (length < (allocatedStorageLength/2 - allocatedStorageLength/8)) + return 0; /* No span if less than 3/8 of allocation */ + if (length < usedStorageLength / 2) + return 0; /* No span if less than half current storage */ + + return 1; +} + +/* + *------------------------------------------------------------------------ + * + * ListStoreUpSize -- + * + * For reasons of efficiency, extra space is allocated for a ListStore + * compared to what was requested. This function calculates how many + * slots should actually be allocated for a given request size. + * + * Results: + * Number of slots to allocate. + * + * Side effects: + * None. + * + *------------------------------------------------------------------------ + */ +static inline int +ListStoreUpSize(int numSlotsRequested) { + /* TODO -how much extra? May be double only for smaller requests? */ + return numSlotsRequested < (LIST_MAX / 2) ? 2 * numSlotsRequested + : LIST_MAX; +} + +/* + *------------------------------------------------------------------------ + * + * ListRepFreeZombies -- + * + * Inline wrapper for ListRepUnsharedFreeZombies that does quick checks + * before calling it. + * + * IMPORTANT: this function must not be called on an internal + * representation of a Tcl_Obj that is itself shared. + * + * Results: + * None. + * + * Side effects: + * See comments for ListRepUnsharedFreeZombies. + * + *------------------------------------------------------------------------ + */ +static inline void +ListRepFreeZombies(const ListRep *repPtr) +{ + if (! ListRepIsShared(repPtr)) { + ListRepUnsharedFreeZombies(repPtr); + } +} + +/* + *------------------------------------------------------------------------ + * + * ObjArrayIncrRefs -- + * + * Increments the reference counts for Tcl_Obj's in a subarray. + * + * Results: + * None. + * + * Side effects: + * As above. + * + *------------------------------------------------------------------------ + */ +static inline void +ObjArrayIncrRefs( + Tcl_Obj * const *objv, /* Pointer to the array */ + int startIdx, /* Starting index of subarray within objv */ + int count) /* Number of elements in the subarray */ +{ + Tcl_Obj * const *end; + LIST_ASSERT(startIdx >= 0); + LIST_ASSERT(count >= 0); + objv += startIdx; + end = objv + count; + while (objv < end) { + Tcl_IncrRefCount(*objv); + ++objv; + } +} + +/* + *------------------------------------------------------------------------ + * + * ObjArrayDecrRefs -- + * + * Decrements the reference counts for Tcl_Obj's in a subarray. + * + * Results: + * None. + * + * Side effects: + * As above. + * + *------------------------------------------------------------------------ + */ +static inline void +ObjArrayDecrRefs( + Tcl_Obj * const *objv, /* Pointer to the array */ + int startIdx, /* Starting index of subarray within objv */ + int count) /* Number of elements in the subarray */ +{ + Tcl_Obj * const *end; + LIST_ASSERT(startIdx >= 0); + LIST_ASSERT(count >= 0); + objv += startIdx; + end = objv + count; + while (objv < end) { + Tcl_DecrRefCount(*objv); + ++objv; + } +} + +/* + *------------------------------------------------------------------------ + * + * ObjArrayCopy -- + * + * Copies an array of Tcl_Obj* pointers. + * + * Results: + * None. + * + * Side effects: + * Reference counts on copied Tcl_Obj's are incremented. + * + *------------------------------------------------------------------------ + */ +static inline void +ObjArrayCopy( + Tcl_Obj **to, /* Destination */ + int count, /* Number of pointers to copy */ + Tcl_Obj *const from[]) /* Source array of Tcl_Obj* */ +{ + Tcl_Obj **end; + LIST_ASSERT(count >= 0); + end = to + count; + /* TODO - would memmove followed by separate IncrRef loop be faster? */ + while (to < end) { + Tcl_IncrRefCount(*from); + *to++ = *from++; + } +} + +/* + *------------------------------------------------------------------------ + * + * MemoryAllocationError -- + * + * Generates a memory allocation failure error. + * + * Results: + * Always TCL_ERROR. + * + * Side effects: + * Error message and code are stored in the interpreter if not NULL. + * + *------------------------------------------------------------------------ + */ +static int +MemoryAllocationError( + Tcl_Interp *interp, /* Interpreter for error message. May be NULL */ + int size) /* Size of attempted allocation that failed */ +{ + if (interp != NULL) { + Tcl_SetObjResult( + interp, + Tcl_ObjPrintf("list construction failed: unable to alloc %u bytes", + size)); + Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL); + } + return TCL_ERROR; +} + +/* + *------------------------------------------------------------------------ + * + * ListLimitExceeded -- + * + * Generates an error for exceeding maximum list size. + * + * Results: + * Always TCL_ERROR. + * + * Side effects: + * Error message and code are stored in the interpreter if not NULL. + * + *------------------------------------------------------------------------ + */ +static int +ListLimitExceededError(Tcl_Interp *interp) +{ + if (interp != NULL) { + Tcl_SetObjResult( + interp, + Tcl_ObjPrintf("max length of a Tcl list (%d elements) exceeded", + LIST_MAX)); + Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL); + } + return TCL_ERROR; +} + +/* + *------------------------------------------------------------------------ + * + * ListRepUnsharedShiftDown -- + * + * Shifts the "in-use" contents in the ListStore for a ListRep down + * by the given number of slots. The ListStore must be unshared and + * the free space at the front of the storage area must be big enough. + * It is the caller's responsibility to check. + * + * Results: + * None. + * + * Side effects: + * The contents of the ListRep's ListStore area are shifted down in the + * storage area. The ListRep's ListSpan is updated accordingly. + * + *------------------------------------------------------------------------ + */ +static inline void +ListRepUnsharedShiftDown(ListRep *repPtr, int shiftCount) +{ + ListStore *storePtr; + + LISTREP_CHECK(repPtr); + LIST_ASSERT(!ListRepIsShared(repPtr)); + + storePtr = repPtr->storePtr; + LIST_ASSERT(storePtr->firstUsed >= shiftCount); + + memmove(&storePtr->slots[storePtr->firstUsed - shiftCount], + &storePtr->slots[storePtr->firstUsed], + storePtr->numUsed * sizeof(Tcl_Obj *)); + storePtr->firstUsed -= shiftCount; + if (repPtr->spanPtr) { + repPtr->spanPtr->spanStart -= shiftCount; + LIST_ASSERT(repPtr->spanPtr->spanLength == storePtr->numUsed); + } + else { + /* + * If there was no span, firstUsed must have been 0 (Invariant) + * AND shiftCount must have been 0 (<= firstUsed on call) + * In other words, this would have been a no-op + */ + + LIST_ASSERT(storePtr->firstUsed == 0); + LIST_ASSERT(shiftCount == 0); + } + + LISTREP_CHECK(repPtr); +} + +/* + *------------------------------------------------------------------------ + * + * ListRepUnsharedShiftUp -- + * + * Shifts the "in-use" contents in the ListStore for a ListRep up + * by the given number of slots. The ListStore must be unshared and + * the free space at the back of the storage area must be big enough. + * It is the caller's responsibility to check. + * TODO - this function is not currently used. + * + * Results: + * None. + * + * Side effects: + * The contents of the ListRep's ListStore area are shifted up in the + * storage area. The ListRep's ListSpan is updated accordingly. + * + *------------------------------------------------------------------------ + */ +static inline void ListRepUnsharedShiftUp(ListRep *repPtr, int shiftCount) +{ + ListStore *storePtr; + + LISTREP_CHECK(repPtr); + LIST_ASSERT(!ListRepIsShared(repPtr)); + + storePtr = repPtr->storePtr; + LIST_ASSERT((storePtr->firstUsed + storePtr->numUsed + shiftCount) + <= storePtr->numAllocated); + + memmove(&storePtr->slots[storePtr->firstUsed + shiftCount], + &storePtr->slots[storePtr->firstUsed], + storePtr->numUsed * sizeof(Tcl_Obj *)); + storePtr->firstUsed += shiftCount; + if (repPtr->spanPtr) { + repPtr->spanPtr->spanStart += shiftCount; + } + else { + /* No span means entire original list is span */ + /* Should have been zero before shift - Invariant TBD */ + LIST_ASSERT(storePtr->firstUsed == shiftCount); + repPtr->spanPtr = ListSpanNew(shiftCount, storePtr->numUsed); + } + + LISTREP_CHECK(repPtr); +} + +#ifdef ENABLE_LIST_ASSERTS /* Else gcc complains about unused static */ +/* + *------------------------------------------------------------------------ + * + * ListRepValidate -- + * + * Checks all invariants for a ListRep. + * + * Results: + * None. + * + * Side effects: + * Panics (assertion failure) if any invariant is not met. + * + *------------------------------------------------------------------------ + */ +static void +ListRepValidate(const ListRep *repPtr) +{ + ListStore *storePtr = repPtr->storePtr; + + (void)storePtr; /* To stop gcc from whining about unused vars */ + + /* Separate each condition so line number gives exact reason for failure */ + LIST_ASSERT(storePtr != NULL); + LIST_ASSERT(storePtr->numAllocated >= 0); + LIST_ASSERT(storePtr->numAllocated <= LIST_MAX); + LIST_ASSERT(storePtr->firstUsed >= 0); + LIST_ASSERT(storePtr->firstUsed < storePtr->numAllocated); + LIST_ASSERT(storePtr->numUsed >= 0); + LIST_ASSERT(storePtr->numUsed <= storePtr->numAllocated); + LIST_ASSERT(storePtr->firstUsed + <= (storePtr->numAllocated - storePtr->numUsed)); + +#ifdef LIST_MEM_DEBUG + for (i = 0; i < storePtr->firstUsed; ++i) { + LIST_ASSERT(storePtr->slots[i] == NULL); + } + for (i = storePtr->firstUsed + storePtr->numUsed; + i < storePtr->numAllocated; + ++i) { + LIST_ASSERT(storePtr->slots[i] == NULL); + } +#endif + + if (! ListRepIsShared(repPtr)) { + /* + * If this is the only reference and there is no span, then store + * occupancy must begin at 0 + */ + LIST_ASSERT(repPtr->spanPtr || repPtr->storePtr->firstUsed == 0); + } + + LIST_ASSERT(ListRepStart(repPtr) >= storePtr->firstUsed); + LIST_ASSERT(ListRepLength(repPtr) <= storePtr->numUsed); + LIST_ASSERT(ListRepStart(repPtr) + <= (storePtr->firstUsed + storePtr->numUsed - ListRepLength(repPtr))); + +} +#endif /* ENABLE_LIST_ASSERTS */ + /* *---------------------------------------------------------------------- * - * NewListInternalRep -- + * ListStoreNew -- * - * Creates a list internal rep with space for objc elements. objc + * Allocates a new ListStore with space for at least objc elements. objc * must be > 0. If objv!=NULL, initializes with the first objc values - * in that array. If objv==NULL, initalize list internal rep to have - * 0 elements, with space to add objc more. Flag value "p" indicates - * how to behave on failure. + * in that array. If objv==NULL, initalize 0 elements, with space + * to add objc more. + * + * Normally the function allocates the exact space requested unless + * the flags arguments has any LISTREP_SPACE_* + * bits set. See the comments for those #defines. * * Results: - * A new List struct with refCount 0 is returned. If some failure - * prevents this then if p=0, NULL is returned and otherwise the - * routine panics. + * On success, a pointer to the allocated ListStore is returned. + * On failure, panics if LISTREP_PANIC_ON_FAIL is set in flags; otherwise + * returns NULL. * * Side effects: - * The ref counts of the elements in objv are incremented since the - * resulting list now refers to them. + * The ref counts of the elements in objv are incremented on success + * since the returned ListStore references them. * *---------------------------------------------------------------------- */ - -static List * -NewListInternalRep( +static ListStore * +ListStoreNew( int objc, Tcl_Obj *const objv[], - int p) + int flags) { - List *listRepPtr; + ListStore *storePtr; + int capacity; if (objc <= 0) { - Tcl_Panic("NewListInternalRep: expects postive element count"); + Tcl_Panic("ListStoreNew: expects positive element count"); } /* @@ -113,58 +721,189 @@ NewListInternalRep( * 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) { + if (flags & LISTREP_PANIC_ON_FAIL) { Tcl_Panic("max length of a Tcl list (%d elements) exceeded", LIST_MAX); } return NULL; } - listRepPtr = (List *)attemptckalloc(LIST_SIZE(objc)); - if (listRepPtr == NULL) { - if (p) { + if (flags & LISTREP_SPACE_FLAGS) + capacity = ListStoreUpSize(objc); + else + capacity = objc; + + storePtr = (ListStore *)attemptckalloc(LIST_SIZE(capacity)); + if (storePtr == NULL && capacity != objc) { + capacity = objc; /* Try allocating exact size */ + storePtr = (ListStore *)attemptckalloc(LIST_SIZE(capacity)); + } + if (storePtr == NULL) { + if (flags & LISTREP_PANIC_ON_FAIL) { Tcl_Panic("list creation failed: unable to alloc %u bytes", LIST_SIZE(objc)); } return NULL; } - listRepPtr->canonicalFlag = 0; - listRepPtr->refCount = 0; - listRepPtr->maxElemCount = objc; + storePtr->refCount = 0; + storePtr->flags = 0; + storePtr->numAllocated = capacity; + if (capacity == objc) { + storePtr->firstUsed = 0; + } + else { + int extra = capacity - objc; + int spaceFlags = flags & LISTREP_SPACE_FLAGS; + if (spaceFlags == LISTREP_SPACE_ONLY_BACK) { + storePtr->firstUsed = 0; + } + else if (spaceFlags == LISTREP_SPACE_FAVOR_FRONT) { + /* Leave more space in the front */ + storePtr->firstUsed = + extra - (extra / 4); /* NOT same as 3*extra/4 */ + } + else if (spaceFlags == LISTREP_SPACE_FAVOR_BACK) { + /* Leave more space in the back */ + storePtr->firstUsed = extra / 4; + } + else { + /* Apportion equally */ + storePtr->firstUsed = extra / 2; + } + } if (objv) { - Tcl_Obj **elemPtrs; - int i; - - listRepPtr->elemCount = objc; - elemPtrs = &listRepPtr->elements; - for (i = 0; i < objc; i++) { - elemPtrs[i] = objv[i]; - Tcl_IncrRefCount(elemPtrs[i]); - } + storePtr->numUsed = objc; + ObjArrayCopy(&storePtr->slots[storePtr->firstUsed], objc, objv); } else { - listRepPtr->elemCount = 0; + storePtr->numUsed = 0; } - return listRepPtr; + + return storePtr; } - + +/* + *------------------------------------------------------------------------ + * + * ListStoreReallocate -- + * + * Reallocates the memory for a ListStore. + * + * Results: + * Pointer to the ListStore which may be the same as storePtr or pointer + * to a new block of memory. On reallocation failure, NULL is returned. + * + * + * Side effects: + * The memory pointed to by storePtr is freed if it a new block has to + * be returned. + * + * + *------------------------------------------------------------------------ + */ +ListStore * +ListStoreReallocate (ListStore *storePtr, int numSlots) +{ + int newCapacity; + ListStore *newStorePtr; + + newCapacity = ListStoreUpSize(numSlots); + newStorePtr = + (ListStore *)attemptckrealloc(storePtr, LIST_SIZE(newCapacity)); + if (newStorePtr == NULL) { + newCapacity = numSlots; + newStorePtr = (ListStore *)attemptckrealloc(storePtr, + LIST_SIZE(newCapacity)); + if (newStorePtr == NULL) + return NULL; + } + /* Only the capacity has changed, fix it in the header */ + newStorePtr->numAllocated = newCapacity; + return newStorePtr; +} + +/* + *---------------------------------------------------------------------- + * + * ListRepInit -- + * + * Initializes a ListRep to hold a list internal representation + * with space for objc elements. + * + * objc must be > 0. If objv!=NULL, initializes with the first objc + * values in that array. If objv==NULL, initalize list internal rep to + * have 0 elements, with space to add objc more. + * + * Normally the function allocates the exact space requested unless + * the flags arguments has one of the LISTREP_SPACE_* bits set. + * See the comments for those #defines. + * + * The reference counts of the ListStore and ListSpan (if present) + * pointed to by the initialized repPtr are set to zero. + * Caller has to manage them as necessary. + * + * Results: + * On success, TCL_OK is returned with *listRepPtr initialized. + * On failure, panics if LISTREP_PANIC_ON_FAIL is set in flags; otherwise + * returns TCL_ERROR with *listRepPtr fields set to NULL. + * + * Side effects: + * The ref counts of the elements in objv are incremented since the + * resulting list now refers to them. + * + *---------------------------------------------------------------------- + */ +static int +ListRepInit( + int objc, + Tcl_Obj *const objv[], + int flags, + ListRep *repPtr + ) +{ + ListStore *storePtr; + + storePtr = ListStoreNew(objc, objv, flags); + if (storePtr) { + repPtr->storePtr = storePtr; + if (storePtr->firstUsed == 0) { + repPtr->spanPtr = NULL; + } + else { + repPtr->spanPtr = + ListSpanNew(storePtr->firstUsed, storePtr->numUsed); + } + return TCL_OK; + } + /* + * Initialize to keep gcc happy at the call site. Else it complains + * about possibly uninitialized use. + */ + repPtr->storePtr = NULL; + repPtr->spanPtr = NULL; + return TCL_ERROR; +} + /* *---------------------------------------------------------------------- * - * AttemptNewList -- + * ListRepInitAttempt -- * - * Creates a list internal rep with space for objc elements. objc - * must be > 0. If objv!=NULL, initializes with the first objc values - * in that array. If objv==NULL, initalize list internal rep to have - * 0 elements, with space to add objc more. + * Creates a list internal rep with space for objc elements. See + * ListRepInit for requirements for parameters (in particular objc must + * be > 0). This function only adds error messages to the interpreter if + * not NULL. + * + * The reference counts of the ListStore and ListSpan (if present) + * pointed to by the initialized repPtr are set to zero. + * Caller has to manage them as necessary. * * Results: - * A new List struct with refCount 0 is returned. If some failure - * prevents this then NULL is returned, and an error message is left - * in the interp result, unless interp is NULL. + * On success, TCL_OK is returned with *listRepPtr initialized. + * On allocation failure, returnes TCL_ERROR with an error message + * in the interpreter if non-NULL. * * Side effects: * The ref counts of the elements in objv are incremented since the @@ -172,30 +911,114 @@ NewListInternalRep( * *---------------------------------------------------------------------- */ - -static List * -AttemptNewList( +static int +ListRepInitAttempt( Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]) + Tcl_Obj *const objv[], + ListRep *repPtr) { - List *listRepPtr = NewListInternalRep(objc, objv, 0); + int result = ListRepInit(objc, objv, 0, repPtr); - if (interp != NULL && listRepPtr == NULL) { - if (objc > LIST_MAX) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "max length of a Tcl list (%d elements) exceeded", - LIST_MAX)); - } else { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "list creation failed: unable to alloc %u bytes", - LIST_SIZE(objc))); - } - Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL); + if (result != TCL_OK && interp != NULL) { + if (objc > LIST_MAX) + ListLimitExceededError(interp); + else + MemoryAllocationError(interp, LIST_SIZE(objc)); } - return listRepPtr; + return result; } - + +/* + *------------------------------------------------------------------------ + * + * ListRepClone -- + * + * Does a deep clone of an existing ListRep. + * + * Normally the function allocates the exact space needed unless + * the flags arguments has one of the LISTREP_SPACE_* bits set. + * See the comments for those #defines. + * + * Results: + * None. + * + * Side effects: + * The toRepPtr location is initialized with the ListStore and ListSpan + * (if needed) containing a copy of the list elements in fromRepPtr. + * The function will panic if memory cannot be allocated. + * + *------------------------------------------------------------------------ + */ +static void +ListRepClone(ListRep *fromRepPtr, ListRep *toRepPtr, int flags) +{ + Tcl_Obj **fromObjs; + int numFrom; + + ListRepElements(fromRepPtr, numFrom, fromObjs); + ListRepInit(numFrom, fromObjs, flags | LISTREP_PANIC_ON_FAIL, toRepPtr); +} + +/* + *------------------------------------------------------------------------ + * + * ListRepUnsharedFreeZombies -- + * + * Frees any Tcl_Obj's from the "in-use" area of the ListStore for a + * ListRep that are not actually references from any lists. + * + * IMPORTANT: this function must not be called on a shared internal + * representation or the internal representation of a shared Tcl_Obj. + * + * Results: + * None. + * + * Side effects: + * The firstUsed and numUsed fields of the ListStore are updated to + * reflect the new "in-use" extent. + * + *------------------------------------------------------------------------ + */ + +static void ListRepUnsharedFreeZombies(const ListRep *repPtr) +{ + int count; + ListStore *storePtr; + ListSpan *spanPtr; + + LIST_ASSERT(!ListRepIsShared(repPtr)); + LISTREP_CHECK(repPtr); + + storePtr = repPtr->storePtr; + spanPtr = repPtr->spanPtr; + if (spanPtr == NULL) { + LIST_ASSERT(storePtr->firstUsed == 0); /* Invariant TBD */ + return; + } + + count = spanPtr->spanStart - storePtr->firstUsed; + LIST_ASSERT(count >= 0); + if (count > 0) { + ObjArrayDecrRefs(storePtr->slots, storePtr->firstUsed, count); + storePtr->firstUsed = spanPtr->spanStart; + storePtr->numUsed -= count; + } + + count = (storePtr->firstUsed + storePtr->numUsed) + - (spanPtr->spanStart + spanPtr->spanLength); + LIST_ASSERT(count >= 0); + if (count > 0) { + ObjArrayDecrRefs( + storePtr->slots, spanPtr->spanStart + spanPtr->spanLength, count); + storePtr->numUsed -= count; + } + + LIST_ASSERT(ListRepStart(repPtr) == storePtr->firstUsed); + LIST_ASSERT(ListRepLength(repPtr) == storePtr->numUsed); + LISTREP_CHECK(repPtr); +} + /* *---------------------------------------------------------------------- * @@ -240,31 +1063,22 @@ Tcl_NewListObj( int objc, /* Count of objects referenced by objv. */ Tcl_Obj *const objv[]) /* An array of pointers to Tcl objects. */ { - List *listRepPtr; - Tcl_Obj *listPtr; + ListRep listRep; + Tcl_Obj *listObj; - TclNewObj(listPtr); + TclNewObj(listObj); if (objc <= 0) { - return listPtr; + return listObj; } - /* - * Create the internal rep. - */ - - listRepPtr = NewListInternalRep(objc, objv, 1); + ListRepInit(objc, objv, LISTREP_PANIC_ON_FAIL, &listRep); + ListObjReplaceRepAndInvalidate(listObj, &listRep); - /* - * Now create the object. - */ - - TclInvalidateStringRep(listPtr); - ListSetInternalRep(listPtr, listRepPtr); - return listPtr; + return listObj; } #endif /* if TCL_MEM_DEBUG */ - + /* *---------------------------------------------------------------------- * @@ -305,29 +1119,19 @@ Tcl_DbNewListObj( int line) /* Line number in the source file; used for * debugging. */ { - Tcl_Obj *listPtr; - List *listRepPtr; + Tcl_Obj *listObj; + ListRep listRep; - TclDbNewObj(listPtr, file, line); + TclDbNewObj(listObj, file, line); if (objc <= 0) { - return listPtr; + return listObj; } - /* - * Create the internal rep. - */ - - listRepPtr = NewListInternalRep(objc, objv, 1); - - /* - * Now create the object. - */ - - TclInvalidateStringRep(listPtr); - ListSetInternalRep(listPtr, listRepPtr); + ListRepInit(objc, objv, LISTREP_PANIC_ON_FAIL, &listRep); + ListObjReplaceRepAndInvalidate(listObj, &listRep); - return listPtr; + return listObj; } #else /* if not TCL_MEM_DEBUG */ @@ -342,7 +1146,108 @@ Tcl_DbNewListObj( return Tcl_NewListObj(objc, objv); } #endif /* TCL_MEM_DEBUG */ - + +/* + *------------------------------------------------------------------------ + * + * TclNewListObj2 -- + * + * Create a new Tcl_Obj list comprising of the concatenation of two + * Tcl_Obj* arrays. + * TODO - currently this function is not used within tclListObj but + * need to see if it would be useful in other files that preallocate + * lists and then append. + * + * Results: + * Non-NULL pointer to the allocate Tcl_Obj. + * + * Side effects: + * None. + * + *------------------------------------------------------------------------ + */ +Tcl_Obj * +TclNewListObj2( + int objc1, /* Count of objects referenced by objv1. */ + Tcl_Obj *const objv1[], /* First array of pointers to Tcl objects. */ + int objc2, /* Count of objects referenced by objv2. */ + Tcl_Obj *const objv2[] /* Second array of pointers to Tcl objects. */ +) +{ + Tcl_Obj *listObj; + ListStore *storePtr; + int objc = objc1 + objc2; + + listObj = Tcl_NewListObj(objc, NULL); + if (objc == 0) { + return listObj; /* An empty object */ + } + LIST_ASSERT_TYPE(listObj); + + storePtr = ListObjStorePtr(listObj); + + LIST_ASSERT(ListObjSpanPtr(listObj) == NULL); + LIST_ASSERT(storePtr->firstUsed == 0); + LIST_ASSERT(storePtr->numUsed == 0); + LIST_ASSERT(storePtr->numAllocated >= objc); + + if (objc1) { + ObjArrayCopy(storePtr->slots, objc1, objv1); + } + if (objc2) { + ObjArrayCopy(&storePtr->slots[objc1], objc2, objv2); + } + storePtr->numUsed = objc; + return listObj; +} + +/* + *---------------------------------------------------------------------- + * + * TclListObjGetRep -- + * + * This function returns a copy of the ListRep stored + * as the internal representation of an object. The reference + * counts of the (ListStore, ListSpan) contained in the representation + * are NOT incremented. + * + * Results: + * The return value is normally TCL_OK; in this case *listRepP + * is set to a copy of the descriptor stored as the internal + * representation of the Tcl_Obj containing a list. if listPtr does not + * refer to a list object and the object can not be converted to one, + * TCL_ERROR is returned and an error message will be left in the + * interpreter's result if interp is not NULL. + * + * Side effects: + * The possible conversion of the object referenced by listPtr + * to a list object. *repPtr is initialized to the internal rep + * if result is TCL_OK, or set to NULL on error. + *---------------------------------------------------------------------- + */ + +static int +TclListObjGetRep( + Tcl_Interp *interp, /* Used to report errors if not NULL. */ + Tcl_Obj *listObj, /* List object for which an element array is + * to be returned. */ + ListRep *repPtr) /* Location to store descriptor */ +{ + if (!TclHasInternalRep(listObj, &tclListType)) { + int result; + result = SetListFromAny(interp, listObj); + if (result != TCL_OK) { + /* Init to keep gcc happy wrt uninitialized fields at call site */ + repPtr->storePtr = NULL; + repPtr->spanPtr = NULL; + return result; + } + } + ListObjGetRep(listObj, repPtr); + LISTREP_CHECK(repPtr); + return TCL_OK; +} + /* *---------------------------------------------------------------------- * @@ -364,36 +1269,32 @@ Tcl_DbNewListObj( * *---------------------------------------------------------------------- */ - void Tcl_SetListObj( Tcl_Obj *objPtr, /* Object whose internal rep to init. */ int objc, /* Count of objects referenced by objv. */ Tcl_Obj *const objv[]) /* An array of pointers to Tcl objects. */ { - List *listRepPtr; - if (Tcl_IsShared(objPtr)) { Tcl_Panic("%s called with shared object", "Tcl_SetListObj"); } /* - * Free any old string rep and any internal rep for the old type. - */ - - TclFreeInternalRep(objPtr); - TclInvalidateStringRep(objPtr); - - /* * Set the object's type to "list" and initialize the internal rep. * However, if there are no elements to put in the list, just give the - * object an empty string rep and a NULL type. + * object an empty string rep and a NULL type. NOTE ListRepInit must + * not be called with objc == 0! */ if (objc > 0) { - listRepPtr = NewListInternalRep(objc, objv, 1); - ListSetInternalRep(objPtr, listRepPtr); - } else { + ListRep listRep; + /* TODO - perhaps ask for extra space? */ + ListRepInit(objc, objv, LISTREP_PANIC_ON_FAIL, &listRep); + ListObjReplaceRepAndInvalidate(objPtr, &listRep); + } + else { + TclFreeInternalRep(objPtr); + TclInvalidateStringRep(objPtr); Tcl_InitStringRep(objPtr, NULL, 0); } } @@ -422,106 +1323,230 @@ Tcl_SetListObj( Tcl_Obj * TclListObjCopy( Tcl_Interp *interp, /* Used to report errors if not NULL. */ - Tcl_Obj *listPtr) /* List object for which an element array is + Tcl_Obj *listObj) /* List object for which an element array is * to be returned. */ { - Tcl_Obj *copyPtr; - List *listRepPtr; + Tcl_Obj *copyObj; - ListGetInternalRep(listPtr, listRepPtr); - if (NULL == listRepPtr) { - if (SetListFromAny(interp, listPtr) != TCL_OK) { + if (!TclHasInternalRep(listObj, &tclListType)) { + if (SetListFromAny(interp, listObj) != TCL_OK) { return NULL; } } - TclNewObj(copyPtr); - TclInvalidateStringRep(copyPtr); - DupListInternalRep(listPtr, copyPtr); - return copyPtr; + TclNewObj(copyObj); + TclInvalidateStringRep(copyObj); + DupListInternalRep(listObj, copyObj); + return copyObj; } /* - *---------------------------------------------------------------------- + *------------------------------------------------------------------------ * - * TclListObjRange -- + * ListRepRange -- * - * Makes a slice of a list value. - * *listPtr must be known to be a valid list. + * Initializes a ListRep as a range within the passed ListRep. + * The range limits are clamped to the list boundaries. * * Results: - * Returns a pointer to the sliced list. - * This may be a new object or the same object if not shared. + * None. * * Side effects: - * The possible conversion of the object referenced by listPtr - * to a list object. - * - *---------------------------------------------------------------------- + * TODO WARNING:- this is not a very clean interface and easy to get wrong. + * Better change it to pass in the source ListObj + * The ListStore and ListSpan referenced by in the returned ListRep + * may or may not be the same as those passed in. For example, the + * ListStore may differ because the range is small enough that a new + * ListStore is more memory-optimal. The ListSpan may differ because + * it is NULL or shared. Regardless, reference counts on the returned + * values are not incremented. Generally, ListObjReplaceRepAndInvalidate may be + * used to store the new ListRep back into an object or a ListRepIncRefs + * followed by ListRepDecrRefs to free in case of errors. + * + *------------------------------------------------------------------------ */ - -Tcl_Obj * -TclListObjRange( - Tcl_Obj *listPtr, /* List object to take a range from. */ - int fromIdx, /* Index of first element to include. */ - int toIdx) /* Index of last element to include. */ +static void +ListRepRange( + ListRep *srcRepPtr, /* Contains source of the range */ + int rangeStart, /* Index of first element to include */ + int rangeEnd, /* Index of last element to include */ + int preserveSrcRep, /* If true, srcRepPtr contents must not be + modified (generally because a shared Tcl_Obj + references it) */ + ListRep *rangeRepPtr) /* Output. Must NOT be == srcRepPtr */ { - Tcl_Obj **elemPtrs; - int listLen, i, newLen; - List *listRepPtr; + Tcl_Obj **srcElems; + int numSrcElems = ListRepLength(srcRepPtr); + int rangeLen; + int doSpan; - TclListObjGetElementsM(NULL, listPtr, &listLen, &elemPtrs); + LISTREP_CHECK(srcRepPtr); - if (fromIdx < 0) { - fromIdx = 0; + /* Take the opportunity to garbage collect */ + /* TODO - we probably do not need the preserveSrcRep here unlike later */ + if (!preserveSrcRep) { + ListRepFreeZombies(srcRepPtr); } - if (toIdx >= listLen) { - toIdx = listLen-1; + + if (rangeStart < 0) { + rangeStart = 0; } - if (fromIdx > toIdx) { - Tcl_Obj *obj; - TclNewObj(obj); - return obj; + if (rangeEnd >= numSrcElems) { + rangeEnd = numSrcElems - 1; } - - newLen = toIdx - fromIdx + 1; - - if (Tcl_IsShared(listPtr) || - ((ListRepPtr(listPtr)->refCount > 1))) { - return Tcl_NewListObj(newLen, &elemPtrs[fromIdx]); + if (rangeStart > rangeEnd) { + /* Empty list of capacity 1. */ + ListRepInit(1, NULL, LISTREP_PANIC_ON_FAIL, rangeRepPtr); + return; } - /* - * In-place is possible. - */ + rangeLen = rangeEnd - rangeStart + 1; /* - * Even if nothing below cause any changes, we still want the - * string-canonizing effect of [lrange 0 end]. + * We can create a range one of three ways: + * (1) Use a ListSpan referencing the current ListStore + * (2) Creating a new ListStore + * (3) Removing all elements outside the range in the current ListStore + * Option (3) may only be done if caller has not disallowed it AND + * the ListStore is not shared. + * + * The choice depends on heuristics related to speed and memory. + * TODO - heuristics below need to be measured and tuned. + * TODO - could rearrange below to deal with memory failure but not worth + * Might as well panic as rest of Tcl does + * + * Note: Even if nothing below cause any changes, we still want the + * string-canonizing effect of [lrange 0 end] so the Tcl_Obj should not + * be returned as is even if the range encompasses the whole list. */ + doSpan = ListSpanMerited(rangeLen, + srcRepPtr->storePtr->numUsed, + srcRepPtr->storePtr->numAllocated); + + if (doSpan) { + /* Option 1 - because span would be most efficient */ + int spanStart = ListRepStart(srcRepPtr) + rangeStart; + if (!preserveSrcRep && srcRepPtr->spanPtr + && srcRepPtr->spanPtr->refCount <= 1) { + /* If span is not shared reuse it */ + srcRepPtr->spanPtr->spanStart = spanStart; + srcRepPtr->spanPtr->spanLength = rangeLen; + *rangeRepPtr = *srcRepPtr; + } + else { + /* Span not present or is shared - Allocate a new span */ + rangeRepPtr->storePtr = srcRepPtr->storePtr; + rangeRepPtr->spanPtr = ListSpanNew(spanStart, rangeLen); + } + /* + * We have potentially created a new internal representation that + * references the same storage as srcRep but not yet incremented its + * reference count. So do NOT call freezombies if preserveSrcRep + * is mandated. + */ + if (!preserveSrcRep) { + ListRepFreeZombies(rangeRepPtr); + } + } + else if (preserveSrcRep || ListRepIsShared(srcRepPtr)) { + /* Option 2 - span or modification in place not allowed/desired */ + ListRepElements(srcRepPtr, numSrcElems, srcElems); + /* TODO - allocate extra space? */ + ListRepInit(rangeLen, + &srcElems[rangeStart], + LISTREP_PANIC_ON_FAIL, + rangeRepPtr); + } else { + /* + * Option 3 - modify in place. Note that because of the invariant + * that spanless list stores must start at 0, we have to move + * everything to the front. + * TODO - perhaps if a span already exists, no need to move to front? + * or maybe no need to move all the way to the front? + * TODO - if range is small relative to allocation, allocate new? + */ + int numAfterRangeEnd; - TclInvalidateStringRep(listPtr); + /* Asserts follow from call to ListRepFreeZombies earlier */ + LIST_ASSERT(!preserveSrcRep); + LIST_ASSERT(!ListRepIsShared(srcRepPtr)); + LIST_ASSERT(ListRepStart(srcRepPtr) == srcRepPtr->storePtr->firstUsed); + LIST_ASSERT(ListRepLength(srcRepPtr) == srcRepPtr->storePtr->numUsed); - /* - * Delete elements that should not be included. - */ + ListRepElements(srcRepPtr, numSrcElems, srcElems); - for (i = 0; i < fromIdx; i++) { - TclDecrRefCount(elemPtrs[i]); - } - for (i = toIdx + 1; i < listLen; i++) { - TclDecrRefCount(elemPtrs[i]); + /* Free leading elements outside range */ + if (rangeStart != 0) { + ObjArrayDecrRefs(srcElems, 0, rangeStart); + } + /* Ditto for trailing */ + numAfterRangeEnd = numSrcElems - (rangeEnd + 1); + LIST_ASSERT(numAfterRangeEnd + >= 0); /* Because numSrcElems > rangeEnd earlier */ + if (numAfterRangeEnd != 0) { + ObjArrayDecrRefs(srcElems, rangeEnd + 1, numAfterRangeEnd); + } + memmove(&srcRepPtr->storePtr->slots[0], + &srcRepPtr->storePtr + ->slots[srcRepPtr->storePtr->firstUsed + rangeStart], + rangeLen * sizeof(Tcl_Obj *)); + srcRepPtr->storePtr->firstUsed = 0; + srcRepPtr->storePtr->numUsed = rangeLen; + srcRepPtr->storePtr->flags = 0; + rangeRepPtr->storePtr = srcRepPtr->storePtr; /* Note no incr ref */ + rangeRepPtr->spanPtr = NULL; } - if (fromIdx > 0) { - memmove(elemPtrs, &elemPtrs[fromIdx], - (size_t) newLen * sizeof(Tcl_Obj*)); - } + /* TODO - call freezombies here if !preserveSrcRep? */ + + /* Note ref counts intentionally not incremented */ + LISTREP_CHECK(rangeRepPtr); + return; +} + +/* + *---------------------------------------------------------------------- + * + * TclListObjRange -- + * + * Makes a slice of a list value. + * *listObj must be known to be a valid list. + * + * Results: + * Returns a pointer to the sliced list. + * This may be a new object or the same object if not shared. + * Returns NULL if passed listObj was not a list and could not be + * converted to one. + * + * Side effects: + * The possible conversion of the object referenced by listPtr + * to a list object. + * + *---------------------------------------------------------------------- + */ + +Tcl_Obj * +TclListObjRange( + Tcl_Obj *listObj, /* List object to take a range from. */ + int rangeStart, /* Index of first element to include. */ + int rangeEnd) /* Index of last element to include. */ +{ + ListRep listRep; + ListRep resultRep; + + int isShared; + if (TclListObjGetRep(NULL, listObj, &listRep) != TCL_OK) + return NULL; + + isShared = Tcl_IsShared(listObj); - listRepPtr = ListRepPtr(listPtr); - listRepPtr->elemCount = newLen; + ListRepRange(&listRep, rangeStart, rangeEnd, isShared, &resultRep); - return listPtr; + if (isShared) { + TclNewObj(listObj); + } + ListObjReplaceRepAndInvalidate(listObj, &resultRep); + return listObj; } /* @@ -557,34 +1582,18 @@ TclListObjRange( int Tcl_ListObjGetElements( Tcl_Interp *interp, /* Used to report errors if not NULL. */ - Tcl_Obj *listPtr, /* List object for which an element array is + Tcl_Obj *objPtr, /* List object for which an element array is * to be returned. */ int *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. */ { - List *listRepPtr; - - ListGetInternalRep(listPtr, listRepPtr); + ListRep listRep; - if (listRepPtr == NULL) { - int result, length; - - (void) Tcl_GetStringFromObj(listPtr, &length); - if (length == 0) { - *objcPtr = 0; - *objvPtr = NULL; - return TCL_OK; - } - result = SetListFromAny(interp, listPtr); - if (result != TCL_OK) { - return result; - } - ListGetInternalRep(listPtr, listRepPtr); - } - *objcPtr = listRepPtr->elemCount; - *objvPtr = &listRepPtr->elements; + if (TclListObjGetRep(interp, objPtr, &listRep) != TCL_OK) + return TCL_ERROR; + ListRepElements(&listRep, *objcPtr, *objvPtr); return TCL_OK; } @@ -593,20 +1602,20 @@ Tcl_ListObjGetElements( * * Tcl_ListObjAppendList -- * - * This function appends the elements in the list value referenced by - * elemListPtr to the list value referenced by listPtr. + * This function appends the elements in the list fromObj + * to toObj. toObj must not be shared else the function will panic. * * Results: - * The return value is normally TCL_OK. If listPtr or elemListPtr do not + * The return value is normally TCL_OK. If fromObj or toObj do not * refer to list values, TCL_ERROR is returned and an error message is * left in the interpreter's result if interp is not NULL. * * Side effects: - * The reference counts of the elements in elemListPtr are incremented - * since the list now refers to them. listPtr and elemListPtr are + * The reference counts of the elements in fromObj are incremented + * since the list now refers to them. toObj and fromObj are * converted, if necessary, to list objects. Also, appending the new - * elements may cause listObj's array of element pointers to grow. - * listPtr's old string representation, if any, is invalidated. + * elements may cause toObj's array of element pointers to grow. + * toObj's old string representation, if any, is invalidated. * *---------------------------------------------------------------------- */ @@ -614,21 +1623,17 @@ Tcl_ListObjGetElements( int Tcl_ListObjAppendList( Tcl_Interp *interp, /* Used to report errors if not NULL. */ - Tcl_Obj *listPtr, /* List object to append elements to. */ - Tcl_Obj *elemListPtr) /* List obj with elements to append. */ + Tcl_Obj *toObj, /* List object to append elements to. */ + Tcl_Obj *fromObj) /* List obj with elements to append. */ { int objc; Tcl_Obj **objv; - if (Tcl_IsShared(listPtr)) { + if (Tcl_IsShared(toObj)) { Tcl_Panic("%s called with shared object", "Tcl_ListObjAppendList"); } - /* - * Pull the elements to append from elemListPtr. - */ - - if (TCL_OK != TclListObjGetElementsM(interp, elemListPtr, &objc, &objv)) { + if (TclListObjGetElementsM(interp, fromObj, &objc, &objv) != TCL_OK) { return TCL_ERROR; } @@ -637,182 +1642,188 @@ Tcl_ListObjAppendList( * Delete zero existing elements. */ - return Tcl_ListObjReplace(interp, listPtr, LIST_MAX, 0, objc, objv); + return TclListObjAppendElements(interp, toObj, objc, objv); } - + /* - *---------------------------------------------------------------------- + *------------------------------------------------------------------------ * - * Tcl_ListObjAppendElement -- + * TclListObjAppendElements -- * - * This function is a special purpose version of Tcl_ListObjAppendList: - * it appends a single object referenced by objPtr to the list object - * referenced by listPtr. If listPtr is not already a list object, an - * attempt will be made to convert it to one. + * Appends multiple elements to a Tcl_Obj list object. If + * the passed Tcl_Obj is not a list object, it will be converted to one + * and an error raised if the conversion fails. + * + * The Tcl_Obj must not be shared though the internal representation + * may be. * * Results: - * The return value is normally TCL_OK; in this case objPtr is added to - * the end of listPtr's list. If listPtr does not refer to a list object - * and the object can not be converted to one, TCL_ERROR is returned and - * an error message will be left in the interpreter's result if interp is - * not NULL. + * On success, TCL_OK is returned with the specified elements appended. + * On failure, TCL_ERROR is returned with an error message in the + * interpreter if not NULL. * * Side effects: - * The ref count of objPtr is incremented since the list now refers to - * it. listPtr will be converted, if necessary, to a list object. Also, - * appending the new element may cause listObj's array of element - * pointers to grow. listPtr's old string representation, if any, is - * invalidated. + * None. * - *---------------------------------------------------------------------- + *------------------------------------------------------------------------ */ - -int -Tcl_ListObjAppendElement( + int TclListObjAppendElements ( Tcl_Interp *interp, /* Used to report errors if not NULL. */ - Tcl_Obj *listPtr, /* List object to append objPtr to. */ - Tcl_Obj *objPtr) /* Object to append to listPtr's list. */ + Tcl_Obj *toObj, /* List object to append */ + int elemCount, /* Number of elements in elemObjs[] */ + Tcl_Obj * const elemObjv[]) /* Objects to append to toObj's list. */ { - List *listRepPtr, *newPtr = NULL; - int numElems, numRequired, needGrow, isShared, attempt; + ListRep listRep; + Tcl_Obj **toObjv; + int toLen; + int finalLen; - if (Tcl_IsShared(listPtr)) { - Tcl_Panic("%s called with shared object", "Tcl_ListObjAppendElement"); + if (Tcl_IsShared(toObj)) { + Tcl_Panic("%s called with shared object", "TclListObjAppendElements"); } - ListGetInternalRep(listPtr, listRepPtr); - if (listRepPtr == NULL) { - int result, length; - - (void) Tcl_GetStringFromObj(listPtr, &length); - if (length == 0) { - Tcl_SetListObj(listPtr, 1, &objPtr); - return TCL_OK; - } - result = SetListFromAny(interp, listPtr); - if (result != TCL_OK) { - return result; - } - ListGetInternalRep(listPtr, listRepPtr); - } + if (TclListObjGetRep(interp, toObj, &listRep) != TCL_OK) + return TCL_ERROR; /* Cannot be converted to a list */ - numElems = listRepPtr->elemCount; - numRequired = numElems + 1 ; - needGrow = (numRequired > listRepPtr->maxElemCount); - isShared = (listRepPtr->refCount > 1); + if (elemCount == 0) + return TCL_OK; /* Nothing to do. Note AFTER check for list above */ - if (numRequired > LIST_MAX) { - if (interp != NULL) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "max length of a Tcl list (%d elements) exceeded", - LIST_MAX)); - Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL); - } - return TCL_ERROR; + ListRepElements(&listRep, toLen, toObjv); + if (elemCount > LIST_MAX || toLen > (LIST_MAX - elemCount)) { + return ListLimitExceededError(interp); } - if (needGrow && !isShared) { + finalLen = toLen + elemCount; + if (!ListRepIsShared(&listRep)) { /* - * Need to grow + unshared internalrep => try to realloc + * Reuse storage if possible. Even if too small, realloc-ing instead + * of creating a new ListStore will save us on manipulating Tcl_Obj + * reference counts on the elements which is a substantial cost + * if the list is not small. */ + int numTailFree; - attempt = 2 * numRequired; - if (attempt <= LIST_MAX) { - newPtr = (List *)attemptckrealloc(listRepPtr, LIST_SIZE(attempt)); - } - if (newPtr == NULL) { - attempt = numRequired + 1 + TCL_MIN_ELEMENT_GROWTH; - if (attempt > LIST_MAX) { - attempt = LIST_MAX; - } - newPtr = (List *)attemptckrealloc(listRepPtr, LIST_SIZE(attempt)); - } - if (newPtr == NULL) { - attempt = numRequired; - newPtr = (List *)attemptckrealloc(listRepPtr, LIST_SIZE(attempt)); - } - if (newPtr) { - listRepPtr = newPtr; - listRepPtr->maxElemCount = attempt; - needGrow = 0; - } - } - if (isShared || needGrow) { - Tcl_Obj **dst, **src = &listRepPtr->elements; + ListRepFreeZombies(&listRep); /* Collect garbage before checking room */ - /* - * Either we have a shared internalrep and we must copy to write, or we - * need to grow and realloc attempts failed. Attempt internalrep copy. - */ + LIST_ASSERT(ListRepStart(&listRep) == listRep.storePtr->firstUsed); + LIST_ASSERT(ListRepLength(&listRep) == listRep.storePtr->numUsed); + LIST_ASSERT(toLen == listRep.storePtr->numUsed); - attempt = 2 * numRequired; - newPtr = AttemptNewList(NULL, attempt, NULL); - if (newPtr == NULL) { - attempt = numRequired + 1 + TCL_MIN_ELEMENT_GROWTH; - if (attempt > LIST_MAX) { - attempt = LIST_MAX; + if (finalLen > listRep.storePtr->numAllocated) { + ListStore *newStorePtr; + newStorePtr = ListStoreReallocate(listRep.storePtr, finalLen); + if (newStorePtr == NULL) { + return MemoryAllocationError(interp, LIST_SIZE(finalLen)); } - newPtr = AttemptNewList(NULL, attempt, NULL); - } - if (newPtr == NULL) { - attempt = numRequired; - newPtr = AttemptNewList(interp, attempt, NULL); - } - if (newPtr == NULL) { + LIST_ASSERT(newStorePtr->numAllocated >= finalLen); + listRep.storePtr = newStorePtr; /* - * All growth attempts failed; throw the error. + * WARNING: at this point the Tcl_Obj internal rep potentially + * points to freed storage if the reallocation returned a + * different location. Overwrite it to bring it back in sync. */ - - return TCL_ERROR; + ListObjStompRep(toObj, &listRep); } - - dst = &newPtr->elements; - newPtr->refCount++; - newPtr->canonicalFlag = listRepPtr->canonicalFlag; - newPtr->elemCount = listRepPtr->elemCount; - - if (isShared) { - /* - * The original internalrep must remain undisturbed. Copy into the new - * one and bump refcounts - */ - while (numElems--) { - *dst = *src++; - Tcl_IncrRefCount(*dst++); - } - listRepPtr->refCount--; - } else { - /* - * Old internalrep to be freed, re-use refCounts. - */ - - memcpy(dst, src, numElems * sizeof(Tcl_Obj *)); - ckfree(listRepPtr); + LIST_ASSERT(listRep.storePtr->numAllocated >= finalLen); + /* Current store big enough */ + numTailFree = ListRepNumFreeTail(&listRep); + LIST_ASSERT((numTailFree + listRep.storePtr->firstUsed) + >= elemCount); /* Total free */ + if (numTailFree < elemCount) { + /* Not enough room at back. Move some to front */ + int shiftCount = elemCount - numTailFree; + /* Divide remaining space between front and back */ + shiftCount += (listRep.storePtr->numAllocated - finalLen) / 2; + LIST_ASSERT(shiftCount <= listRep.storePtr->firstUsed); + if (shiftCount) + ListRepUnsharedShiftDown(&listRep, shiftCount); } - listRepPtr = newPtr; + ObjArrayCopy(&listRep.storePtr->slots[ListRepStart(&listRep) + + ListRepLength(&listRep)], + elemCount, + elemObjv); + listRep.storePtr->numUsed = finalLen; + if (listRep.spanPtr) { + LIST_ASSERT(listRep.spanPtr->spanStart + == listRep.storePtr->firstUsed); + listRep.spanPtr->spanLength = finalLen; + } + LIST_ASSERT(ListRepStart(&listRep) == listRep.storePtr->firstUsed); + LIST_ASSERT(ListRepLength(&listRep) == finalLen); + LISTREP_CHECK(&listRep); + + ListObjReplaceRepAndInvalidate(toObj, &listRep); + return TCL_OK; } - ListResetInternalRep(listPtr, listRepPtr); - listRepPtr->refCount++; - TclFreeInternalRep(listPtr); - ListSetInternalRep(listPtr, listRepPtr); - listRepPtr->refCount--; /* - * Add objPtr to the end of listPtr's array of element pointers. Increment - * the ref count for the (now shared) objPtr. + * Have to make a new list rep, either shared or no room in old one. + * If the old list did not have a span (all elements at front), do + * not leave space in the front either, assuming all appends and no + * prepends. */ + if (ListRepInit(finalLen, + NULL, + listRep.spanPtr ? LISTREP_SPACE_FAVOR_BACK + : LISTREP_SPACE_ONLY_BACK, + &listRep) + != TCL_OK) { + return TCL_ERROR; + } + LIST_ASSERT(listRep.storePtr->numAllocated >= finalLen); + + if (toLen) { + ObjArrayCopy(ListRepSlotPtr(&listRep, 0), toLen, toObjv); + } + ObjArrayCopy(ListRepSlotPtr(&listRep, toLen), elemCount, elemObjv); + listRep.storePtr->numUsed = finalLen; + if (listRep.spanPtr) { + LIST_ASSERT(listRep.spanPtr->spanStart == listRep.storePtr->firstUsed); + listRep.spanPtr->spanLength = finalLen; + } + LISTREP_CHECK(&listRep); + ListObjReplaceRepAndInvalidate(toObj, &listRep); + return TCL_OK; +} - *(&listRepPtr->elements + listRepPtr->elemCount) = objPtr; - Tcl_IncrRefCount(objPtr); - listRepPtr->elemCount++; +/* + *---------------------------------------------------------------------- + * + * Tcl_ListObjAppendElement -- + * + * This function is a special purpose version of Tcl_ListObjAppendList: + * it appends a single object referenced by elemObj to the list object + * referenced by toObj. If toObj is not already a list object, an + * attempt will be made to convert it to one. + * + * Results: + * The return value is normally TCL_OK; in this case elemObj is added to + * the end of toObj's list. If toObj does not refer to a list object + * and the object can not be converted to one, TCL_ERROR is returned and + * an error message will be left in the interpreter's result if interp is + * not NULL. + * + * Side effects: + * The ref count of elemObj is incremented since the list now refers to + * it. toObj will be converted, if necessary, to a list object. Also, + * appending the new element may cause listObj's array of element + * pointers to grow. toObj's old string representation, if any, is + * invalidated. + * + *---------------------------------------------------------------------- + */ +int +Tcl_ListObjAppendElement( + Tcl_Interp *interp, /* Used to report errors if not NULL. */ + Tcl_Obj *toObj, /* List object to append elemObj to. */ + Tcl_Obj *elemObj) /* Object to append to toObj's list. */ +{ /* - * Invalidate any old string representation since the list's internal - * representation has changed. + * TODO - compare perf with 8.6 to see if worth optimizing single + * element case */ - - TclInvalidateStringRep(listPtr); - return TCL_OK; + return TclListObjAppendElements(interp, toObj, 1, &elemObj); } /* @@ -843,33 +1854,29 @@ Tcl_ListObjAppendElement( 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. */ - Tcl_Obj **objPtrPtr) /* The resulting Tcl_Obj* is stored here. */ + Tcl_Interp *interp, /* Used to report errors if not NULL. */ + Tcl_Obj *listObj, /* List object to index into. */ + int index, /* Index of element to return. */ + Tcl_Obj **objPtrPtr) /* The resulting Tcl_Obj* is stored here. */ { - List *listRepPtr; - - ListGetInternalRep(listPtr, listRepPtr); - if (listRepPtr == NULL) { - int result, length; + Tcl_Obj **elemObjs; + int numElems; - (void) Tcl_GetStringFromObj(listPtr, &length); - if (length == 0) { - *objPtrPtr = NULL; - return TCL_OK; - } - result = SetListFromAny(interp, listPtr); - if (result != TCL_OK) { - return result; - } - ListGetInternalRep(listPtr, listRepPtr); + /* + * TODO + * Unlike the original list code, this does not optimize for lindex'ing + * an empty string when the internal rep is not already a list. On the + * other hand, this code will be faster for the case where the object + * is currently a dict. Benchmark the two cases. + */ + if (TclListObjGetElementsM(interp, listObj, &numElems, &elemObjs) + != TCL_OK) { + return TCL_ERROR; } - - if ((index < 0) || (index >= listRepPtr->elemCount)) { + if ((index < 0) || (index >= numElems)) { *objPtrPtr = NULL; } else { - *objPtrPtr = (&listRepPtr->elements)[index]; + *objPtrPtr = elemObjs[index]; } return TCL_OK; @@ -899,39 +1906,33 @@ Tcl_ListObjIndex( int Tcl_ListObjLength( - Tcl_Interp *interp, /* Used to report errors if not NULL. */ - Tcl_Obj *listPtr, /* List object whose #elements to return. */ + Tcl_Interp *interp, /* Used to report errors if not NULL. */ + Tcl_Obj *listObj, /* List object whose #elements to return. */ int *intPtr) /* The resulting int is stored here. */ { - List *listRepPtr; + ListRep listRep; - ListGetInternalRep(listPtr, listRepPtr); - if (listRepPtr == NULL) { - int result, length; - - (void) Tcl_GetStringFromObj(listPtr, &length); - if (length == 0) { - *intPtr = 0; - return TCL_OK; - } - result = SetListFromAny(interp, listPtr); - if (result != TCL_OK) { - return result; - } - ListGetInternalRep(listPtr, listRepPtr); + /* + * TODO + * Unlike the original list code, this does not optimize for lindex'ing + * an empty string when the internal rep is not already a list. On the + * other hand, this code will be faster for the case where the object + * is currently a dict. Benchmark the two cases. + */ + if (TclListObjGetRep(interp, listObj, &listRep) != TCL_OK) { + return TCL_ERROR; } - - *intPtr = listRepPtr->elemCount; + *intPtr = ListRepLength(&listRep); return TCL_OK; } - + /* *---------------------------------------------------------------------- * * Tcl_ListObjReplace -- * * This function replaces zero or more elements of the list referenced by - * listPtr with the objects from an (objc,objv) array. The objc elements + * listObj with the objects from an (objc,objv) array. The objc elements * of the array referenced by objv replace the count elements in listPtr * starting at first. * @@ -956,270 +1957,413 @@ Tcl_ListObjLength( * Side effects: * The ref counts of the objc elements in objv are incremented since the * resulting list now refers to them. Similarly, the ref counts for - * replaced objects are decremented. listPtr is converted, if necessary, - * to a list object. listPtr's old string representation, if any, is + * replaced objects are decremented. listObj is converted, if necessary, + * to a list object. listObj's old string representation, if any, is * freed. * *---------------------------------------------------------------------- */ - int Tcl_ListObjReplace( Tcl_Interp *interp, /* Used for error reporting if not NULL. */ - Tcl_Obj *listPtr, /* List object whose elements to replace. */ + Tcl_Obj *listObj, /* 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. */ - Tcl_Obj *const objv[]) /* An array of objc pointers to Tcl objects to - * insert. */ + int numToDelete, /* Number of elements to replace. */ + int numToInsert, /* Number of objects to insert. */ + Tcl_Obj *const insertObjs[])/* Tcl objects to insert */ { - List *listRepPtr; - Tcl_Obj **elemPtrs; - int needGrow, numElems, numRequired, numAfterLast, start, i, j, isShared; - - if (Tcl_IsShared(listPtr)) { + ListRep listRep; + int origListLen; + int lenChange; + int leadSegmentLen; + int tailSegmentLen; + int numFreeSlots; + int leadShift; + int tailShift; + Tcl_Obj **listObjs; + + /* TODO - refactor this monstrosity into subfunctions */ + + if (Tcl_IsShared(listObj)) { Tcl_Panic("%s called with shared object", "Tcl_ListObjReplace"); } - ListGetInternalRep(listPtr, listRepPtr); - if (listRepPtr == NULL) { - int length; - - (void) Tcl_GetStringFromObj(listPtr, &length); - if (length == 0) { - if (objc == 0) { - return TCL_OK; - } - Tcl_SetListObj(listPtr, objc, NULL); - } else { - int result = SetListFromAny(interp, listPtr); - - if (result != TCL_OK) { - return result; - } - } - ListGetInternalRep(listPtr, listRepPtr); - } - - /* - * Note that when count == 0 and objc == 0, this routine is logically a - * no-op, removing and adding no elements to the list. However, by flowing - * through this routine anyway, we get the important side effect that the - * resulting listPtr is a list in canoncial form. This is important. - * Resist any temptation to optimize this case. - */ - - elemPtrs = &listRepPtr->elements; - numElems = listRepPtr->elemCount; + if (TclListObjGetRep(interp, listObj, &listRep) != TCL_OK) + return TCL_ERROR; /* Cannot be converted to a list */ + /* Make limits sane */ + origListLen = ListRepLength(&listRep); if (first < 0) { first = 0; } - if (first >= numElems) { - first = numElems; /* So we'll insert after last element. */ + if (first > origListLen) { + first = origListLen; /* So we'll insert after last element. */ } - if (count < 0) { - count = 0; - } else if (first > INT_MAX - count /* Handle integer overflow */ - || numElems < first+count) { - - count = numElems - first; + if (numToDelete < 0) { + numToDelete = 0; } - - 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; + else if (first > INT_MAX - numToDelete /* Handle integer overflow */ + || origListLen < first + numToDelete) { + numToDelete = origListLen - first; } - isShared = (listRepPtr->refCount > 1); - numRequired = numElems - count + objc; /* Known <= LIST_MAX */ - needGrow = numRequired > listRepPtr->maxElemCount; - for (i = 0; i < objc; i++) { - Tcl_IncrRefCount(objv[i]); + if (numToInsert > LIST_MAX - (origListLen - numToDelete)) { + return ListLimitExceededError(interp); } - if (needGrow && !isShared) { - /* Try to use realloc */ - List *newPtr = NULL; - int attempt = 2 * numRequired; - if (attempt <= LIST_MAX) { - newPtr = (List *)attemptckrealloc(listRepPtr, LIST_SIZE(attempt)); - } - if (newPtr == NULL) { - attempt = numRequired + 1 + TCL_MIN_ELEMENT_GROWTH; - if (attempt > LIST_MAX) { - attempt = LIST_MAX; - } - newPtr = (List *)attemptckrealloc(listRepPtr, LIST_SIZE(attempt)); + /* + * There are a number of special cases to consider from an optimization + * point of view. + * (1) Pure deletes (numToInsert==0) from the front or back can be treated + * as a range op irrespective of whether the ListStore is shared or not + * (2) Pure inserts (numToDelete == 0) + * (2a) Pure inserts at the back can be treated as appends + * (2b) Pure inserts from the *front* can be optimized under certain + * conditions by inserting before first ListStore slot in use if there + * is room, again irrespective of sharing + * (3) If the ListStore is shared OR there is insufficient free space + * OR existing allocation is too large compared to new size, create + * a new ListStore + * (4) Unshared ListStore with sufficient free space. Delete, shift and + * insert within the ListStore. + */ + + /* Note: do not do TclInvalidateStringRep as yet in case there are errors */ + + /* Check Case (1) - Treat pure deletes from front or back as range ops */ + if (numToInsert == 0) { + if (numToDelete == 0) { + /* Should force canonical even for no-op */ + TclInvalidateStringRep(listObj); + return TCL_OK; } - if (newPtr == NULL) { - attempt = numRequired; - newPtr = (List *)attemptckrealloc(listRepPtr, LIST_SIZE(attempt)); + if (first == 0) { + /* Delete from front, so return tail */ + ListRep tailRep; + ListRepRange(&listRep, numToDelete, origListLen-1, 0, &tailRep); + ListObjReplaceRepAndInvalidate(listObj, &tailRep); + return TCL_OK; } - if (newPtr) { - listRepPtr = newPtr; - ListResetInternalRep(listPtr, listRepPtr); - elemPtrs = &listRepPtr->elements; - listRepPtr->maxElemCount = attempt; - needGrow = numRequired > listRepPtr->maxElemCount; + else if ((first+numToDelete) >= origListLen) { + /* Delete from tail, so return head */ + ListRep headRep; + ListRepRange(&listRep, 0, first-1, 0, &headRep); + ListObjReplaceRepAndInvalidate(listObj, &headRep); + return TCL_OK; } + /* Deletion from middle. Fall through to general case */ } - if (!needGrow && !isShared) { - int shift; - - /* - * Can use the current List struct. First "delete" count elements - * starting at first. - */ - for (j = first; j < first + count; j++) { - Tcl_Obj *victimPtr = elemPtrs[j]; + /* Garbage collect before checking the pure insert optimization */ + ListRepFreeZombies(&listRep); - TclDecrRefCount(victimPtr); + /* + * Check Case (2) - pure inserts under certain conditions: + */ + if (numToDelete == 0) { + /* Case (2a) - Append to list */ + if (first == origListLen) { + return TclListObjAppendElements( + interp, listObj, numToInsert, insertObjs); } /* - * Shift the elements after the last one removed to their new - * locations. + * Case (2b) - pure inserts at front under some circumstances + * (i) Insertion must be at head of list + * (ii) The list's span must be at head of the in-use slots in the store + * (iii) There must be unused room at front of the store + * NOTE THIS IS TRUE EVEN IF THE ListStore IS SHARED as it will not + * affect the other Tcl_Obj's referencing this ListStore. See the TIP. */ + if (first == 0 && /* (i) */ + ListRepStart(&listRep) == listRep.storePtr->firstUsed && /* (ii) */ + numToInsert <= listRep.storePtr->firstUsed /* (iii) */ + ) { + int newLen; + LIST_ASSERT(numToInsert); /* Else would have returned above */ + listRep.storePtr->firstUsed -= numToInsert; + ObjArrayCopy(&listRep.storePtr->slots[listRep.storePtr->firstUsed], + numToInsert, + insertObjs); + listRep.storePtr->numUsed += numToInsert; + newLen = listRep.spanPtr->spanLength + numToInsert; + if (listRep.spanPtr && listRep.spanPtr->refCount <= 1) { + /* An unshared span record, re-use it */ + listRep.spanPtr->spanStart = listRep.storePtr->firstUsed; + listRep.spanPtr->spanLength = newLen; + } + else { + /* Need a new span record */ + if (listRep.storePtr->firstUsed == 0) + listRep.spanPtr = NULL; + else + listRep.spanPtr = + ListSpanNew(listRep.storePtr->firstUsed, newLen); + } + ListObjReplaceRepAndInvalidate(listObj, &listRep); + return TCL_OK; + } + } - start = first + count; - numAfterLast = numElems - start; - shift = objc - count; /* numNewElems - numDeleted */ - if ((numAfterLast > 0) && (shift != 0)) { - Tcl_Obj **src = elemPtrs + start; - memmove(src+shift, src, numAfterLast * sizeof(Tcl_Obj*)); + /* Just for readability of the code */ + lenChange = numToInsert - numToDelete; + leadSegmentLen = first; + tailSegmentLen = origListLen - (first + numToDelete); + numFreeSlots = listRep.storePtr->numAllocated - listRep.storePtr->numUsed; + + /* + * Before further processing, if unshared, try and reallocate to avoid + * new allocation below. This avoids expensive ref count manipulation + * later by not having to go through the ListRepInit and + * ListObjReplaceAndInvalidate below. + */ + if (numFreeSlots < lenChange && !ListRepIsShared(&listRep)) { + ListStore *newStorePtr = + ListStoreReallocate(listRep.storePtr, origListLen + lenChange); + if (newStorePtr == NULL) { + return MemoryAllocationError(interp, + LIST_SIZE(origListLen + lenChange)); } - } else { + listRep.storePtr = newStorePtr; + numFreeSlots = + listRep.storePtr->numAllocated - listRep.storePtr->numUsed; /* - * Cannot use the current List struct; it is shared, too small, or - * both. Allocate a new struct and insert elements into it. + * WARNING: at this point the Tcl_Obj internal rep potentially + * points to freed storage if the reallocation returned a + * different location. Overwrite it to bring it back in sync. */ + ListObjStompRep(listObj, &listRep); + } - List *oldListRepPtr = listRepPtr; - Tcl_Obj **oldPtrs = elemPtrs; - int newMax; - - if (needGrow) { - newMax = 2 * numRequired; - } else { - newMax = listRepPtr->maxElemCount; + /* + * Case (3) a new ListStore is required + * (a) The passed-in ListStore is shared + * (b) There is not enough free space in the unshared passed-in ListStore + * (c) The new unshared size is much "smaller" (TODO) than the allocated space + * TODO - for unshared case ONLY, consider a "move" based implementation + */ + if (ListRepIsShared(&listRep) || /* 3a */ + numFreeSlots < lenChange || /* 3b */ + (origListLen + lenChange) < (listRep.storePtr->numAllocated / 4) /* 3c */ + ) { + ListRep newRep; + Tcl_Obj **toObjs; + listObjs = &listRep.storePtr->slots[ListRepStart(&listRep)]; + ListRepInit(origListLen + lenChange, + NULL, + LISTREP_PANIC_ON_FAIL | LISTREP_SPACE_FAVOR_NONE, + &newRep); + toObjs = ListRepSlotPtr(&newRep, 0); + if (leadSegmentLen > 0) { + ObjArrayCopy(toObjs, leadSegmentLen, listObjs); } - - listRepPtr = AttemptNewList(NULL, newMax, NULL); - if (listRepPtr == NULL) { - unsigned int limit = LIST_MAX - numRequired; - unsigned int extra = numRequired - numElems - + TCL_MIN_ELEMENT_GROWTH; - int growth = (int) ((extra > limit) ? limit : extra); - - listRepPtr = AttemptNewList(NULL, numRequired + growth, NULL); - if (listRepPtr == NULL) { - listRepPtr = AttemptNewList(interp, numRequired, NULL); - if (listRepPtr == NULL) { - for (i = 0; i < objc; i++) { - /* See bug 3598580 */ -#if TCL_MAJOR_VERSION > 8 - Tcl_DecrRefCount(objv[i]); -#else - objv[i]->refCount--; -#endif - } - return TCL_ERROR; - } - } + if (numToInsert > 0) { + ObjArrayCopy(&toObjs[leadSegmentLen], + numToInsert, + insertObjs); + } + if (tailSegmentLen > 0) { + ObjArrayCopy(&toObjs[leadSegmentLen + numToInsert], + tailSegmentLen, + &listObjs[leadSegmentLen+numToDelete]); } + newRep.storePtr->numUsed = origListLen + lenChange; + if (newRep.spanPtr) { + newRep.spanPtr->spanLength = newRep.storePtr->numUsed; + } + LISTREP_CHECK(&newRep); + ListObjReplaceRepAndInvalidate(listObj, &newRep); + return TCL_OK; + } - ListResetInternalRep(listPtr, listRepPtr); - listRepPtr->refCount++; + /* + * Case (4) - unshared ListStore with sufficient room. + * After deleting elements, there will be a corresponding gap. If this + * gap does not match number of insertions, either the lead segment, + * or the tail segment, or both will have to be moved. + * The general strategy is to move the fewest number of elements. If + * + * TODO - what about appends to unshared ? Is below sufficiently optimal? + */ - elemPtrs = &listRepPtr->elements; + /* Following must hold for unshared listreps after ListRepFreeZombies above */ + LIST_ASSERT(origListLen == listRep.storePtr->numUsed); + LIST_ASSERT(origListLen == ListRepLength(&listRep)); + LIST_ASSERT(ListRepStart(&listRep) == listRep.storePtr->firstUsed); - if (isShared) { - /* - * The old struct will remain in place; need new refCounts for the - * new List struct references. Copy over only the surviving - * elements. - */ + LIST_ASSERT((numToDelete + numToInsert) > 0); - for (i=0; i < first; i++) { - elemPtrs[i] = oldPtrs[i]; - Tcl_IncrRefCount(elemPtrs[i]); - } - for (i = first + count, j = first + objc; - j < numRequired; i++, j++) { - elemPtrs[j] = oldPtrs[i]; - Tcl_IncrRefCount(elemPtrs[j]); - } + /* Base of slot array holding the list elements */ + listObjs = &listRep.storePtr->slots[ListRepStart(&listRep)]; - oldListRepPtr->refCount--; - } else { - /* - * The old struct will be removed; use its inherited refCounts. - */ + /* + * Free up elements to be deleted. Before that, increment the ref counts + * for objects to be inserted in case there is overlap. See bug3598580 + * or test listobj-11.1 + */ + if (numToInsert) { + ObjArrayIncrRefs(insertObjs, 0, numToInsert); + } + if (numToDelete) { + ObjArrayDecrRefs(listObjs, first, numToDelete); + } - if (first > 0) { - memcpy(elemPtrs, oldPtrs, first * sizeof(Tcl_Obj *)); - } + /* + * Calculate shifts if necessary to accomodate insertions. + * NOTE: all indices are relative to listObjs which is not necessarily the + * start of the ListStore storage area. + * + * leadShift - how much to shift the lead segment + * tailShift - how much to shift the tail segment + * insertTarget - index where to insert. + */ + if (lenChange == 0) { + /* Exact fit */ + leadShift = 0; + tailShift = 0; + } + else if (lenChange < 0) { + /* + * More deletions than insertions. The gap after deletions is large + * enough for insertions. Move a segment depending on size. + */ + if (leadSegmentLen > tailSegmentLen) { + /* Tail segment smaller. Insert after lead, move tail down */ + leadShift = 0; + tailShift = lenChange; + } + else { + /* Lead segment smaller. Insert before tail, move lead up */ + leadShift = -lenChange; + tailShift = 0; + } + } + else { + /* + * lenChange > 0 as numToDelete < numToInsert. We need to make room + * for the insertions. Again we have multiple possibilities. We may + * be able to get by just shifting one segment or need to shift + * both. In the former case, favor shifting the smaller segment. + */ + int leadSpace = ListRepNumFreeHead(&listRep); + int tailSpace = ListRepNumFreeTail(&listRep); + int finalFreeSpace = leadSpace + tailSpace - lenChange; + + LIST_ASSERT((leadSpace + tailSpace) >= lenChange); + if (leadSpace >= lenChange + && (leadSegmentLen < tailSegmentLen || tailSpace < lenChange)) { + /* Move only lead to the front to make more room */ + leadShift = -lenChange; + tailShift = 0; /* - * "Delete" count elements starting at first. + * Note: we do not need the equivalent of the redistribution of + * free space as below since pure appending is handled earlier + * in this function. */ - - for (j = first; j < first + count; j++) { - Tcl_Obj *victimPtr = oldPtrs[j]; - - TclDecrRefCount(victimPtr); + } + else if (tailSpace >= lenChange) { + /* Move only tail segment to the back to make more room. */ + leadShift = 0; + tailShift = lenChange; + /* + * Redistribute the remaining free space between the front and + * back but only if there is no leading segment since we do not + * want to unnecessarily move two segments instead of one. This + * is an important optimization for continuous prepending. + */ + if (leadSegmentLen == 0) { + int postShiftTailSpace = tailSpace - tailShift; + if (postShiftTailSpace > (finalFreeSpace/2)) { + int extraShift = postShiftTailSpace - (finalFreeSpace / 2); + tailShift += extraShift; + /* + * Though leadSegmentLen is 0, we will need to update the + * start of used area fields. So update leadShift as well + */ + leadShift = extraShift; /* Yes, even though leadSegment + is 0 len, need to update h */ + } } - + LIST_ASSERT(tailShift <= tailSpace); + } + else { /* - * Copy the elements after the last one removed, shifted to their - * new locations. + * Both lead and tail need to be shifted to make room. + * Divide remaining free space equally between front and back. */ + LIST_ASSERT(leadSpace < lenChange); + LIST_ASSERT(tailSpace < lenChange); - start = first + count; - numAfterLast = numElems - start; - if (numAfterLast > 0) { - memcpy(elemPtrs + first + objc, oldPtrs + start, - (size_t) numAfterLast * sizeof(Tcl_Obj *)); + /* + * leadShift = leadSpace - (finalFreeSpace/2) + * Thus leadShift <= leadSpace + * Also, + * = leadSpace - (leadSpace + tailSpace - lenChange)/2 + * = leadSpace/2 - tailSpace/2 + lenChange/2 + * >= 0 because lenChange > tailSpace + */ + leadShift = leadSpace - (finalFreeSpace / 2); + tailShift = lenChange - leadShift; + if (tailShift > tailSpace) { + /* Account for integer division errors */ + leadShift += 1; + tailShift -= 1; } - - ckfree(oldListRepPtr); + /* + * Following must be true because otherwise one of the previous + * if clauses would have been taken. + */ + LIST_ASSERT(leadShift > 0 && leadShift < lenChange); + LIST_ASSERT(tailShift > 0 && tailShift < lenChange); + leadShift = -leadShift; /* Lead is actually shifted downward */ } } - /* - * Insert the new elements into elemPtrs before "first". - */ - - for (i=0,j=first ; ielemCount = numRequired; - - /* - * Invalidate and free any old representations that may not agree - * with the revised list's internal representation. - */ + listRep.storePtr->firstUsed += leadShift; + listRep.storePtr->numUsed = origListLen + lenChange; + listRep.storePtr->flags = 0; - listRepPtr->refCount++; - TclFreeInternalRep(listPtr); - ListSetInternalRep(listPtr, listRepPtr); - listRepPtr->refCount--; + if (listRep.spanPtr && listRep.spanPtr->refCount <= 1) { + /* An unshared span record, re-use it, even if not required */ + listRep.spanPtr->spanStart = listRep.storePtr->firstUsed; + listRep.spanPtr->spanLength = listRep.storePtr->numUsed; + } + else { + /* Need a new span record */ + if (listRep.storePtr->firstUsed == 0) { + listRep.spanPtr = NULL; + } + else { + listRep.spanPtr = ListSpanNew(listRep.storePtr->firstUsed, + listRep.storePtr->numUsed); + } + } - TclInvalidateStringRep(listPtr); + LISTREP_CHECK(&listRep); + ListObjReplaceRepAndInvalidate(listObj, &listRep); return TCL_OK; } + /* *---------------------------------------------------------------------- @@ -1249,28 +2393,26 @@ Tcl_ListObjReplace( Tcl_Obj * TclLindexList( Tcl_Interp *interp, /* Tcl interpreter. */ - Tcl_Obj *listPtr, /* List being unpacked. */ - Tcl_Obj *argPtr) /* Index or index list. */ + Tcl_Obj *listObj, /* List being unpacked. */ + Tcl_Obj *argObj) /* Index or index list. */ { - int index; /* Index into the list. */ Tcl_Obj *indexListCopy; - List *listRepPtr; + Tcl_Obj **indexObjs; + int numIndexObjs; /* * Determine whether argPtr designates a list or a single index. We have * to be careful about the order of the checks to avoid repeated - * shimmering; see TIP#22 and TIP#33 for the details. + * shimmering; if internal rep is already a list do not shimmer it. + * see TIP#22 and TIP#33 for the details. */ - - ListGetInternalRep(argPtr, listRepPtr); - if ((listRepPtr == NULL) - && TclGetIntForIndexM(NULL , argPtr, INT_MAX - 1, &index) == TCL_OK) { + if (!TclHasInternalRep(argObj, &tclListType) + && TclGetIntForIndexM(NULL, argObj, INT_MAX - 1, &index) == TCL_OK) { /* * argPtr designates a single index. */ - - return TclLindexFlat(interp, listPtr, 1, &argPtr); + return TclLindexFlat(interp, listObj, 1, &argObj); } /* @@ -1285,24 +2427,20 @@ TclLindexList( * implementation does not. */ - indexListCopy = TclListObjCopy(NULL, argPtr); + indexListCopy = TclListObjCopy(NULL, argObj); if (indexListCopy == NULL) { /* - * argPtr designates something that is neither an index nor a - * well-formed list. Report the error via TclLindexFlat. + * The argument is neither an index nor a well-formed list. + * Report the error via TclLindexFlat. + * TODO - This is as original. why not directly return an error? */ - - return TclLindexFlat(interp, listPtr, 1, &argPtr); + return TclLindexFlat(interp, listObj, 1, &argObj); } - ListGetInternalRep(indexListCopy, listRepPtr); - - assert(listRepPtr != NULL); - - listPtr = TclLindexFlat(interp, listPtr, listRepPtr->elemCount, - &listRepPtr->elements); + ListObjGetElements(indexListCopy, numIndexObjs, indexObjs); + listObj = TclLindexFlat(interp, listObj, numIndexObjs, indexObjs); Tcl_DecrRefCount(indexListCopy); - return listPtr; + return listObj; } /* @@ -1334,16 +2472,16 @@ TclLindexList( Tcl_Obj * TclLindexFlat( Tcl_Interp *interp, /* Tcl interpreter. */ - Tcl_Obj *listPtr, /* Tcl object representing the list. */ + Tcl_Obj *listObj, /* Tcl object representing the list. */ int indexCount, /* Count of indices. */ Tcl_Obj *const indexArray[])/* Array of pointers to Tcl objects that * represent the indices in the list. */ { int i; - Tcl_IncrRefCount(listPtr); + Tcl_IncrRefCount(listObj); - for (i=0 ; i error. - */ - + /* The sublist is not a list at all => error. */ break; } - TclListObjGetElementsM(NULL, sublistCopy, &listLen, &elemPtrs); + LIST_ASSERT_TYPE(sublistCopy); + ListObjGetElements(sublistCopy, listLen, elemPtrs); if (TclGetIntForIndexM(interp, indexArray[i], /*endValue*/ listLen-1, &index) == TCL_OK) { @@ -1381,20 +2517,17 @@ TclLindexFlat( return NULL; } } - TclNewObj(listPtr); + TclNewObj(listObj); } else { - /* - * Extract the pointer to the appropriate element. - */ - - listPtr = elemPtrs[index]; + /* Extract the pointer to the appropriate element. */ + listObj = elemPtrs[index]; } - Tcl_IncrRefCount(listPtr); + Tcl_IncrRefCount(listObj); } Tcl_DecrRefCount(sublistCopy); } - return listPtr; + return listObj; } /* @@ -1427,16 +2560,15 @@ TclLindexFlat( Tcl_Obj * TclLsetList( Tcl_Interp *interp, /* Tcl interpreter. */ - Tcl_Obj *listPtr, /* Pointer to the list being modified. */ - Tcl_Obj *indexArgPtr, /* Index or index-list arg to 'lset'. */ - Tcl_Obj *valuePtr) /* Value arg to 'lset' or NULL to 'lpop'. */ + Tcl_Obj *listObj, /* Pointer to the list being modified. */ + Tcl_Obj *indexArgObj, /* Index or index-list arg to 'lset'. */ + Tcl_Obj *valueObj) /* Value arg to 'lset' or NULL to 'lpop'. */ { int indexCount = 0; /* Number of indices in the index list. */ Tcl_Obj **indices = NULL; /* Vector of indices in the index list. */ - Tcl_Obj *retValuePtr; /* Pointer to the list to be returned. */ + Tcl_Obj *retValueObj; /* Pointer to the list to be returned. */ int index; /* Current index in the list - discarded. */ Tcl_Obj *indexListCopy; - List *listRepPtr; /* * Determine whether the index arg designates a list or a single index. @@ -1444,36 +2576,32 @@ TclLsetList( * shimmering; see TIP #22 and #23 for details. */ - ListGetInternalRep(indexArgPtr, listRepPtr); - if (listRepPtr == NULL - && TclGetIntForIndexM(NULL, indexArgPtr, INT_MAX - 1, &index) == TCL_OK) { - /* - * indexArgPtr designates a single index. - */ - - return TclLsetFlat(interp, listPtr, 1, &indexArgPtr, valuePtr); - + if (!TclHasInternalRep(indexArgObj, &tclListType) + && TclGetIntForIndexM(NULL, indexArgObj, INT_MAX - 1, &index) + == TCL_OK) { + /* indexArgPtr designates a single index. */ + return TclLsetFlat(interp, listObj, 1, &indexArgObj, valueObj); } - indexListCopy = TclListObjCopy(NULL, indexArgPtr); + indexListCopy = TclListObjCopy(NULL, indexArgObj); if (indexListCopy == NULL) { /* * indexArgPtr designates something that is neither an index nor a * well formed list. Report the error via TclLsetFlat. */ - - return TclLsetFlat(interp, listPtr, 1, &indexArgPtr, valuePtr); + return TclLsetFlat(interp, listObj, 1, &indexArgObj, valueObj); } - TclListObjGetElementsM(NULL, indexArgPtr, &indexCount, &indices); + LIST_ASSERT_TYPE(indexListCopy); + ListObjGetElements(indexListCopy, indexCount, indices); /* * Let TclLsetFlat handle the actual lset'ting. */ - retValuePtr = TclLsetFlat(interp, listPtr, indexCount, indices, valuePtr); + retValueObj = TclLsetFlat(interp, listObj, indexCount, indices, valueObj); Tcl_DecrRefCount(indexListCopy); - return retValuePtr; + return retValueObj; } /* @@ -1510,64 +2638,66 @@ TclLsetList( * caller is expected to store the returned value back in the variable * and decrement its reference count. (INST_STORE_* does exactly this.) * - * Surgery is performed on the unshared list value to produce the result. - * TclLsetFlat maintains a linked list of Tcl_Obj's whose string - * representations must be spoilt by threading via 'ptr2' of the - * two-pointer internal representation. On entry to TclLsetFlat, the - * values of 'ptr2' are immaterial; on exit, the 'ptr2' field of any - * Tcl_Obj that has been modified is set to NULL. - * *---------------------------------------------------------------------- */ Tcl_Obj * TclLsetFlat( Tcl_Interp *interp, /* Tcl interpreter. */ - Tcl_Obj *listPtr, /* Pointer to the list being modified. */ + Tcl_Obj *listObj, /* Pointer to the list being modified. */ int indexCount, /* Number of index args. */ Tcl_Obj *const indexArray[], /* Index args. */ - Tcl_Obj *valuePtr) /* Value arg to 'lset' or NULL to 'lpop'. */ + Tcl_Obj *valueObj) /* Value arg to 'lset' or NULL to 'lpop'. */ { int index, result, len; - Tcl_Obj *subListPtr, *retValuePtr, *chainPtr; - Tcl_ObjInternalRep *irPtr; + Tcl_Obj *subListObj, *retValueObj; + Tcl_Obj *pendingInvalidates[10]; + Tcl_Obj **pendingInvalidatesPtr = pendingInvalidates; + int numPendingInvalidates = 0; /* * If there are no indices, simply return the new value. (Without * indices, [lset] is a synonym for [set]. - * [lpop] does not use this but protect for NULL valuePtr just in case. + * [lpop] does not use this but protect for NULL valueObj just in case. + * TODO - should we not verify that listObj is a list? */ if (indexCount == 0) { - if (valuePtr != NULL) { - Tcl_IncrRefCount(valuePtr); + if (valueObj != NULL) { + Tcl_IncrRefCount(valueObj); } - return valuePtr; + return valueObj; } /* * If the list is shared, make a copy we can modify (copy-on-write). We * use Tcl_DuplicateObj() instead of TclListObjCopy() for a few reasons: - * 1) we have not yet confirmed listPtr is actually a list; 2) We make a + * 1) we have not yet confirmed listObj is actually a list; 2) We make a * verbatim copy of any existing string rep, and when we combine that with * the delayed invalidation of string reps of modified Tcl_Obj's * implemented below, the outcome is that any error condition that causes - * this routine to return NULL, will leave the string rep of listPtr and + * this routine to return NULL, will leave the string rep of listObj and * all elements to be unchanged. */ - subListPtr = Tcl_IsShared(listPtr) ? Tcl_DuplicateObj(listPtr) : listPtr; + subListObj = Tcl_IsShared(listObj) ? Tcl_DuplicateObj(listObj) : listObj; /* * Anchor the linked list of Tcl_Obj's whose string reps must be * invalidated if the operation succeeds. */ - retValuePtr = subListPtr; - chainPtr = NULL; + retValueObj = subListObj; result = TCL_OK; + /* Allocate if static array for pending invalidations is too small */ + if (indexCount + > (int) (sizeof(pendingInvalidates) / sizeof(pendingInvalidates[0]))) { + pendingInvalidatesPtr = + (Tcl_Obj **) ckalloc(indexCount * sizeof(*pendingInvalidatesPtr)); + } + /* * Loop through all the index arguments, and for each one dive into the * appropriate sublist. @@ -1581,8 +2711,8 @@ TclLsetFlat( * Check for the possible error conditions... */ - if (TclListObjGetElementsM(interp, subListPtr, &elemCount, &elemPtrs) - != TCL_OK) { + if (TclListObjGetElementsM(interp, subListObj, &elemCount, &elemPtrs) + != TCL_OK) { /* ...the sublist we're indexing into isn't a list at all. */ result = TCL_ERROR; break; @@ -1594,22 +2724,27 @@ TclLsetFlat( */ if (TclGetIntForIndexM(interp, *indexArray, elemCount - 1, &index) - != TCL_OK) { + != TCL_OK) { /* ...the index we're trying to use isn't an index at all. */ result = TCL_ERROR; - indexArray++; + indexArray++; /* Why bother with this increment? TBD */ break; } indexArray++; if (index < 0 || index > elemCount - || (valuePtr == NULL && index >= elemCount)) { + || (valueObj == NULL && index >= elemCount)) { /* ...the index points outside the sublist. */ if (interp != NULL) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "index \"%s\" out of range", Tcl_GetString(indexArray[-1]))); - Tcl_SetErrorCode(interp, "TCL", "VALUE", "INDEX" - "OUTOFRANGE", NULL); + Tcl_SetObjResult(interp, + Tcl_ObjPrintf("index \"%s\" out of range", + Tcl_GetString(indexArray[-1]))); + Tcl_SetErrorCode(interp, + "TCL", + "VALUE", + "INDEX" + "OUTOFRANGE", + NULL); } result = TCL_ERROR; break; @@ -1617,128 +2752,129 @@ TclLsetFlat( /* * No error conditions. As long as we're not yet on the last index, - * determine the next sublist for the next pass through the loop, and - * take steps to make sure it is an unshared copy, as we intend to - * modify it. + * determine the next sublist for the next pass through the loop, + * and take steps to make sure it is an unshared copy, as we intend + * to modify it. */ if (--indexCount) { - parentList = subListPtr; + parentList = subListObj; if (index == elemCount) { - TclNewObj(subListPtr); - } else { - subListPtr = elemPtrs[index]; + TclNewObj(subListObj); } - if (Tcl_IsShared(subListPtr)) { - subListPtr = Tcl_DuplicateObj(subListPtr); + else { + subListObj = elemPtrs[index]; + } + if (Tcl_IsShared(subListObj)) { + subListObj = Tcl_DuplicateObj(subListObj); } /* * Replace the original elemPtr[index] in parentList with a copy * we know to be unshared. This call will also deal with the * situation where parentList shares its internalrep with other - * Tcl_Obj's. Dealing with the shared internalrep case can cause - * subListPtr to become shared again, so detect that case and make - * and store another copy. + * Tcl_Obj's. Dealing with the shared internalrep case can + * cause subListObj to become shared again, so detect that case + * and make and store another copy. */ if (index == elemCount) { - Tcl_ListObjAppendElement(NULL, parentList, subListPtr); - } else { - TclListObjSetElement(NULL, parentList, index, subListPtr); + Tcl_ListObjAppendElement(NULL, parentList, subListObj); } - if (Tcl_IsShared(subListPtr)) { - subListPtr = Tcl_DuplicateObj(subListPtr); - TclListObjSetElement(NULL, parentList, index, subListPtr); + else { + TclListObjSetElement(NULL, parentList, index, subListObj); + } + if (Tcl_IsShared(subListObj)) { + subListObj = Tcl_DuplicateObj(subListObj); + TclListObjSetElement(NULL, parentList, index, subListObj); } /* - * The TclListObjSetElement() calls do not spoil the string rep of - * parentList, and that's fine for now, since all we've done so - * far is replace a list element with an unshared copy. The list - * value remains the same, so the string rep. is still valid, and - * unchanged, which is good because if this whole routine returns - * NULL, we'd like to leave no change to the value of the lset - * variable. Later on, when we set valuePtr in its proper place, - * then all containing lists will have their values changed, and - * will need their string reps spoiled. We maintain a list of all - * those Tcl_Obj's (via a little internalrep surgery) so we can spoil - * them at that time. + * The TclListObjSetElement() calls do not spoil the string rep + * of parentList, and that's fine for now, since all we've done + * so far is replace a list element with an unshared copy. The + * list value remains the same, so the string rep. is still + * valid, and unchanged, which is good because if this whole + * routine returns NULL, we'd like to leave no change to the + * value of the lset variable. Later on, when we set valueObj + * in its proper place, then all containing lists will have + * their values changed, and will need their string reps + * spoiled. We maintain a list of all those Tcl_Obj's (via a + * little internalrep surgery) so we can spoil them at that + * time. */ - irPtr = TclFetchInternalRep(parentList, &tclListType); - irPtr->twoPtrValue.ptr2 = chainPtr; - chainPtr = parentList; + pendingInvalidatesPtr[numPendingInvalidates] = parentList; + ++numPendingInvalidates; } } while (indexCount > 0); /* * Either we've detected and error condition, and exited the loop with * result == TCL_ERROR, or we've successfully reached the last index, and - * we're ready to store valuePtr. In either case, we need to clean up our + * we're ready to store valueObj. In either case, we need to clean up our * string spoiling list of Tcl_Obj's. */ - while (chainPtr) { - Tcl_Obj *objPtr = chainPtr; - List *listRepPtr; - - /* - * Clear away our internalrep surgery mess. - */ + /* TODO - this loop seems to have nothing to do in the error case + so may be skip right away if result != TCL_OK? */ + while (numPendingInvalidates > 0) { + Tcl_Obj *objPtr; - irPtr = TclFetchInternalRep(objPtr, &tclListType); - listRepPtr = (List *)irPtr->twoPtrValue.ptr1; - chainPtr = (Tcl_Obj *)irPtr->twoPtrValue.ptr2; + --numPendingInvalidates; + objPtr = pendingInvalidatesPtr[numPendingInvalidates]; if (result == TCL_OK) { - /* - * We're going to store valuePtr, so spoil string reps of all + * We're going to store valueObj, so spoil string reps of all * containing lists. + * TODO - historically, the storing of the internal rep was done + * because the ptr2 field of the internal rep was used to chain + * objects whose string rep needed to be invalidated. Now this + * is no longer the case, so replacing of the internal rep + * should not be needed. The TclInvalidateStringRep should suffice. */ - - listRepPtr->refCount++; - TclFreeInternalRep(objPtr); - ListSetInternalRep(objPtr, listRepPtr); - listRepPtr->refCount--; - - TclInvalidateStringRep(objPtr); + ListRep objInternalRep; + TclListObjGetRep(NULL, objPtr, &objInternalRep); + ListObjReplaceRepAndInvalidate(objPtr, &objInternalRep); } else { - irPtr->twoPtrValue.ptr2 = NULL; + /* TODO - do we need to do anything here */ } } + if (pendingInvalidatesPtr != pendingInvalidates) + ckfree(pendingInvalidatesPtr); + if (result != TCL_OK) { /* * Error return; message is already in interp. Clean up any excess * memory. */ - if (retValuePtr != listPtr) { - Tcl_DecrRefCount(retValuePtr); + if (retValueObj != listObj) { + Tcl_DecrRefCount(retValueObj); } return NULL; } /* - * Store valuePtr in proper sublist and return. The -1 is to avoid a + * Store valueObj in proper sublist and return. The -1 is to avoid a * compiler warning (not a problem because we checked that we have a * proper list - or something convertible to one - above). */ len = -1; - TclListObjLengthM(NULL, subListPtr, &len); - if (valuePtr == NULL) { - Tcl_ListObjReplace(NULL, subListPtr, index, 1, 0, NULL); + TclListObjLengthM(NULL, subListObj, &len); + if (valueObj == NULL) { + Tcl_ListObjReplace(NULL, subListObj, index, 1, 0, NULL); } else if (index == len) { - Tcl_ListObjAppendElement(NULL, subListPtr, valuePtr); + Tcl_ListObjAppendElement(NULL, subListObj, valueObj); } else { - TclListObjSetElement(NULL, subListPtr, index, valuePtr); - TclInvalidateStringRep(subListPtr); + TclListObjSetElement(NULL, subListObj, index, valueObj); + TclInvalidateStringRep(subListObj); } - Tcl_IncrRefCount(retValuePtr); - return retValuePtr; + Tcl_IncrRefCount(retValueObj); + return retValueObj; } /* @@ -1749,24 +2885,21 @@ TclLsetFlat( * Set a single element of a list to a specified value * * Results: - * The return value is normally TCL_OK. If listPtr does not refer to a + * The return value is normally TCL_OK. If listObj does not refer to a * list object and cannot be converted to one, TCL_ERROR is returned and * an error message will be left in the interpreter result if interp is * not NULL. Similarly, if index designates an element outside the range * [0..listLength-1], where listLength is the count of elements in the - * list object designated by listPtr, TCL_ERROR is returned and an error + * list object designated by listObj, TCL_ERROR is returned and an error * message is left in the interpreter result. * * Side effects: - * Tcl_Panic if listPtr designates a shared object. Otherwise, attempts + * Tcl_Panic if listObj designates a shared object. Otherwise, attempts * to convert it to a list with a non-shared internal rep. Decrements the * ref count of the object at the specified index within the list, - * replaces with the object designated by valuePtr, and increments the + * replaces with the object designated by valueObj, and increments the * ref count of the replacement object. * - * It is the caller's responsibility to invalidate the string - * representation of the object. - * *---------------------------------------------------------------------- */ @@ -1774,52 +2907,29 @@ int TclListObjSetElement( Tcl_Interp *interp, /* Tcl interpreter; used for error reporting * if not NULL. */ - Tcl_Obj *listPtr, /* List object in which element should be + Tcl_Obj *listObj, /* List object in which element should be * stored. */ int index, /* Index of element to store. */ - Tcl_Obj *valuePtr) /* Tcl object to store in the designated list + Tcl_Obj *valueObj) /* Tcl object to store in the designated list * element. */ { - List *listRepPtr; /* Internal representation of the list being - * modified. */ - Tcl_Obj **elemPtrs; /* Pointers to elements of the list. */ + ListRep listRep; + Tcl_Obj **elemPtrs; /* Pointers to elements of the list. */ int elemCount; /* Number of elements in the list. */ - /* - * Ensure that the listPtr parameter designates an unshared list. - */ + /* Ensure that the listObj parameter designates an unshared list. */ - if (Tcl_IsShared(listPtr)) { + if (Tcl_IsShared(listObj)) { Tcl_Panic("%s called with shared object", "TclListObjSetElement"); } - ListGetInternalRep(listPtr, listRepPtr); - if (listRepPtr == NULL) { - int result, length; - - (void) Tcl_GetStringFromObj(listPtr, &length); - if (length == 0) { - if (interp != NULL) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "index \"%d\" out of range", index)); - Tcl_SetErrorCode(interp, "TCL", "VALUE", "INDEX", - "OUTOFRANGE", NULL); - } - return TCL_ERROR; - } - result = SetListFromAny(interp, listPtr); - if (result != TCL_OK) { - return result; - } - ListGetInternalRep(listPtr, listRepPtr); + if (TclListObjGetRep(interp, listObj, &listRep) != TCL_OK) { + return TCL_ERROR; } - elemCount = listRepPtr->elemCount; - - /* - * Ensure that the index is in bounds. - */ + elemCount = ListRepLength(&listRep); + /* Ensure that the index is in bounds. */ if (index<0 || index>=elemCount) { if (interp != NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( @@ -1830,66 +2940,27 @@ TclListObjSetElement( return TCL_ERROR; } - /* - * If the internal rep is shared, replace it with an unshared copy. - */ - - if (listRepPtr->refCount > 1) { - Tcl_Obj **dst, **src = &listRepPtr->elements; - List *newPtr = AttemptNewList(NULL, listRepPtr->maxElemCount, NULL); - - if (newPtr == NULL) { - newPtr = AttemptNewList(interp, elemCount, NULL); - if (newPtr == NULL) { - return TCL_ERROR; - } - } - newPtr->refCount++; - newPtr->elemCount = elemCount; - newPtr->canonicalFlag = listRepPtr->canonicalFlag; - - dst = &newPtr->elements; - while (elemCount--) { - *dst = *src++; - Tcl_IncrRefCount(*dst++); - } - - listRepPtr->refCount--; - - listRepPtr = newPtr; - ListResetInternalRep(listPtr, listRepPtr); + /* Replace a shared internal rep with an unshared copy */ + if (listRep.storePtr->refCount > 1) { + ListRep newInternalRep; + /* TODO - leave extra space? */ + ListRepClone(&listRep, &newInternalRep, LISTREP_PANIC_ON_FAIL); + listRep = newInternalRep; } - elemPtrs = &listRepPtr->elements; - /* - * Add a reference to the new list element. - */ - - Tcl_IncrRefCount(valuePtr); + /* Retrieve element array AFTER potential cloning above */ + ListRepElements(&listRep, elemCount, elemPtrs); /* - * Remove a reference from the old list element. + * Add a reference to the new list element and remove from old before + * replacing it. Order is important! */ - + Tcl_IncrRefCount(valueObj); Tcl_DecrRefCount(elemPtrs[index]); + elemPtrs[index] = valueObj; - /* - * Stash the new object in the list. - */ - - elemPtrs[index] = valuePtr; - - /* - * Invalidate outdated internalreps. - */ - - ListGetInternalRep(listPtr, listRepPtr); - listRepPtr->refCount++; - TclFreeInternalRep(listPtr); - ListSetInternalRep(listPtr, listRepPtr); - listRepPtr->refCount--; - - TclInvalidateStringRep(listPtr); + /* Internal rep may be cloned so replace */ + ListObjReplaceRepAndInvalidate(listObj, &listRep); return TCL_OK; } @@ -1914,21 +2985,19 @@ TclListObjSetElement( static void FreeListInternalRep( - Tcl_Obj *listPtr) /* List object with internal rep to free. */ + Tcl_Obj *listObj) /* List object with internal rep to free. */ { - List *listRepPtr; - - ListGetInternalRep(listPtr, listRepPtr); - assert(listRepPtr != NULL); - - if (listRepPtr->refCount-- <= 1) { - Tcl_Obj **elemPtrs = &listRepPtr->elements; - int i, numElems = listRepPtr->elemCount; - - for (i = 0; i < numElems; i++) { - Tcl_DecrRefCount(elemPtrs[i]); - } - ckfree(listRepPtr); + ListRep listRep; + + ListObjGetRep(listObj, &listRep); + if (listRep.storePtr->refCount-- <= 1) { + ObjArrayDecrRefs( + listRep.storePtr->slots, + listRep.storePtr->firstUsed, listRep.storePtr->numUsed); + ckfree(listRep.storePtr); + } + if (listRep.spanPtr) { + ListSpanDecrRefs(listRep.spanPtr); } } @@ -1951,16 +3020,14 @@ FreeListInternalRep( static void DupListInternalRep( - Tcl_Obj *srcPtr, /* Object with internal rep to copy. */ - Tcl_Obj *copyPtr) /* Object with internal rep to set. */ + Tcl_Obj *srcObj, /* Object with internal rep to copy. */ + Tcl_Obj *copyObj) /* Object with internal rep to set. */ { - List *listRepPtr; - - ListGetInternalRep(srcPtr, listRepPtr); - assert(listRepPtr != NULL); - ListSetInternalRep(copyPtr, listRepPtr); + ListRep listRep; + ListObjGetRep(srcObj, &listRep); + ListObjOverwriteRep(copyObj, &listRep); } - + /* *---------------------------------------------------------------------- * @@ -1985,8 +3052,8 @@ SetListFromAny( Tcl_Interp *interp, /* Used for error reporting if not NULL. */ Tcl_Obj *objPtr) /* The object to convert. */ { - List *listRepPtr; Tcl_Obj **elemPtrs; + ListRep listRep; /* * Dictionaries are a special case; they have a string representation such @@ -2011,17 +3078,22 @@ SetListFromAny( */ Tcl_DictObjSize(NULL, objPtr, &size); - listRepPtr = AttemptNewList(interp, size > 0 ? 2*size : 1, NULL); - if (!listRepPtr) { + /* TODO - leave space in front and/or back? */ + if (ListRepInitAttempt( + interp, size > 0 ? 2 * size : 1, NULL, &listRep) + != TCL_OK) { return TCL_ERROR; } - listRepPtr->elemCount = 2 * size; - /* - * Populate the list representation. - */ + LIST_ASSERT(listRep.spanPtr == NULL); /* Guard against future changes */ + LIST_ASSERT(listRep.storePtr->firstUsed == 0); + LIST_ASSERT((listRep.storePtr->flags & LISTSTORE_CANONICAL) == 0); + + listRep.storePtr->numUsed = 2 * size; + + /* Populate the list representation. */ - elemPtrs = &listRepPtr->elements; + elemPtrs = listRep.storePtr->slots; Tcl_DictObjFirst(NULL, objPtr, &search, &keyPtr, &valuePtr, &done); while (!done) { *elemPtrs++ = keyPtr; @@ -2042,15 +3114,18 @@ SetListFromAny( estCount = TclMaxListLength(nextElem, length, &limit); estCount += (estCount == 0); /* Smallest list struct holds 1 * element. */ - listRepPtr = AttemptNewList(interp, estCount, NULL); - if (listRepPtr == NULL) { + /* TODO - allocate additional space? */ + if (ListRepInitAttempt(interp, estCount, NULL, &listRep) + != TCL_OK) { return TCL_ERROR; } - elemPtrs = &listRepPtr->elements; - /* - * Each iteration, parse and store a list element. - */ + LIST_ASSERT(listRep.spanPtr == NULL); /* Guard against future changes */ + LIST_ASSERT(listRep.storePtr->firstUsed == 0); + + elemPtrs = listRep.storePtr->slots; + + /* Each iteration, parse and store a list element. */ while (nextElem < limit) { const char *elemStart; @@ -2059,11 +3134,11 @@ SetListFromAny( if (TCL_OK != TclFindElement(interp, nextElem, limit - nextElem, &elemStart, &nextElem, &elemSize, &literal)) { - fail: - while (--elemPtrs >= &listRepPtr->elements) { +fail: + while (--elemPtrs >= listRep.storePtr->slots) { Tcl_DecrRefCount(*elemPtrs); } - ckfree(listRepPtr); + ckfree(listRep.storePtr); return TCL_ERROR; } if (elemStart == limit) { @@ -2075,11 +3150,7 @@ SetListFromAny( check = Tcl_InitStringRep(*elemPtrs, literal ? elemStart : NULL, elemSize); if (elemSize && check == NULL) { - if (interp) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "cannot construct list, out of memory", -1)); - Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL); - } + MemoryAllocationError(interp, elemSize); goto fail; } if (!literal) { @@ -2090,16 +3161,29 @@ SetListFromAny( Tcl_IncrRefCount(*elemPtrs++);/* Since list now holds ref to it. */ } - listRepPtr->elemCount = elemPtrs - &listRepPtr->elements; + listRep.storePtr->numUsed = + elemPtrs - listRep.storePtr->slots; } + LISTREP_CHECK(&listRep); + /* * Store the new internalRep. We do this as late * as possible to allow the conversion code, in particular * Tcl_GetStringFromObj, to use the old internalRep. */ - ListSetInternalRep(objPtr, listRepPtr); + /* + * Note old string representation NOT to be invalidated. + * So do NOT use ListObjReplaceRepAndInvalidate. InternalRep to be freed AFTER + * IncrRefs so do not use ListObjOverwriteRep + */ + ListRepIncrRefs(&listRep); + TclFreeInternalRep(objPtr); + objPtr->internalRep.twoPtrValue.ptr1 = listRep.storePtr; + objPtr->internalRep.twoPtrValue.ptr2 = listRep.spanPtr; + objPtr->typePtr = &tclListType; + return TCL_OK; } @@ -2126,7 +3210,7 @@ SetListFromAny( static void UpdateStringOfList( - Tcl_Obj *listPtr) /* List object with string rep to update. */ + Tcl_Obj *listObj) /* List object with string rep to update. */ { # define LOCAL_SIZE 64 char localFlags[LOCAL_SIZE], *flagPtr = NULL; @@ -2134,45 +3218,46 @@ UpdateStringOfList( const char *elem, *start; char *dst; Tcl_Obj **elemPtrs; - List *listRepPtr; + ListRep listRep; - ListGetInternalRep(listPtr, listRepPtr); + ListObjGetRep(listObj, &listRep); + LISTREP_CHECK(&listRep); - assert(listRepPtr != NULL); - - numElems = listRepPtr->elemCount; + ListRepElements(&listRep, numElems, elemPtrs); /* * Mark the list as being canonical; although it will now have a string * rep, it is one we derived through proper "canonical" quoting and so * it's known to be free from nasties relating to [concat] and [eval]. + * However, we only do this if this is not a spanned list. Marking the + * storage canonical for a spanned list make ALL lists using the storage + * canonical which is not right. (Consider a list generated from a + * string and then this function called for a spanned list generated + * from it). On the other hand, a spanned list is always canonical + * (never generated from a string) so it does not have to be explicitly + * marked as such. The ListObjIsCanonical macro takes this into account. + * See the comments there. */ + if (listRep.spanPtr == NULL) { + LIST_ASSERT(listRep.storePtr->firstUsed == 0);/* Invariant */ + listRep.storePtr->flags |= LISTSTORE_CANONICAL; + } - listRepPtr->canonicalFlag = 1; - - /* - * Handle empty list case first, so rest of the routine is simpler. - */ + /* Handle empty list case first, so rest of the routine is simpler. */ if (numElems == 0) { - Tcl_InitStringRep(listPtr, NULL, 0); + Tcl_InitStringRep(listObj, NULL, 0); return; } - /* - * Pass 1: estimate space, gather flags. - */ + /* Pass 1: estimate space, gather flags. */ if (numElems <= LOCAL_SIZE) { flagPtr = localFlags; } else { - /* - * We know numElems <= LIST_MAX, so this is safe. - */ - + /* We know numElems <= LIST_MAX, so this is safe. */ flagPtr = (char *)ckalloc(numElems); } - elemPtrs = &listRepPtr->elements; for (i = 0; i < numElems; i++) { flagPtr[i] = (i ? TCL_DONT_QUOTE_HASH : 0); elem = TclGetStringFromObj(elemPtrs[i], &length); @@ -2190,7 +3275,7 @@ UpdateStringOfList( * Pass 2: copy into string rep buffer. */ - start = dst = Tcl_InitStringRep(listPtr, NULL, bytesNeeded); + start = dst = Tcl_InitStringRep(listObj, NULL, bytesNeeded); TclOOM(dst, bytesNeeded); for (i = 0; i < numElems; i++) { flagPtr[i] |= (i ? TCL_DONT_QUOTE_HASH : 0); @@ -2200,7 +3285,7 @@ UpdateStringOfList( } /* Set the string length to what was actually written, the safe choice */ - (void) Tcl_InitStringRep(listPtr, NULL, dst - 1 - start); + (void) Tcl_InitStringRep(listObj, NULL, dst - 1 - start); if (flagPtr != localFlags) { ckfree(flagPtr); diff --git a/generic/tclUtil.c b/generic/tclUtil.c index e9d943b..9c167c9 100644 --- a/generic/tclUtil.c +++ b/generic/tclUtil.c @@ -2029,6 +2029,7 @@ Tcl_ConcatObj( for (i = 0; i < objc; i++) { objPtr = objv[i]; if (!TclListObjIsCanonical(objPtr)) { + /* Because of above loop, only possible if empty string. Skip */ continue; } if (resPtr) { -- cgit v0.12 From 016ec0a646faef2fc968cdf8287302beaa0f70dc Mon Sep 17 00:00:00 2001 From: apnadkarni Date: Tue, 24 May 2022 17:23:43 +0000 Subject: Performance test scripts for list commands --- tests-perf/comparePerf.tcl | 371 ++++++++++++++ tests-perf/listPerf.tcl | 1225 ++++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 1596 insertions(+) create mode 100644 tests-perf/comparePerf.tcl create mode 100644 tests-perf/listPerf.tcl diff --git a/tests-perf/comparePerf.tcl b/tests-perf/comparePerf.tcl new file mode 100644 index 0000000..f35da21 --- /dev/null +++ b/tests-perf/comparePerf.tcl @@ -0,0 +1,371 @@ +#!/usr/bin/tclsh +# ------------------------------------------------------------------------ +# +# comparePerf.tcl -- +# +# Script to compare performance data from multiple runs. +# +# ------------------------------------------------------------------------ +# +# See the file "license.terms" for information on usage and redistribution +# of this file. +# +# Usage: +# tclsh comparePerf.tcl [--regexp RE] [--ratio time|rate] [--combine] [--base BASELABEL] PERFFILE ... +# +# The test data from each input file is tabulated so as to compare the results +# of test runs. If a PERFFILE does not exist, it is retried by adding the +# .perf extension. If the --regexp is specified, only test results whose +# id matches RE are examined. +# +# If the --combine option is specified, results of test sets with the same +# label are combined and averaged in the output. +# +# If the --base option is specified, the BASELABEL is used as the label to use +# the base timing. Otherwise, the label of the first data file is used. +# +# If --ratio option is "time" the ratio of test timing vs base test timing +# is shown. If "rate" (default) the inverse is shown. +# +# If --no-header is specified, the header describing test configuration is +# not output. +# +# The format of input files is as follows: +# +# Each line must begin with one of the characters below followed by a space +# followed by a string whose semantics depend on the initial character. +# E - Full path to the Tcl executable that was used to generate the file +# V - The Tcl patchlevel of the implementation +# D - A description for the test run for human consumption +# L - A label used to identify run environment. The --combine option will +# average all measuremets that have the same label. An input file without +# a label is treated as having a unique label and not combined with any other. +# P - A test measurement (see below) +# R - The number of runs made for the each test +# # - A comment, may be an arbitrary string. Usually included in performance +# data to describe the test. This is silently ignored +# +# Any lines not matching one of the above are ignored with a warning to stderr. +# +# A line beginning with the "P" marker is a test measurement. The first word +# following is a floating point number representing the test runtime. +# The remaining line (after trimming of whitespace) is the id of the test. +# Test generators are encouraged to make the id a well-defined machine-parseable +# as well human readable description of the test. The id must not appear more +# than once. An example test measurement line: +# P 2.32280 linsert in unshared L[10000] 1 elems 10000 times at 0 (var) +# Note here the iteration count is not present. +# + +namespace eval perf::compare { + # List of dictionaries, one per input file + variable PerfData +} + +proc perf::compare::warn {message} { + puts stderr "Warning: $message" +} +proc perf::compare::print {text} { + puts stdout $text +} +proc perf::compare::slurp {testrun_path} { + variable PerfData + + set runtimes [dict create] + + set path [file normalize $testrun_path] + set fd [open $path] + array set header {} + while {[gets $fd line] >= 0} { + set line [regsub -all {\s+} [string trim $line] " "] + switch -glob -- $line { + "#*" { + # Skip comments + } + "R *" - + "L *" - + "D *" - + "V *" - + "T *" - + "E *" { + set marker [lindex $line 0] + if {[info exists header($marker)]} { + warn "Ignoring $marker record (duplicate): \"$line\"" + } + set header($marker) [string range $line 2 end] + } + "P *" { + if {[scan $line "P %f %n" runtime id_start] == 2} { + set id [string range $line $id_start end] + if {[dict exists $runtimes $id]} { + warn "Ignoring duplicate test id \"$id\"" + } else { + dict set runtimes $id $runtime + } + } else { + warn "Invalid test result line format: \"$line\"" + } + } + default { + puts stderr "Warning: ignoring unrecognized line \"$line\"" + } + } + } + close $fd + + set result [dict create Input $path Runtimes $runtimes] + foreach {c k} { + L Label + V Version + E Executable + D Description + } { + if {[info exists header($c)]} { + dict set result $k $header($c) + } + } + + return $result +} + +proc perf::compare::burp {test_sets} { + variable Options + + # Print the key for each test run + set header " " + set separator " " + foreach test_set $test_sets { + set test_set_key "\[[incr test_set_num]\]" + if {! $Options(--no-header)} { + print "$test_set_key" + foreach k {Label Executable Version Input Description} { + if {[dict exists $test_set $k]} { + print "$k: [dict get $test_set $k]" + } + } + } + append header $test_set_key $separator + set separator " "; # Expand because later columns have ratio + } + set header [string trimright $header] + + if {! $Options(--no-header)} { + print "" + if {$Options(--ratio) eq "rate"} { + set ratio_description "ratio of baseline to the measurement (higher is faster)." + } else { + set ratio_description "ratio of measurement to the baseline (lower is faster)." + } + print "The first column \[1\] is the baseline measurement." + print "Subsequent columns are pairs of the additional measurement and " + print $ratio_description + print "" + } + + # Print the actual test run data + + print $header + set test_sets [lassign $test_sets base_set] + set fmt {%#10.5f} + set fmt_ratio {%-6.2f} + foreach {id base_runtime} [dict get $base_set Runtimes] { + if {[info exists Options(--regexp)]} { + if {![regexp $Options(--regexp) $id]} { + continue + } + } + if {$Options(--print-test-number)} { + set line "[format %-4s [incr counter].]" + } else { + set line "" + } + append line [format $fmt $base_runtime] + foreach test_set $test_sets { + if {[dict exists $test_set Runtimes $id]} { + set runtime [dict get $test_set Runtimes $id] + if {$Options(--ratio) eq "time"} { + if {$base_runtime != 0} { + set ratio [format $fmt_ratio [expr {$runtime/$base_runtime}]] + } else { + if {$runtime == 0} { + set ratio "NaN " + } else { + set ratio "Inf " + } + } + } else { + if {$runtime != 0} { + set ratio [format $fmt_ratio [expr {$base_runtime/$runtime}]] + } else { + if {$base_runtime == 0} { + set ratio "NaN " + } else { + set ratio "Inf " + } + } + } + append line "|" [format $fmt $runtime] "|" $ratio + } else { + append line [string repeat { } 11] + } + } + append line "|" $id + print $line + } +} + +proc perf::compare::chew {test_sets} { + variable Options + + # Combine test sets that have the same label, averaging the values + set unlabeled_sets {} + array set labeled_sets {} + + foreach test_set $test_sets { + # If there is no label, treat as independent set + if {![dict exists $test_set Label]} { + lappend unlabeled_sets $test_set + } else { + lappend labeled_sets([dict get $test_set Label]) $test_set + } + } + + foreach label [array names labeled_sets] { + set combined_set [lindex $labeled_sets($label) 0] + set runtimes [dict get $combined_set Runtimes] + foreach test_set [lrange $labeled_sets($label) 1 end] { + dict for {id timing} [dict get $test_set Runtimes] { + dict lappend runtimes $id $timing + } + } + dict for {id timings} $runtimes { + set total [tcl::mathop::+ {*}$timings] + dict set runtimes $id [expr {$total/[llength $timings]}] + } + dict set combined_set Runtimes $runtimes + set labeled_sets($label) $combined_set + } + + # Choose the "base" test set + if {![info exists Options(--base)]} { + set first_set [lindex $test_sets 0] + if {[dict exists $first_set Label]} { + # Use label of first as the base + set Options(--base) [dict get $first_set Label] + } + } + + if {[info exists Options(--base)] && $Options(--base) ne ""} { + lappend combined_sets $labeled_sets($Options(--base));# Will error if no such + unset labeled_sets($Options(--base)) + } else { + lappend combined_sets [lindex $unlabeled_sets 0] + set unlabeled_sets [lrange $unlabeled_sets 1 end] + } + foreach label [array names labeled_sets] { + lappend combined_sets $labeled_sets($label) + } + lappend combined_sets {*}$unlabeled_sets + + return $combined_sets +} + +proc perf::compare::setup {argv} { + variable Options + + array set Options { + --ratio rate + --combine 0 + --print-test-number 0 + --no-header 0 + } + while {[llength $argv]} { + set argv [lassign $argv arg] + switch -glob -- $arg { + -r - + --regexp { + if {[llength $argv] == 0} { + error "Missing value for option $arg" + } + set argv [lassign $argv val] + set Options(--regexp) $val + } + --ratio { + if {[llength $argv] == 0} { + error "Missing value for option $arg" + } + set argv [lassign $argv val] + if {$val ni {time rate}} { + error "Value for option $arg must be either \"time\" or \"rate\"" + } + set Options(--ratio) $val + } + --print-test-number - + --combine - + --no-header { + set Options($arg) 1 + } + --base { + if {[llength $argv] == 0} { + error "Missing value for option $arg" + } + set argv [lassign $argv val] + set Options($arg) $val + } + -- { + # Remaining will be passed back to the caller + break + } + --* { + error "Unknown option $arg" + } + -* { + error "Unknown option -[lindex $arg 0]" + } + default { + # Remaining will be passed back to the caller + set argv [linsert $argv 0 $arg] + break; + } + } + } + + set paths {} + foreach path $argv { + set path [file join $path]; # Convert from native else glob fails + if {[file isfile $path]} { + lappend paths $path + continue + } + if {[file isfile $path.perf]} { + lappend paths $path.perf + continue + } + lappend paths {*}[glob -nocomplain $path] + } + return $paths +} +proc perf::compare::main {} { + variable Options + + set paths [setup $::argv] + if {[llength $paths] == 0} { + error "No test data files specified." + } + set test_data [list ] + set seen [dict create] + foreach path $paths { + if {![dict exists $seen $path]} { + lappend test_data [slurp $path] + dict set seen $path "" + } + } + + if {$Options(--combine)} { + set test_data [chew $test_data] + } + + burp $test_data +} + +perf::compare::main diff --git a/tests-perf/listPerf.tcl b/tests-perf/listPerf.tcl new file mode 100644 index 0000000..1252870 --- /dev/null +++ b/tests-perf/listPerf.tcl @@ -0,0 +1,1225 @@ +#!/usr/bin/tclsh +# ------------------------------------------------------------------------ +# +# listPerf.tcl -- +# +# This file provides performance tests for list operations. +# +# ------------------------------------------------------------------------ +# +# See the file "license.terms" for information on usage and redistribution +# of this file. +# +# Note: this file does not use the test-performance.tcl framework as we want +# more direct control over timerate options. + +catch {package require twapi} + +namespace eval perf::list { + variable perfScript [file normalize [info script]] + + # Test for each of these lengths + variable Lengths {10 100 1000 10000} + + variable RunTimes + set RunTimes(command) 0.0 + set RunTimes(total) 0.0 + + variable Options + array set Options { + --print-comments 0 + --print-iterations 0 + } + + # Procs used for calibrating overhead + proc proc2args {a b} {} + proc proc3args {a b c} {} + + proc print {s} { + puts $s + } + proc print_usage {} { + puts stderr "Usage: [file tail [info nameofexecutable]] $::argv0 \[options\] \[command ...\]" + puts stderr "\t--description DESC\tHuman readable description of test run" + puts stderr "\t--label LABEL\tA label used to identify test environment" + puts stderr "\t--print-comments\tPrint comment for each test" + puts stderr "\t--print-iterations\tPrint number of iterations run for each test" + } + + proc setup {argv} { + variable Options + variable Lengths + + while {[llength $argv]} { + set argv [lassign $argv arg] + switch -glob -- $arg { + --print-comments - + --print-iterations { + set Options($arg) 1 + } + --label - + --description { + if {[llength $argv] == 0} { + error "Missing value for option $arg" + } + set argv [lassign $argv val] + set Options($arg) $val + } + --lengths { + if {[llength $argv] == 0} { + error "Missing value for option $arg" + } + set argv [lassign $argv val] + set Lengths $val + + } + -- { + # Remaining will be passed back to the caller + break + } + --* { + error "Unknown option $arg" + } + default { + # Remaining will be passed back to the caller + set argv [linsert $argv 0 $arg] + break; + } + } + } + + return $argv + } + proc format_timings {us iters} { + variable Options + if {!$Options(--print-iterations)} { + return "[format {%#10.4f} $us]" + } + return "[format {%#10.4f} $us] [format {%8d} $iters]" + } + proc measure {id script args} { + variable NullOverhead + variable RunTimes + variable Options + + set opts(-overhead) "" + set opts(-runs) 5 + while {[llength $args]} { + set args [lassign $args opt] + if {[llength $args] == 0} { + error "No argument supplied for $opt option. Test: $id" + } + set args [lassign $args val] + switch $opt { + -setup - + -cleanup - + -overhead - + -time - + -runs - + -reps { + set opts($opt) $val + } + default { + error "Unknown option $opt. Test: $id" + } + } + } + + set timerate_args {} + if {[info exists opts(-time)]} { + lappend timerate_args $opts(-time) + } + if {[info exists opts(-reps)]} { + if {[info exists opts(-time)]} { + set timerate_args [list $opts(-time) $opts(-reps)] + } else { + # Force the default for first time option + set timerate_args [list 1000 $opts(-reps)] + } + } elseif {[info exists opts(-time)]} { + set timerate_args [list $opts(-time)] + } + if {[info exists opts(-setup)]} { + uplevel 1 $opts(-setup) + } + # Cache the empty overhead to prevent unnecessary delays. Note if you modify + # to cache other scripts, the cache key must be AFTER substituting the + # overhead script in the caller's context. + if {$opts(-overhead) eq ""} { + if {![info exists NullOverhead]} { + set NullOverhead [lindex [timerate {}] 0] + } + set overhead_us $NullOverhead + } else { + # The overhead measurements might use setup so we need to setup + # first and then cleanup in preparation for setting up again for + # the script to be measured + if {[info exists opts(-setup)]} { + uplevel 1 $opts(-setup) + } + set overhead_us [lindex [uplevel 1 [list timerate $opts(-overhead)]] 0] + if {[info exists opts(-cleanup)]} { + uplevel 1 $opts(-cleanup) + } + } + set timings {} + for {set i 0} {$i < $opts(-runs)} {incr i} { + if {[info exists opts(-setup)]} { + uplevel 1 $opts(-setup) + } + lappend timings [uplevel 1 [list timerate -overhead $overhead_us $script {*}$timerate_args]] + if {[info exists opts(-cleanup)]} { + uplevel 1 $opts(-cleanup) + } + } + set timings [lsort -real -index 0 $timings] + if {$opts(-runs) > 15} { + set ignore [expr {$opts(-runs)/8}] + } elseif {$opts(-runs) >= 5} { + set ignore 2 + } else { + set ignore 0 + } + # Ignore highest and lowest + set timings [lrange $timings 0 end-$ignore] + # Average it out + set us 0 + set iters 0 + foreach timing $timings { + set us [expr {$us + [lindex $timing 0]}] + set iters [expr {$iters + [lindex $timing 2]}] + } + set us [expr {$us/[llength $timings]}] + set iters [expr {$iters/[llength $timings]}] + + set RunTimes(command) [expr {$RunTimes(command) + $us}] + print "P [format_timings $us $iters] $id" + } + proc comment {args} { + variable Options + if {$Options(--print-comments)} { + print "# [join $args { }]" + } + } + proc spanned_list {len} { + # Note - for small len, this will not create a spanned list + set delta [expr {$len/8}] + return [lrange [lrepeat [expr {$len+(2*$delta)}] a] $delta [expr {$delta+$len-1}]] + } + proc print_separator {command} { + comment [string repeat = 80] + comment Command: $command + } + + oo::class create ListPerf { + constructor {args} { + my variable Opts + # Note default Opts can be overridden in construct as well as in measure + set Opts [dict merge { + -setup { + set L [lrepeat $len a] + set Lspan [perf::list::spanned_list $len] + } -cleanup { + unset -nocomplain L + unset -nocomplain Lspan + unset -nocomplain L2 + } + } $args] + } + method measure {comment script locals args} { + my variable Opts + dict with locals {} + ::perf::list::measure $comment $script {*}[dict merge $Opts $args] + } + method option {opt val} { + my variable Opts + dict set Opts $opt $val + } + method option_unset {opt} { + my variable Opts + unset -nocomplain Opts($opt) + } + } + + proc linsert_describe {share_mode len at num iters} { + return "linsert L\[$len\] $share_mode $num elems $iters times at $at" + } + proc linsert_perf {} { + variable Lengths + + print_separator linsert + + comment == Insert into empty lists + comment Insert one element into empty list + measure [linsert_describe empty 0 "0 (const)" 1 1] {linsert {} 0 ""} + + ListPerf create perf -overhead {set L {}} -time 1000 + + # Note: Const indices take different path through bytecode than variable + # indices hence separate cases below + foreach len $Lengths { + if {$len >= 10000} { + set reps 100 + } else { + set reps [expr {100000/$len}] + } + perf option -reps $reps + foreach idx [list 0 1 [expr {$len/2}] end-1 end] { + + # Const index + comment Insert once to shared list with const index + perf measure [linsert_describe shared $len "$idx (const)" 1 1] \ + "linsert \$L $idx x" [list len $len] -overhead {} + + comment Insert multiple times to shared list with const index + perf measure [linsert_describe shared $len "$idx (const)" 1 $reps] \ + "set L \[linsert \$L $idx X\]" [list len $len] + + # Variable index + comment Insert once to shared list with variable index + perf measure [linsert_describe shared $len "$idx (var)" 1 1] \ + {linsert $L $idx x} [list len $len idx $idx] -overhead {} + + comment Insert multiple times to shared list with variable index + perf measure [linsert_describe shared $len "$idx (var)" 1 $reps] { + set L [linsert $L $idx X] + } [list len $len idx $idx] + } + + # Multiple items at a time + # Not in loop above because of desired output ordering + foreach idx [list 0 1 [expr {$len/2}] end-1 end] { + comment Insert multiple items multiple times to shared list with const index + perf measure [linsert_describe shared $len "$idx (const)" 5 $reps] \ + "set L \[linsert \$L $idx X X X X X\]" [list len $len] + + comment Insert multiple items multiple times to shared list with variable index + perf measure [linsert_describe shared $len "$idx (var)" 5 $reps] { + set L [linsert $L $idx X X X X X] + } [list len $len idx $idx] + } + + } + + # Not in loop above because of how we want order in output + + foreach len $Lengths { + if {$len > 100000} { + set reps 10 + } else { + set reps [expr {100000/$len}] + } + perf option -reps $reps + foreach idx [list 0 1 [expr {$len/2}] end-1 end] { + # NOTE : the Insert once case is left out for unshared lists + # because it requires re-init on every iteration resulting + # in a lot of measurement noise + + # Const index + comment Insert multiple times to unshared list with const index + perf measure [linsert_describe unshared $len "$idx (const)" 1 $reps] \ + "set L \[linsert \$L\[set L {}\] $idx X]" [list len $len] + + comment Insert multiple items multiple times to unshared list with const index + perf measure [linsert_describe unshared $len "$idx (const)" 5 $reps] \ + "set L \[linsert \$L\[set L {}\] $idx X X X X X]" [list len $len] + + # Variable index + + comment Insert multiple times to unshared list with variable index + perf measure [linsert_describe unshared $len "$idx (var)" 1 $reps] { + set L [linsert $L[set L {}] $idx X] + } [list len $len idx $idx] + + comment Insert multiple items multiple times to unshared list with variable index + perf measure [linsert_describe unshared $len "$idx (var)" 5 $reps] { + set L [linsert $L[set L {}] $idx X X X X X] + } [list len $len idx $idx] + + } + } + + # Note: no span tests because the inserts above will themselves create + # spanned lists + + perf destroy + } + + proc lappend_describe {share_mode len num iters} { + return "lappend L\[$len\] $share_mode $num elems $iters times" + } + proc lappend_perf {} { + variable Lengths + + print_separator lappend + + ListPerf create perf -setup {set L [lrepeat [expr {$len/4}] x]} + + # Shared + foreach len $Lengths { + comment Append to a shared list variable multiple times + perf measure [lappend_describe shared [expr {$len/2}] 1 $len] { + set L2 $L; # Make shared + lappend L x + } [list len $len] -reps $len -overhead {set L2 $L} + } + + # Unshared + foreach len $Lengths { + comment Append to a unshared list variable multiple times + perf measure [lappend_describe unshared [expr {$len/2}] 1 $len] { + lappend L x + } [list len $len] -reps $len + } + + # Span + foreach len $Lengths { + comment Append to a unshared-span list variable multiple times + perf measure [lappend_describe unshared-span [expr {$len/2}] 1 $len] { + lappend Lspan x + } [list len $len] -reps $len + } + + perf destroy + } + + proc lpop_describe {share_mode len at reps} { + return "lpop L\[$len\] $share_mode at $at $reps times" + } + proc lpop_perf {} { + variable Lengths + + print_separator lpop + + ListPerf create perf + + # Shared + perf option -overhead {set L2 $L} + foreach len $Lengths { + set reps [expr {($len >= 1000 ? ($len/2) : $len) - 2}] + foreach idx {0 1 end-1 end} { + comment Pop element at position $idx from a shared list variable + perf measure [lpop_describe shared $len $idx $reps] { + set L2 $L + lpop L $idx + } [list len $len idx $idx] -reps $reps + } + } + + # Unshared + perf option -overhead {} + foreach len $Lengths { + set reps [expr {($len >= 1000 ? ($len/2) : $len) - 2}] + foreach idx {0 1 end-1 end} { + comment Pop element at position $idx from an unshared list variable + perf measure [lpop_describe unshared $len $idx $reps] { + lpop L $idx + } [list len $len idx $idx] -reps $reps + } + } + + perf destroy + + # Nested + ListPerf create perf -setup { + set L [lrepeat $len [list a b]] + } + + # Shared, nested index + perf option -overhead {set L2 $L; set L L2} + foreach len $Lengths { + set reps [expr {($len >= 1000 ? ($len/2) : $len) - 2}] + foreach idx {0 1 end-1 end} { + perf measure [lpop_describe shared $len "{$idx 0}" $reps] { + set L2 $L + lpop L $idx 0 + set L $L2 + } [list len $len idx $idx] -reps $reps + } + } + + # TODO - Nested Unshared + # Not sure how to measure performance. When unshared there is no copy + # so deleting a nested index repeatedly is not feasible + + perf destroy + } + + proc lassign_describe {share_mode len num reps} { + return "lassign L\[$len\] $share_mode $num elems $reps times" + } + proc lassign_perf {} { + variable Lengths + + print_separator lassign + + ListPerf create perf + + foreach len $Lengths { + set reps 1000 + comment Reflexive lassign - shared + perf measure [lassign_describe shared $len 1 $reps] { + set L2 $L + set L2 [lassign $L2 v] + } [list len $len] -overhead {set L2 $L} -reps $reps + + set reps [expr {($len >= 1000 ? ($len/2) : $len) - 2}] + comment Reflexive lassign - unshared + perf measure [lassign_describe unshared $len 1 $reps] { + set L [lassign $L v] + } [list len $len] -reps $reps + + set reps 1000 + comment Reflexive lassign - shared, multiple + perf measure [lassign_describe shared $len 5 $reps] { + set L2 $L + set L2 [lassign $L2 a b c d e] + } [list len $len] -overhead {set L2 $L} -reps $reps + } + perf destroy + } + + proc lrepeat_describe {len num} { + return "lrepeat L\[$len\] $num elems at a time" + } + proc lrepeat_perf {} { + variable Lengths + + print_separator lrepeat + + ListPerf create perf -reps 100000 + foreach len $Lengths { + comment Generate a list from a single repeated element + perf measure [lrepeat_describe $len 1] { + lrepeat $len a + } [list len $len] + + comment Generate a list from multiple repeated elements + perf measure [lrepeat_describe $len 5] { + lrepeat $len a b c d e + } [list len $len] + } + + perf destroy + } + + proc lreverse_describe {share_mode len} { + return "lreverse L\[$len\] $share_mode" + } + proc lreverse_perf {} { + variable Lengths + + print_separator lreverse + + ListPerf create perf -reps 10000 + + foreach len $Lengths { + comment Reverse a shared list + perf measure [lreverse_describe shared $len] { + lreverse $L + } [list len $len] + + comment Reverse a unshared list + perf measure [lreverse_describe unshared $len] { + set L [lreverse $L[set L {}]] + } [list len $len] -overhead {set L $L; set L {}} + + if {$len >= 100} { + comment Reverse a shared-span list + perf measure [lreverse_describe shared-span $len] { + lreverse $Lspan + } [list len $len] + + comment Reverse a unshared-span list + perf measure [lreverse_describe unshared-span $len] { + set Lspan [lreverse $Lspan[set Lspan {}]] + } [list len $len] -overhead {set Lspan $Lspan; set Lspan {}} + } + } + + perf destroy + } + + proc llength_describe {share_mode len} { + return "llength L\[$len\] $share_mode" + } + proc llength_perf {} { + variable Lengths + + print_separator llength + + ListPerf create perf -reps 100000 + + foreach len $Lengths { + comment Length of a list + perf measure [llength_describe shared $len] { + llength $L + } [list len $len] + + if {$len >= 100} { + comment Length of a span list + perf measure [llength_describe shared-span $len] { + llength $Lspan + } [list len $len] + } + } + + perf destroy + } + + proc lindex_describe {share_mode len at} { + return "lindex L\[$len\] $share_mode at $at" + } + proc lindex_perf {} { + variable Lengths + + print_separator lindex + + ListPerf create perf -reps 100000 + + foreach len $Lengths { + comment Index into a list + set idx [expr {$len/2}] + perf measure [lindex_describe shared $len $idx] { + lindex $L $idx + } [list len $len idx $idx] + + if {$len >= 100} { + comment Index into a span list + perf measure [lindex_describe shared-span $len $idx] { + lindex $Lspan $idx + } [list len $len idx $idx] + } + } + + perf destroy + } + + proc lrange_describe {share_mode len range} { + return "lrange L\[$len\] $share_mode range $range" + } + + proc lrange_perf {} { + variable Lengths + + print_separator lrange + + ListPerf create perf -time 1000 -reps 100000 + + foreach share_mode {shared unshared} { + foreach len $Lengths { + set eighth [expr {$len/8}] + set ranges [list \ + [list 0 0] [list 0 end-1] \ + [list $eighth [expr {3*$eighth}]] \ + [list $eighth [expr {7*$eighth}]] \ + [list 1 end] [list end-1 end] \ + ] + foreach range $ranges { + comment Range $range in $share_mode list of length $len + if {$share_mode eq "shared"} { + perf measure [lrange_describe shared $len $range] \ + "lrange \$L $range" [list len $len range $range] + } else { + perf measure [lrange_describe unshared $len $range] \ + "lrange \[lrepeat \$len\ a] $range" \ + [list len $len range $range] -overhead {lrepeat $len a} + } + } + + if {$len >= 100} { + foreach range $ranges { + comment Range $range in ${share_mode}-span list of length $len + if {$share_mode eq "shared"} { + perf measure [lrange_describe shared-span $len $range] \ + "lrange \$Lspan {*}$range" [list len $len range $range] + } else { + perf measure [lrange_describe unshared-span $len $range] \ + "lrange \[perf::list::spanned_list \$len\] $range" \ + [list len $len range $range] -overhead {perf::list::spanned_list $len} + } + } + } + } + } + + perf destroy + } + + proc lset_describe {share_mode len at} { + return "lset L\[$len\] $share_mode at $at" + } + proc lset_perf {} { + variable Lengths + + print_separator lset + + ListPerf create perf -reps 10000 + + # Shared + foreach share_mode {shared unshared} { + foreach len $Lengths { + foreach idx {0 1 end-1 end end+1} { + comment lset at position $idx in a $share_mode list variable + if {$share_mode eq "shared"} { + perf measure [lset_describe shared $len $idx] { + set L2 $L + lset L $idx X + } [list len $len idx $idx] -overhead {set L2 $L} + } else { + perf measure [lset_describe unshared $len $idx] { + lset L $idx X + } [list len $len idx $idx] + } + } + } + } + + perf destroy + + # Nested + ListPerf create perf -setup { + set L [lrepeat $len [list a b]] + } + + foreach share_mode {shared unshared} { + foreach len $Lengths { + foreach idx {0 1 end-1 end} { + comment lset at position $idx in a $share_mode list variable + if {$share_mode eq "shared"} { + perf measure [lset_describe shared $len "{$idx 0}"] { + set L2 $L + lset L $idx 0 X + } [list len $len idx $idx] -overhead {set L2 $L} + } else { + perf measure [lset_describe unshared $len "{$idx 0}"] { + lset L $idx 0 {X Y} + } [list len $len idx $idx] + } + } + } + } + + perf destroy + } + + proc lremove_describe {share_mode len at nremoved} { + return "lremove L\[$len\] $share_mode $nremoved elements at $at" + } + proc lremove_perf {} { + variable Lengths + + print_separator lremove + + ListPerf create perf -reps 10000 + + foreach share_mode {shared unshared} { + foreach len $Lengths { + foreach idx [list 0 1 [expr {$len/2}] end-1 end] { + if {$share_mode eq "shared"} { + comment Remove one element from shared list + perf measure [lremove_describe shared $len $idx 1] \ + {lremove $L $idx} [list len $len idx $idx] + + } else { + comment Remove one element from unshared list + set reps [expr {$len >= 1000 ? ($len/8) : ($len-2)}] + perf measure [lremove_describe unshared $len $idx 1] \ + {set L [lremove $L[set L {}] $idx]} [list len $len idx $idx] \ + -overhead {set L $L; set L {}} -reps $reps + } + } + if {$share_mode eq "shared"} { + comment Remove multiple elements from shared list + perf measure [lremove_describe shared $len [list 0 1 [expr {$len/2}] end-1 end] 5] { + lremove $L 0 1 [expr {$len/2}] end-1 end + } [list len $len] + } + } + # Span + foreach len $Lengths { + foreach idx [list 0 1 [expr {$len/2}] end-1 end] { + if {$share_mode eq "shared"} { + comment Remove one element from shared-span list + perf measure [lremove_describe shared-span $len $idx 1] \ + {lremove $Lspan $idx} [list len $len idx $idx] + } else { + comment Remove one element from unshared-span list + set reps [expr {$len >= 1000 ? ($len/8) : ($len-2)}] + perf measure [lremove_describe unshared-span $len $idx 1] \ + {set Lspan [lremove $Lspan[set Lspan {}] $idx]} [list len $len idx $idx] \ + -overhead {set Lspan $Lspan; set Lspan {}} -reps $reps + } + } + if {$share_mode eq "shared"} { + comment Remove multiple elements from shared-span list + perf measure [lremove_describe shared-span $len [list 0 1 [expr {$len/2}] end-1 end] 5] { + lremove $Lspan 0 1 [expr {$len/2}] end-1 end + } [list len $len] + } + } + } + + perf destroy + } + + proc lreplace_describe {share_mode len first last ninsert {times 1}} { + if {$last < $first} { + return "lreplace L\[$len\] $share_mode 0 ($first:$last) elems at $first with $ninsert elems $times times." + } + return "lreplace L\[$len\] $share_mode $first:$last with $ninsert elems $times times." + } + proc lreplace_perf {} { + variable Lengths + + print_separator lreplace + + set default_reps 10000 + ListPerf create perf -reps $default_reps + + foreach share_mode {shared unshared} { + # Insert only + foreach len $Lengths { + set reps [expr {$len <= 100 ? ($len-2) : ($len/8)}] + foreach first [list 0 1 [expr {$len/2}] end-1 end] { + if {$share_mode eq "shared"} { + comment Insert one to shared list + perf measure [lreplace_describe shared $len $first -1 1] { + lreplace $L $first -1 x + } [list len $len first $first] + + comment Insert multiple to shared list + perf measure [lreplace_describe shared $len $first -1 10] { + lreplace $L $first -1 X X X X X X X X X X + } [list len $len first $first] + + comment Insert one to shared list repeatedly + perf measure [lreplace_describe shared $len $first -1 1 $reps] { + set L [lreplace $L $first -1 x] + } [list len $len first $first] -reps $reps + + comment Insert multiple to shared list repeatedly + perf measure [lreplace_describe shared $len $first -1 10 $reps] { + set L [lreplace $L $first -1 X X X X X X X X X X] + } [list len $len first $first] -reps $reps + + } else { + comment Insert one to unshared list + perf measure [lreplace_describe unshared $len $first -1 1] { + set L [lreplace $L[set L {}] $first -1 x] + } [list len $len first $first] -overhead { + set L $L; set L {} + } -reps $reps + + comment Insert multiple to unshared list + perf measure [lreplace_describe unshared $len $first -1 10] { + set L [lreplace $L[set L {}] $first -1 X X X X X X X X X X] + } [list len $len first $first] -overhead { + set L $L; set L {} + } -reps $reps + } + } + } + + # Delete only + foreach len $Lengths { + set reps [expr {$len <= 100 ? ($len-2) : ($len/8)}] + foreach first [list 0 1 [expr {$len/2}] end-1 end] { + if {$share_mode eq "shared"} { + comment Delete one from shared list + perf measure [lreplace_describe shared $len $first $first 0] { + lreplace $L $first $first + } [list len $len first $first] + } else { + comment Delete one from unshared list + perf measure [lreplace_describe unshared $len $first $first 0] { + set L [lreplace $L[set L {}] $first $first x] + } [list len $len first $first] -overhead { + set L $L; set L {} + } -reps $reps + } + } + } + + # Insert + delete + foreach len $Lengths { + set reps [expr {$len <= 100 ? ($len-2) : ($len/8)}] + foreach range [list {0 1} {1 2} {end-2 end-1} {end-1 end}] { + lassign $range first last + if {$share_mode eq "shared"} { + comment Insertions more than deletions from shared list + perf measure [lreplace_describe shared $len $first $last 3] { + lreplace $L $first $last X Y Z + } [list len $len first $first last $last] + + comment Insertions same as deletions from shared list + perf measure [lreplace_describe shared $len $first $last 2] { + lreplace $L $first $last X Y + } [list len $len first $first last $last] + + comment Insertions fewer than deletions from shared list + perf measure [lreplace_describe shared $len $first $last 1] { + lreplace $L $first $last X + } [list len $len first $first last $last] + } else { + comment Insertions more than deletions from unshared list + perf measure [lreplace_describe unshared $len $first $last 3] { + set L [lreplace $L[set L {}] $first $last X Y Z] + } [list len $len first $first last $last] -overhead { + set L $L; set L {} + } -reps $reps + + comment Insertions same as deletions from unshared list + perf measure [lreplace_describe unshared $len $first $last 2] { + set L [lreplace $L[set L {}] $first $last X Y ] + } [list len $len first $first last $last] -overhead { + set L $L; set L {} + } -reps $reps + + comment Insertions fewer than deletions from unshared list + perf measure [lreplace_describe unshared $len $first $last 1] { + set L [lreplace $L[set L {}] $first $last X] + } [list len $len first $first last $last] -overhead { + set L $L; set L {} + } -reps $reps + } + } + } + # Spanned Insert + delete + foreach len $Lengths { + set reps [expr {$len <= 100 ? ($len-2) : ($len/8)}] + foreach range [list {0 1} {1 2} {end-2 end-1} {end-1 end}] { + lassign $range first last + if {$share_mode eq "shared"} { + comment Insertions more than deletions from shared-span list + perf measure [lreplace_describe shared-span $len $first $last 3] { + lreplace $Lspan $first $last X Y Z + } [list len $len first $first last $last] + + comment Insertions same as deletions from shared-span list + perf measure [lreplace_describe shared-span $len $first $last 2] { + lreplace $Lspan $first $last X Y + } [list len $len first $first last $last] + + comment Insertions fewer than deletions from shared-span list + perf measure [lreplace_describe shared-span $len $first $last 1] { + lreplace $Lspan $first $last X + } [list len $len first $first last $last] + } else { + comment Insertions more than deletions from unshared-span list + perf measure [lreplace_describe unshared-span $len $first $last 3] { + set Lspan [lreplace $Lspan[set Lspan {}] $first $last X Y Z] + } [list len $len first $first last $last] -overhead { + set Lspan $Lspan; set Lspan {} + } -reps $reps + + comment Insertions same as deletions from unshared-span list + perf measure [lreplace_describe unshared-span $len $first $last 2] { + set Lspan [lreplace $Lspan[set Lspan {}] $first $last X Y ] + } [list len $len first $first last $last] -overhead { + set Lspan $Lspan; set Lspan {} + } -reps $reps + + comment Insertions fewer than deletions from unshared-span list + perf measure [lreplace_describe unshared-span $len $first $last 1] { + set Lspan [lreplace $Lspan[set Lspan {}] $first $last X] + } [list len $len first $first last $last] -overhead { + set Lspan $Lspan; set Lspan {} + } -reps $reps + } + } + } + } + + perf destroy + } + + proc join_describe {share_mode len} { + return "join L\[$len\] $share_mode" + } + proc join_perf {} { + variable Lengths + + print_separator join + + ListPerf create perf -reps 10000 + foreach len $Lengths { + comment Join a list + perf measure [join_describe shared $len] { + join $L + } [list len $len] + } + foreach len $Lengths { + comment Join a spanned list + perf measure [join_describe shared-span $len] { + join $Lspan + } [list len $len] + } + perf destroy + } + + proc lsearch_describe {share_mode len} { + return "lsearch L\[$len\] $share_mode" + } + proc lsearch_perf {} { + variable Lengths + + print_separator lsearch + + ListPerf create perf -reps 100000 + foreach len $Lengths { + comment Search a list + perf measure [lsearch_describe shared $len] { + lsearch $L needle + } [list len $len] + } + foreach len $Lengths { + comment Search a spanned list + perf measure [lsearch_describe shared-span $len] { + lsearch $Lspan needle + } [list len $len] + } + perf destroy + } + + proc foreach_describe {share_mode len} { + return "foreach L\[$len\] $share_mode" + } + proc foreach_perf {} { + variable Lengths + + print_separator foreach + + ListPerf create perf -reps 10000 + foreach len $Lengths { + comment Iterate through a list + perf measure [foreach_describe shared $len] { + foreach e $L {} + } [list len $len] + } + foreach len $Lengths { + comment Iterate a spanned list + perf measure [foreach_describe shared-span $len] { + foreach e $Lspan {} + } [list len $len] + } + perf destroy + } + + proc lmap_describe {share_mode len} { + return "lmap L\[$len\] $share_mode" + } + proc lmap_perf {} { + variable Lengths + + print_separator lmap + + ListPerf create perf -reps 10000 + foreach len $Lengths { + comment Iterate through a list + perf measure [lmap_describe shared $len] { + lmap e $L {} + } [list len $len] + } + foreach len $Lengths { + comment Iterate a spanned list + perf measure [lmap_describe shared-span $len] { + lmap e $Lspan {} + } [list len $len] + } + perf destroy + } + + proc get_sort_sample {{spanned 0}} { + variable perfScript + variable sortSampleText + + if {![info exists sortSampleText]} { + set fd [open $perfScript] + set sortSampleText [split [read $fd] ""] + close $fd + } + set sortSampleText [string range $sortSampleText 0 9999] + + # NOTE: do NOT cache list result in a variable as we need it unshared + if {$spanned} { + return [lrange [split $sortSampleText ""] 1 end-1] + } else { + return [split $sortSampleText ""] + } + } + proc lsort_describe {share_mode len} { + return "lsort L\[$len] $share_mode" + } + proc lsort_perf {} { + print_separator lsort + + ListPerf create perf -setup {} + + comment Sort a shared list + perf measure [lsort_describe shared [llength [perf::list::get_sort_sample]]] { + lsort $L + } {} -setup {set L [perf::list::get_sort_sample]} + + comment Sort an unshared list + perf measure [lsort_describe unshared [llength [perf::list::get_sort_sample]]] { + lsort [perf::list::get_sort_sample] + } {} -overhead {perf::list::get_sort_sample} + + comment Sort a shared-span list + perf measure [lsort_describe shared-span [llength [perf::list::get_sort_sample 1]]] { + lsort $L + } {} -setup {set L [perf::list::get_sort_sample 1]} + + comment Sort an unshared-span list + perf measure [lsort_describe unshared-span [llength [perf::list::get_sort_sample 1]]] { + lsort [perf::list::get_sort_sample 1] + } {} -overhead {perf::list::get_sort_sample 1} + + perf destroy + } + + proc concat_describe {canonicality len elemlen} { + return "concat L\[$len\] $canonicality with elements of length $elemlen" + } + proc concat_perf {} { + variable Lengths + + print_separator concat + + ListPerf create perf -reps 100000 + + foreach len $Lengths { + foreach elemlen {1 100} { + comment Pure lists (no string representation) + perf measure [concat_describe "pure lists" $len $elemlen] { + concat $L $L + } [list len $len elemlen $elemlen] -setup { + set L [lrepeat $len [string repeat a $elemlen]] + } + + comment Canonical lists (with string representation) + perf measure [concat_describe "canonical lists" $len $elemlen] { + concat $L $L + } [list len $len elemlen $elemlen] -setup { + set L [lrepeat $len [string repeat a $elemlen]] + append x x $L; # Generate string while keeping internal rep list + unset x + } + + comment Non-canonical lists + perf measure [concat_describe "non-canonical lists" $len $elemlen] { + concat $L $L + } [list len $len elemlen $elemlen] -setup { + set L [string repeat "[string repeat a $elemlen] " $len] + llength $L + } + } + } + + # Span version + foreach len $Lengths { + foreach elemlen {1 100} { + comment Pure span lists (no string representation) + perf measure [concat_describe "pure spanned lists" $len $elemlen] { + concat $L $L + } [list len $len elemlen $elemlen] -setup { + set L [lrange [lrepeat [expr {$len+2}] [string repeat a $elemlen]] 1 end-1] + } + + comment Canonical span lists (with string representation) + perf measure [concat_describe "canonical spanned lists" $len $elemlen] { + concat $L $L + } [list len $len elemlen $elemlen] -setup { + set L [lrange [lrepeat [expr {$len+2}] [string repeat a $elemlen]] 1 end-1] + append x x $L; # Generate string while keeping internal rep list + unset x + } + } + } + + perf destroy + } + + proc test {} { + variable RunTimes + variable Options + + set selections [perf::list::setup $::argv] + if {[llength $selections] == 0} { + set commands [info commands ::perf::list::*_perf] + } else { + set commands [lmap sel $selections { + if {$sel eq "help"} { + print_usage + continue + } + set cmd ::perf::list::${sel}_perf + if {$cmd ni [info commands ::perf::list::*_perf]} { + puts stderr "Error: command $sel is not known or supported. Skipping." + continue + } + set cmd + }] + } + comment Setting up + timerate -calibrate {} + if {[info exists Options(--label)]} { + print "L $Options(--label)" + } + print "V [info patchlevel]" + print "E [info nameofexecutable]" + if {[info exists Options(--description)]} { + print "D $Options(--description)" + } + set twapi_keys {-privatebytes -workingset -workingsetpeak} + if {[info commands ::twapi::get_process_memory_info] ne ""} { + set twapi_vm_pre [::twapi::get_process_memory_info] + } + foreach cmd [lsort -dictionary $commands] { + set RunTimes(command) 0.0 + $cmd + set RunTimes(total) [expr {$RunTimes(total)+$RunTimes(command)}] + print "P [format_timings $RunTimes(command) 1] [string range $cmd 14 end-5] total run time" + } + # Print total runtime in same format as timerate output + print "P [format_timings $RunTimes(total) 1] Total run time" + + if {[info exists twapi_vm_pre]} { + set twapi_vm_post [::twapi::get_process_memory_info] + set MB 1048576.0 + foreach key $twapi_keys { + set pre [expr {[dict get $twapi_vm_pre $key]/$MB}] + set post [expr {[dict get $twapi_vm_post $key]/$MB}] + print "P [format_timings $pre 1] Memory (MB) $key pre-test" + print "P [format_timings $post 1] Memory (MB) $key post-test" + print "P [format_timings [expr {$post-$pre}] 1] Memory (MB) delta $key" + } + } + if {[info commands memory] ne ""} { + foreach line [split [memory info] \n] { + if {$line eq ""} continue + set line [split $line] + set val [expr {[lindex $line end]/1000.0}] + set line [string trim [join [lrange $line 0 end-1]]] + print "P [format_timings $val 1] memdbg $line (in thousands)" + } + print "# Allocations not freed on exit written to the lost-memory.tmp file." + print "# These will have to be manually compared." + # env TCL_FINALIZE_ON_EXIT must be set to 1 for this. + # DO NOT SET HERE - set ::env(TCL_FINALIZE_ON_EXIT) 1 + # Must be set in environment before starting tclsh else bogus results + if {[info exists Options(--label)]} { + set dump_file list-memory-$Options(--label).memdmp + } else { + set dump_file list-memory-[pid].memdmp + } + memory onexit $dump_file + } + } +} + + +if {[info exists ::argv0] && [file tail $::argv0] eq [file tail [info script]]} { + ::perf::list::test +} -- cgit v0.12 From ef0ad83e38569d28700b3145c5593fc3562bcd6d Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 25 May 2022 08:56:35 +0000 Subject: Fix testcase utf-4.12 (which - actually - exposed this bug) --- tests/utf.test | 7 +++---- 1 file changed, 3 insertions(+), 4 deletions(-) diff --git a/tests/utf.test b/tests/utf.test index c0d64e2..60596f7 100644 --- a/tests/utf.test +++ b/tests/utf.test @@ -16,6 +16,8 @@ if {"::tcltest" ni [namespace children]} { ::tcltest::loadTestedCommands catch [list package require -exact tcl::test [info patchlevel]] +package require tcltests + 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}] @@ -191,12 +193,9 @@ test utf-4.10 {Tcl_NumUtfChars: #x00, calc len, overcomplete} {testnumutfchars t test utf-4.11 {Tcl_NumUtfChars: 3 bytes of 4-byte UTF-8 characater} {testnumutfchars testbytestring} { testnumutfchars [testbytestring \xF0\x9F\x92\xA9] end-1 } 3 -test utf-4.12.0 {Tcl_NumUtfChars: #4-byte UTF-8 character} {testnumutfchars testbytestring ucs2} { +test utf-4.12 {Tcl_NumUtfChars: #4-byte UTF-8 character} {testnumutfchars testbytestring deprecated} { testnumutfchars [testbytestring \xF0\x9F\x92\xA9] end } 2 -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} { testnumutfchars foobar[testbytestring \xF2\xC2\xA0] end } 8 -- cgit v0.12 From f544dd76f2e5c1b1b878c3d683f16f8aab7b6f9e Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 25 May 2022 10:26:59 +0000 Subject: Add testcases and fix implementation --- generic/tclCmdMZ.c | 25 +++++++++++++++---------- tests/string.test | 6 ++++++ 2 files changed, 21 insertions(+), 10 deletions(-) diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c index 8d3eda9..d57dc69 100644 --- a/generic/tclCmdMZ.c +++ b/generic/tclCmdMZ.c @@ -1451,6 +1451,7 @@ StringIsCmd( int (*chcomp)(int) = NULL; /* The UniChar comparison function. */ int i, failat = 0, result = 1, strict = 0, index, length1, length2; Tcl_Obj *objPtr, *failVarObj = NULL; + Tcl_WideInt w; static const char *const isClasses[] = { "alnum", "alpha", "ascii", "control", @@ -1592,9 +1593,17 @@ StringIsCmd( case STR_IS_INT: { void *p; int type; - if (TCL_OK == TclGetNumberFromObj(NULL, objPtr, &p, &type) - && (type == TCL_NUMBER_LONG) && (*(long *)p <= INT_MAX) && (*(long *)p >= INT_MIN)) { - break; + if (TCL_OK == TclGetNumberFromObj(NULL, objPtr, &p, &type)) { + if (type == TCL_NUMBER_LONG +#ifndef TCL_WIDE_INT_IS_LONG + || type == TCL_NUMBER_WIDE +#endif + || type == TCL_NUMBER_BIG) { + /* [string is integer] is -UINT_MAX to UINT_MAX range */ + if (TclGetIntFromObj(NULL, objPtr, &i) == TCL_OK) { + break; + } + } } } goto failedIntParse; @@ -1643,13 +1652,9 @@ StringIsCmd( failat = 0; } break; - case STR_IS_WIDE: { - void *p; - int type; - if (TCL_OK == TclGetNumberFromObj(NULL, objPtr, &p, &type) - && (type == TCL_NUMBER_WIDE)) { - break; - } + case STR_IS_WIDE: + if (TCL_OK == TclGetWideIntFromObj(NULL, objPtr, &w)) { + break; } failedIntParse: diff --git a/tests/string.test b/tests/string.test index 172b22d..ad6b126 100644 --- a/tests/string.test +++ b/tests/string.test @@ -795,6 +795,12 @@ test string-6.130.1.$noComp {string is entier, false on bad octal} { test string-6.131.$noComp {string is entier, false on bad hex} { list [run {string is entier -fail var 0X12345611234123456123456562345612345612345612345612345612345612345612345612345612345345XYZ}] $var } {0 88} +test string-6.132.$noComp {string is integer, bug [76ad7aeba3]} { + run {string is integer 18446744073709551615} +} 0 +test string-6.133.$noComp {string is integer, bug [76ad7aeba3]} { + run {string is integer -18446744073709551615} +} 0 catch {rename largest_int {}} -- cgit v0.12 From 614d534834b68a5de44f51c8c37023f815243f55 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 25 May 2022 10:57:21 +0000 Subject: Renumber two testcases (align with Tcl 8.7), and align Cywin-specific error-message) --- generic/tclStubInit.c | 4 ++-- tests/string.test | 4 ++-- 2 files changed, 4 insertions(+), 4 deletions(-) diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c index 23aba3e..82d758c 100644 --- a/generic/tclStubInit.c +++ b/generic/tclStubInit.c @@ -394,7 +394,7 @@ static int exprInt(Tcl_Interp *interp, const char *expr, int *ptr){ *ptr = (int)longValue; } else { Tcl_SetObjResult(interp, Tcl_NewStringObj( - "integer value too large to represent as non-long integer", -1)); + "integer value too large to represent", -1)); result = TCL_ERROR; } } @@ -410,7 +410,7 @@ static int exprIntObj(Tcl_Interp *interp, Tcl_Obj*expr, int *ptr){ *ptr = (int)longValue; } else { Tcl_SetObjResult(interp, Tcl_NewStringObj( - "integer value too large to represent as non-long integer", -1)); + "integer value too large to represent", -1)); result = TCL_ERROR; } } diff --git a/tests/string.test b/tests/string.test index ad6b126..f2b8bcc 100644 --- a/tests/string.test +++ b/tests/string.test @@ -795,10 +795,10 @@ test string-6.130.1.$noComp {string is entier, false on bad octal} { test string-6.131.$noComp {string is entier, false on bad hex} { list [run {string is entier -fail var 0X12345611234123456123456562345612345612345612345612345612345612345612345612345612345345XYZ}] $var } {0 88} -test string-6.132.$noComp {string is integer, bug [76ad7aeba3]} { +test string-6.139.$noComp {string is integer, bug [76ad7aeba3]} { run {string is integer 18446744073709551615} } 0 -test string-6.133.$noComp {string is integer, bug [76ad7aeba3]} { +test string-6.140.$noComp {string is integer, bug [76ad7aeba3]} { run {string is integer -18446744073709551615} } 0 -- cgit v0.12 From 1903a8c143273706a5bceb7a0e034a1e0f783bb7 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 25 May 2022 12:55:23 +0000 Subject: Simplify solution for [76ad7aeba3]: No need to call TclGetNumberFromObj() twice, since it's already done inside TclGetIntFromObj() --- generic/tclCmdMZ.c | 18 +++--------------- 1 file changed, 3 insertions(+), 15 deletions(-) diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c index d57dc69..c94abbd 100644 --- a/generic/tclCmdMZ.c +++ b/generic/tclCmdMZ.c @@ -1590,21 +1590,9 @@ StringIsCmd( case STR_IS_GRAPH: chcomp = Tcl_UniCharIsGraph; break; - case STR_IS_INT: { - void *p; - int type; - if (TCL_OK == TclGetNumberFromObj(NULL, objPtr, &p, &type)) { - if (type == TCL_NUMBER_LONG -#ifndef TCL_WIDE_INT_IS_LONG - || type == TCL_NUMBER_WIDE -#endif - || type == TCL_NUMBER_BIG) { - /* [string is integer] is -UINT_MAX to UINT_MAX range */ - if (TclGetIntFromObj(NULL, objPtr, &i) == TCL_OK) { - break; - } - } - } + case STR_IS_INT: + if (TCL_OK == TclGetIntFromObj(NULL, objPtr, &i)) { + break; } goto failedIntParse; case STR_IS_ENTIER: -- cgit v0.12 From 8852e00049c50af24808ee5d609065b76f829fe9 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 25 May 2022 15:18:31 +0000 Subject: Deprecate 2 internal typedefs: TclCmdProcType/TclObjCmdProcType. Too little benefit to keep them --- generic/tclInt.decls | 4 ++-- generic/tclInt.h | 2 ++ generic/tclIntDecls.h | 4 ++-- generic/tclProc.c | 4 ++-- 4 files changed, 8 insertions(+), 6 deletions(-) diff --git a/generic/tclInt.decls b/generic/tclInt.decls index 8cefc34..6b0bdae 100644 --- a/generic/tclInt.decls +++ b/generic/tclInt.decls @@ -150,7 +150,7 @@ declare 32 { } # Removed in 8.5: #declare 33 { -# TclCmdProcType TclGetInterpProc(void) +# Tcl_CmdProc *TclGetInterpProc(void) #} declare 34 {deprecated {Use Tcl_GetIntForIndex}} { int TclGetIntForIndex(Tcl_Interp *interp, Tcl_Obj *objPtr, @@ -175,7 +175,7 @@ declare 38 { const char **simpleNamePtr) } declare 39 { - TclObjCmdProcType TclGetObjInterpProc(void) + Tcl_ObjCmdProc *TclGetObjInterpProc(void) } declare 40 { int TclGetOpenMode(Tcl_Interp *interp, const char *str, int *seekFlagPtr) diff --git a/generic/tclInt.h b/generic/tclInt.h index 59106cd..294ff97 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -2644,8 +2644,10 @@ typedef Tcl_Channel (TclOpenFileChannelProc_)(Tcl_Interp *interp, *---------------------------------------------------------------- */ +#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9 typedef Tcl_CmdProc *TclCmdProcType; typedef Tcl_ObjCmdProc *TclObjCmdProcType; +#endif /* *---------------------------------------------------------------- diff --git a/generic/tclIntDecls.h b/generic/tclIntDecls.h index f4e657b..28b2a61 100644 --- a/generic/tclIntDecls.h +++ b/generic/tclIntDecls.h @@ -146,7 +146,7 @@ EXTERN int TclGetNamespaceForQualName(Tcl_Interp *interp, Namespace **actualCxtPtrPtr, const char **simpleNamePtr); /* 39 */ -EXTERN TclObjCmdProcType TclGetObjInterpProc(void); +EXTERN Tcl_ObjCmdProc * TclGetObjInterpProc(void); /* 40 */ EXTERN int TclGetOpenMode(Tcl_Interp *interp, const char *str, int *seekFlagPtr); @@ -703,7 +703,7 @@ typedef struct TclIntStubs { void (*reserved36)(void); int (*tclGetLoadedPackages) (Tcl_Interp *interp, const char *targetName); /* 37 */ int (*tclGetNamespaceForQualName) (Tcl_Interp *interp, const char *qualName, Namespace *cxtNsPtr, int flags, Namespace **nsPtrPtr, Namespace **altNsPtrPtr, Namespace **actualCxtPtrPtr, const char **simpleNamePtr); /* 38 */ - TclObjCmdProcType (*tclGetObjInterpProc) (void); /* 39 */ + Tcl_ObjCmdProc * (*tclGetObjInterpProc) (void); /* 39 */ int (*tclGetOpenMode) (Tcl_Interp *interp, const char *str, int *seekFlagPtr); /* 40 */ Tcl_Command (*tclGetOriginalCommand) (Tcl_Command command); /* 41 */ const char * (*tclpGetUserHome) (const char *name, Tcl_DString *bufferPtr); /* 42 */ diff --git a/generic/tclProc.c b/generic/tclProc.c index 8c65de3..f2dd98a 100644 --- a/generic/tclProc.c +++ b/generic/tclProc.c @@ -2274,10 +2274,10 @@ TclUpdateReturnInfo( *---------------------------------------------------------------------- */ -TclObjCmdProcType +Tcl_ObjCmdProc * TclGetObjInterpProc(void) { - return (TclObjCmdProcType) TclObjInterpProc; + return (Tcl_ObjCmdProc *) TclObjInterpProc; } /* -- cgit v0.12 From 3790a1ab40e5274f20e00f2c1709e7f8fec9319f Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 25 May 2022 22:26:49 +0000 Subject: See [https://github.com/tcltk/tcl/pull/14] --- .github/dependabot.yml | 6 ++++++ 1 file changed, 6 insertions(+) create mode 100644 .github/dependabot.yml diff --git a/.github/dependabot.yml b/.github/dependabot.yml new file mode 100644 index 0000000..203f3c8 --- /dev/null +++ b/.github/dependabot.yml @@ -0,0 +1,6 @@ +version: 2 +updates: +- package-ecosystem: "github-actions" + directory: "/" + schedule: + interval: "weekly" -- cgit v0.12 From fea7919329d937f72dfed48c38134d49c8dfa64b Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 26 May 2022 12:47:42 +0000 Subject: Revert part of [0381fc9b91]: testcases get-1.8 and get-1.9 are meant for longIs64bit only --- tests/get.test | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/tests/get.test b/tests/get.test index 8232a9a..079166e 100644 --- a/tests/get.test +++ b/tests/get.test @@ -20,6 +20,7 @@ catch [list package require -exact tcl::test [info patchlevel]] testConstraint testgetint [llength [info commands testgetint]] testConstraint testdoubleobj [llength [info commands testdoubleobj]] +testConstraint longIs64bit [expr {$tcl_platform(wordSize) == 8}] test get-1.1 {Tcl_GetInt procedure} testgetint { testgetint 44 { 22} @@ -42,10 +43,10 @@ test get-1.6 {Tcl_GetInt procedure} testgetint { test get-1.7 {Tcl_GetInt procedure} testgetint { list [catch {testgetint 44 18446744073709551616} msg] $msg $errorCode } {1 {integer value too large to represent} {ARITH IOVERFLOW {integer value too large to represent}}} -test get-1.8 {Tcl_GetInt procedure} testgetint { +test get-1.8 {Tcl_GetInt procedure} {testgetint longIs64bit} { testgetint 18446744073709551614 } {-2} -test get-1.9 {Tcl_GetInt procedure} testgetint { +test get-1.9 {Tcl_GetInt procedure} {testgetint longIs64bit} { testgetint +18446744073709551614 } {-2} test get-1.10 {Tcl_GetInt procedure} testgetint { -- cgit v0.12 From 0e71952f875f6b305ed4b7505a4d05afa4249dc5 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 26 May 2022 20:53:34 +0000 Subject: [https://github.com/tcltk/tcl/pull/16] --- .github/workflows/onefiledist.yml | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/.github/workflows/onefiledist.yml b/.github/workflows/onefiledist.yml index 95c6b82..05ca83c 100644 --- a/.github/workflows/onefiledist.yml +++ b/.github/workflows/onefiledist.yml @@ -34,7 +34,7 @@ jobs: tar -cf tclsh${TCL_PATCHLEVEL}_snapshot.tar tclsh${TCL_PATCHLEVEL}_snapshot working-directory: 1dist - name: Upload - uses: actions/upload-artifact@v2 + uses: actions/upload-artifact@v3 with: name: Tclsh ${{ env.TCL_PATCHLEVEL }} Linux single-file build (snapshot) path: 1dist/*.tar @@ -96,7 +96,7 @@ jobs: "contents/" working-directory: 1dist - name: Upload - uses: actions/upload-artifact@v2 + uses: actions/upload-artifact@v3 with: name: Tclsh ${{ env.TCL_PATCHLEVEL }} macOS single-file build (snapshot) path: 1dist/*.dmg @@ -140,7 +140,7 @@ jobs: cp ../win/tclsh*.exe tclsh${TCL_PATCHLEVEL}_snapshot.exe working-directory: 1dist - name: Upload - uses: actions/upload-artifact@v2 + uses: actions/upload-artifact@v3 with: name: Tclsh ${{ env.TCL_PATCHLEVEL }} Windows single-file build (snapshot) path: '1dist/*_snapshot.exe' -- cgit v0.12 From 9140182bbe121ce870cbcaa4d4a250dc0231ceb4 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 26 May 2022 21:12:11 +0000 Subject: Eliminate warnings in tclProc.c with USE_DTRACE. Try to eliminate warnings with gcc 4.8.5, which i is unhappy with macros that explicitly test (&foo) as booleans --- generic/tclDecls.h | 16 ++++++++-------- generic/tclProc.c | 8 ++++---- 2 files changed, 12 insertions(+), 12 deletions(-) diff --git a/generic/tclDecls.h b/generic/tclDecls.h index 1b8de88..d2ecd17 100644 --- a/generic/tclDecls.h +++ b/generic/tclDecls.h @@ -3916,19 +3916,19 @@ extern const TclStubs *tclStubsPtr; #undef Tcl_GetBytesFromObj #if defined(USE_TCL_STUBS) #define Tcl_GetStringFromObj(objPtr, sizePtr) \ - ((sizePtr) && (sizeof(*(sizePtr)) == sizeof(int) && sizeof(int) != sizeof(size_t)) ? \ + (((sizePtr) != NULL) && (sizeof(*(sizePtr)) == sizeof(int) && sizeof(int) != sizeof(size_t)) ? \ tclStubsPtr->tclGetStringFromObj(objPtr, (int *)(void *)(sizePtr)) : \ tclStubsPtr->tcl_GetStringFromObj(objPtr, (size_t *)(void *)(sizePtr))) #define Tcl_GetBytesFromObj(interp, objPtr, sizePtr) \ - ((sizePtr) && (sizeof(*(sizePtr)) == sizeof(int) && sizeof(int) != sizeof(size_t)) ? \ + (((sizePtr) != NULL) && (sizeof(*(sizePtr)) == sizeof(int) && sizeof(int) != sizeof(size_t)) ? \ tclStubsPtr->tclGetBytesFromObj(interp, objPtr, (int *)(void *)(sizePtr)) : \ tclStubsPtr->tcl_GetBytesFromObj(interp, objPtr, (size_t *)(void *)(sizePtr))) #define Tcl_GetByteArrayFromObj(objPtr, sizePtr) \ - ((sizePtr) && (sizeof(*(sizePtr)) == sizeof(int) && sizeof(int) != sizeof(size_t)) ? \ + (((sizePtr) != NULL) && (sizeof(*(sizePtr)) == sizeof(int) && sizeof(int) != sizeof(size_t)) ? \ tclStubsPtr->tclGetBytesFromObj(NULL, objPtr, (int *)(void *)(sizePtr)) : \ tclStubsPtr->tcl_GetBytesFromObj(NULL, objPtr, (size_t *)(void *)(sizePtr))) #define Tcl_GetUnicodeFromObj(objPtr, sizePtr) \ - ((sizePtr) && (sizeof(*(sizePtr)) == sizeof(int) && sizeof(int) != sizeof(size_t)) ? \ + (((sizePtr) != NULL) && (sizeof(*(sizePtr)) == sizeof(int) && sizeof(int) != sizeof(size_t)) ? \ tclStubsPtr->tclGetUnicodeFromObj(objPtr, (int *)(void *)(sizePtr)) : \ tclStubsPtr->tcl_GetUnicodeFromObj(objPtr, (size_t *)(void *)(sizePtr))) #define Tcl_GetIndexFromObjStruct(interp, objPtr, tablePtr, offset, msg, flags, indexPtr) \ @@ -3936,19 +3936,19 @@ extern const TclStubs *tclStubsPtr; (flags)|(int)(sizeof(*(indexPtr))<<1), (indexPtr))) #else #define Tcl_GetStringFromObj(objPtr, sizePtr) \ - ((sizePtr) && (sizeof(*(sizePtr)) == sizeof(int) && sizeof(int) != sizeof(size_t)) ? \ + (((sizePtr) != NULL) && (sizeof(*(sizePtr)) == sizeof(int) && sizeof(int) != sizeof(size_t)) ? \ (TclGetStringFromObj)(objPtr, (int *)(void *)(sizePtr)) : \ (Tcl_GetStringFromObj)(objPtr, (size_t *)(void *)(sizePtr))) #define Tcl_GetBytesFromObj(interp, objPtr, sizePtr) \ - ((sizePtr) && (sizeof(*(sizePtr)) == sizeof(int) && sizeof(int) != sizeof(size_t)) ? \ + (((sizePtr) != NULL) && (sizeof(*(sizePtr)) == sizeof(int) && sizeof(int) != sizeof(size_t)) ? \ (TclGetBytesFromObj)(interp, objPtr, (int *)(void *)(sizePtr)) : \ (Tcl_GetBytesFromObj)(interp, objPtr, (size_t *)(void *)(sizePtr))) #define Tcl_GetByteArrayFromObj(objPtr, sizePtr) \ - ((sizePtr) && (sizeof(*(sizePtr)) == sizeof(int) && sizeof(int) != sizeof(size_t)) ? \ + (((sizePtr) != NULL) && (sizeof(*(sizePtr)) == sizeof(int) && sizeof(int) != sizeof(size_t)) ? \ (TclGetBytesFromObj)(NULL, objPtr, (int *)(void *)(sizePtr)) : \ (Tcl_GetBytesFromObj)(NULL, objPtr, (size_t *)(void *)(sizePtr))) #define Tcl_GetUnicodeFromObj(objPtr, sizePtr) \ - ((sizePtr) && (sizeof(*(sizePtr)) == sizeof(int) && sizeof(int) != sizeof(size_t)) ? \ + (((sizePtr) != NULL) && (sizeof(*(sizePtr)) == sizeof(int) && sizeof(int) != sizeof(size_t)) ? \ (TclGetUnicodeFromObj)(objPtr, (int *)(void *)(sizePtr)) : \ Tcl_GetUnicodeFromObj(objPtr, (size_t *)(void *)(sizePtr))) #define Tcl_GetIndexFromObjStruct(interp, objPtr, tablePtr, offset, msg, flags, indexPtr) \ diff --git a/generic/tclProc.c b/generic/tclProc.c index 3f42be8..74323c8 100644 --- a/generic/tclProc.c +++ b/generic/tclProc.c @@ -1692,9 +1692,9 @@ TclNRInterpProcCore( #ifdef USE_DTRACE if (TCL_DTRACE_PROC_ARGS_ENABLED()) { - size_t l = iPtr->varFramePtr->isProcCallFrame & FRAME_IS_LAMBDA ? 1 : 0; + int l = iPtr->varFramePtr->isProcCallFrame & FRAME_IS_LAMBDA ? 1 : 0; const char *a[10]; - size_t i; + int i; for (i = 0 ; i < 10 ; i++) { a[i] = (l < iPtr->varFramePtr->objc ? @@ -1713,7 +1713,7 @@ TclNRInterpProcCore( TclDecrRefCount(info); } if (TCL_DTRACE_PROC_ENTRY_ENABLED()) { - size_t l = iPtr->varFramePtr->isProcCallFrame & FRAME_IS_LAMBDA ? 1 : 0; + int l = iPtr->varFramePtr->isProcCallFrame & FRAME_IS_LAMBDA ? 1 : 0; TCL_DTRACE_PROC_ENTRY(l < iPtr->varFramePtr->objc ? TclGetString(iPtr->varFramePtr->objv[l]) : NULL, @@ -1721,7 +1721,7 @@ TclNRInterpProcCore( (Tcl_Obj **)(iPtr->varFramePtr->objv + l + 1)); } if (TCL_DTRACE_PROC_ENTRY_ENABLED()) { - size_t l = iPtr->varFramePtr->isProcCallFrame & FRAME_IS_LAMBDA ? 1 : 0; + int l = iPtr->varFramePtr->isProcCallFrame & FRAME_IS_LAMBDA ? 1 : 0; TCL_DTRACE_PROC_ENTRY(l < iPtr->varFramePtr->objc ? TclGetString(iPtr->varFramePtr->objv[l]) : NULL, -- cgit v0.12 From 54f8e4453de7195ba93211ba1b84dabe59a24a39 Mon Sep 17 00:00:00 2001 From: bch Date: Thu, 26 May 2022 21:41:29 +0000 Subject: documentation spelling error --- doc/msgcat.n | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/doc/msgcat.n b/doc/msgcat.n index ac6dde7..76d275b 100644 --- a/doc/msgcat.n +++ b/doc/msgcat.n @@ -73,7 +73,7 @@ the application source code. New languages or locales may be provided by adding a new file to the message catalog. .PP -\fBmsgcat\fR distinguises packages by its namespace. +\fBmsgcat\fR distinguishes packages by its namespace. Each package has its own message catalog and configuration settings in \fBmsgcat\fR. .PP A \fIlocale\fR is a specification string describing a user language like \fBde_ch\fR for Swiss German. -- cgit v0.12 From c54b502e0d4673f4250097cdc2358cac90c56ecc Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 26 May 2022 22:31:39 +0000 Subject: [https://github.com/tcltk/tcl/pull/15] and typo --- .github/workflows/linux-build.yml | 2 +- .github/workflows/mac-build.yml | 4 ++-- .github/workflows/win-build.yml | 4 ++-- generic/tclDate.c | 2 +- generic/tclGetDate.y | 2 +- 5 files changed, 7 insertions(+), 7 deletions(-) diff --git a/.github/workflows/linux-build.yml b/.github/workflows/linux-build.yml index b94ed97..0bbfbd2 100644 --- a/.github/workflows/linux-build.yml +++ b/.github/workflows/linux-build.yml @@ -19,7 +19,7 @@ jobs: working-directory: unix steps: - name: Checkout - uses: actions/checkout@v2 + uses: actions/checkout@v3 - name: Prepare run: touch tclStubInit.c working-directory: generic diff --git a/.github/workflows/mac-build.yml b/.github/workflows/mac-build.yml index 8593989..5b0c657 100644 --- a/.github/workflows/mac-build.yml +++ b/.github/workflows/mac-build.yml @@ -11,7 +11,7 @@ jobs: working-directory: macosx steps: - name: Checkout - uses: actions/checkout@v2 + uses: actions/checkout@v3 - name: Prepare run: touch tclStubInit.c working-directory: generic @@ -37,7 +37,7 @@ jobs: working-directory: unix steps: - name: Checkout - uses: actions/checkout@v2 + uses: actions/checkout@v3 - name: Prepare run: | touch tclStubInit.c diff --git a/.github/workflows/win-build.yml b/.github/workflows/win-build.yml index 79a7e68..9a0ac98 100644 --- a/.github/workflows/win-build.yml +++ b/.github/workflows/win-build.yml @@ -19,7 +19,7 @@ jobs: # Using powershell means we need to explicitly stop on failure steps: - name: Checkout - uses: actions/checkout@v2 + uses: actions/checkout@v3 - name: Init MSVC uses: ilammy/msvc-dev-cmd@v1 - name: Build ${{ matrix.cfgopt }} @@ -58,7 +58,7 @@ jobs: # Using powershell means we need to explicitly stop on failure steps: - name: Checkout - uses: actions/checkout@v2 + uses: actions/checkout@v3 - name: Install MSYS2 and Make run: choco install msys2 make - name: Prepare diff --git a/generic/tclDate.c b/generic/tclDate.c index 8d37f3d..0971c8c 100644 --- a/generic/tclDate.c +++ b/generic/tclDate.c @@ -2749,7 +2749,7 @@ int TclClockOldscanObjCmd( ClientData clientData, /* Unused */ Tcl_Interp *interp, /* Tcl interpreter */ - int objc, /* Count of paraneters */ + int objc, /* Count of parameters */ Tcl_Obj *CONST *objv) /* Parameters */ { Tcl_Obj *result, *resultElement; diff --git a/generic/tclGetDate.y b/generic/tclGetDate.y index 551b1ed..df1b5d3 100644 --- a/generic/tclGetDate.y +++ b/generic/tclGetDate.y @@ -966,7 +966,7 @@ int TclClockOldscanObjCmd( ClientData clientData, /* Unused */ Tcl_Interp *interp, /* Tcl interpreter */ - int objc, /* Count of paraneters */ + int objc, /* Count of parameters */ Tcl_Obj *CONST *objv) /* Parameters */ { Tcl_Obj *result, *resultElement; -- cgit v0.12 From 0cdb72e2c3cb4bc204ea8b2b9af2c5315e419107 Mon Sep 17 00:00:00 2001 From: bch Date: Fri, 27 May 2022 00:21:51 +0000 Subject: msgcat documentation: reflect code --- doc/msgcat.n | 6 ++---- 1 file changed, 2 insertions(+), 4 deletions(-) diff --git a/doc/msgcat.n b/doc/msgcat.n index 76d275b..c39dc87 100644 --- a/doc/msgcat.n +++ b/doc/msgcat.n @@ -224,9 +224,7 @@ As an example, the user may prefer French or English text. This may be configure This group of commands manage the list of loaded locales for packages not setting a package locale. .PP .RS -The subcommand \fBget\fR returns the list of currently loaded locales. -.PP -The subcommand \fBpresent\fR requires the argument \fIlocale\fR and returns true, if this locale is loaded. +The subcommand \fBloaded\fR returns the list of currently loaded locales. .PP The subcommand \fBclear\fR removes all locales and their data, which are not in the current preference list. .RE @@ -235,7 +233,7 @@ The subcommand \fBclear\fR removes all locales and their data, which are not in . .VS "TIP 412" Searches the specified directory for files that match -the language specifications returned by \fB::msgcat::mcloadedlocales get\fR +the language specifications returned by \fB::msgcat::mcloadedlocales loaded\fR (or \fBmsgcat::mcpackagelocale preferences\fR if a package locale is set) (note that these are all lowercase), extended by the file extension .QW .msg . Each matching file is -- cgit v0.12 From 7b9852676d7eb98fcc7823aaa4c5fe0a49812d2b Mon Sep 17 00:00:00 2001 From: apnadkarni Date: Fri, 27 May 2022 03:50:08 +0000 Subject: Rearrange output order to make comparisons easier. --- tests-perf/listPerf.tcl | 179 ++++++++++++++++++++++++++++-------------------- 1 file changed, 104 insertions(+), 75 deletions(-) diff --git a/tests-perf/listPerf.tcl b/tests-perf/listPerf.tcl index 1252870..b8dcd49 100644 --- a/tests-perf/listPerf.tcl +++ b/tests-perf/listPerf.tcl @@ -249,93 +249,122 @@ namespace eval perf::list { print_separator linsert - comment == Insert into empty lists - comment Insert one element into empty list - measure [linsert_describe empty 0 "0 (const)" 1 1] {linsert {} 0 ""} - ListPerf create perf -overhead {set L {}} -time 1000 # Note: Const indices take different path through bytecode than variable # indices hence separate cases below - foreach len $Lengths { - if {$len >= 10000} { - set reps 100 - } else { - set reps [expr {100000/$len}] - } - perf option -reps $reps - foreach idx [list 0 1 [expr {$len/2}] end-1 end] { - - # Const index - comment Insert once to shared list with const index - perf measure [linsert_describe shared $len "$idx (const)" 1 1] \ - "linsert \$L $idx x" [list len $len] -overhead {} - - comment Insert multiple times to shared list with const index - perf measure [linsert_describe shared $len "$idx (const)" 1 $reps] \ - "set L \[linsert \$L $idx X\]" [list len $len] - - # Variable index - comment Insert once to shared list with variable index - perf measure [linsert_describe shared $len "$idx (var)" 1 1] \ - {linsert $L $idx x} [list len $len idx $idx] -overhead {} - - comment Insert multiple times to shared list with variable index - perf measure [linsert_describe shared $len "$idx (var)" 1 $reps] { - set L [linsert $L $idx X] - } [list len $len idx $idx] - } - # Multiple items at a time - # Not in loop above because of desired output ordering - foreach idx [list 0 1 [expr {$len/2}] end-1 end] { - comment Insert multiple items multiple times to shared list with const index - perf measure [linsert_describe shared $len "$idx (const)" 5 $reps] \ - "set L \[linsert \$L $idx X X X X X\]" [list len $len] - comment Insert multiple items multiple times to shared list with variable index - perf measure [linsert_describe shared $len "$idx (var)" 5 $reps] { - set L [linsert $L $idx X X X X X] - } [list len $len idx $idx] + # Var case + foreach share_mode {shared unshared} { + set idx 0 + if {$share_mode eq "shared"} { + comment == Insert into empty lists + comment Insert one element into empty list + measure [linsert_describe shared 0 "0 (var)" 1 1] {linsert $L $idx ""} -setup {set idx 0; set L {}} + } else { + comment == Insert into empty lists + comment Insert one element into empty list + measure [linsert_describe unshared 0 "0 (var)" 1 1] {linsert {} $idx ""} -setup {set idx 0} + } + foreach idx_str [list 0 1 mid end-1 end] { + foreach len $Lengths { + if {$len >= 10000} { + set reps 100 + } else { + set reps [expr {100000/$len}] + } + if {$idx_str eq "mid"} { + set idx [expr {$len/2}] + } else { + set idx $idx_str + } + # perf option -reps $reps + set reps 100 + if {$share_mode eq "shared"} { + comment Insert once to shared list with variable index + perf measure [linsert_describe shared $len "$idx (var)" 1 1] \ + {linsert $L $idx x} [list len $len idx $idx] -overhead {} -reps 10000 + + comment Insert multiple times to shared list with variable index + perf measure [linsert_describe shared $len "$idx (var)" 1 $reps] { + set L [linsert $L $idx X] + } [list len $len idx $idx] -reps $reps + + comment Insert multiple items multiple times to shared list with variable index + perf measure [linsert_describe shared $len "$idx (var)" 5 $reps] { + set L [linsert $L $idx X X X X X] + } [list len $len idx $idx] -reps $reps + } else { + # NOTE : the Insert once case is left out for unshared lists + # because it requires re-init on every iteration resulting + # in a lot of measurement noise + comment Insert multiple times to unshared list with variable index + perf measure [linsert_describe unshared $len "$idx (var)" 1 $reps] { + set L [linsert $L[set L {}] $idx X] + } [list len $len idx $idx] -reps $reps + comment Insert multiple items multiple times to unshared list with variable index + perf measure [linsert_describe unshared $len "$idx (var)" 5 $reps] { + set L [linsert $L[set L {}] $idx X X X X X] + } [list len $len idx $idx] -reps $reps + } + } } - } - # Not in loop above because of how we want order in output - - foreach len $Lengths { - if {$len > 100000} { - set reps 10 + # Const index + foreach share_mode {shared unshared} { + if {$share_mode eq "shared"} { + comment == Insert into empty lists + comment Insert one element into empty list + measure [linsert_describe shared 0 "0 (const)" 1 1] {linsert $L 0 ""} -setup {set L {}} } else { - set reps [expr {100000/$len}] + comment == Insert into empty lists + comment Insert one element into empty list + measure [linsert_describe unshared 0 "0 (const)" 1 1] {linsert {} 0 ""} } - perf option -reps $reps - foreach idx [list 0 1 [expr {$len/2}] end-1 end] { - # NOTE : the Insert once case is left out for unshared lists - # because it requires re-init on every iteration resulting - # in a lot of measurement noise - - # Const index - comment Insert multiple times to unshared list with const index - perf measure [linsert_describe unshared $len "$idx (const)" 1 $reps] \ - "set L \[linsert \$L\[set L {}\] $idx X]" [list len $len] - - comment Insert multiple items multiple times to unshared list with const index - perf measure [linsert_describe unshared $len "$idx (const)" 5 $reps] \ - "set L \[linsert \$L\[set L {}\] $idx X X X X X]" [list len $len] - - # Variable index - - comment Insert multiple times to unshared list with variable index - perf measure [linsert_describe unshared $len "$idx (var)" 1 $reps] { - set L [linsert $L[set L {}] $idx X] - } [list len $len idx $idx] + foreach idx_str [list 0 1 mid end end-1] { + foreach len $Lengths { + if {$len >= 10000} { + set reps 100 + } else { + set reps [expr {100000/$len}] + } + # Note end, end-1 explicitly calculated as otherwise they + # are not treated as const + if {$idx_str eq "mid"} { + set idx [expr {$len/2}] + } elseif {$idx_str eq "end"} { + set idx [expr {$len-1}] + } elseif {$idx_str eq "end-1"} { + set idx [expr {$len-2}] + } else { + set idx $idx_str + } + #perf option -reps $reps + set reps 100 + if {$share_mode eq "shared"} { + comment Insert once to shared list with const index + perf measure [linsert_describe shared $len "$idx (const)" 1 1] \ + "linsert \$L $idx x" [list len $len] -overhead {} -reps 10000 - comment Insert multiple items multiple times to unshared list with variable index - perf measure [linsert_describe unshared $len "$idx (var)" 5 $reps] { - set L [linsert $L[set L {}] $idx X X X X X] - } [list len $len idx $idx] + comment Insert multiple times to shared list with const index + perf measure [linsert_describe shared $len "$idx (const)" 1 $reps] \ + "set L \[linsert \$L $idx X\]" [list len $len] -reps $reps + + comment Insert multiple items multiple times to shared list with const index + perf measure [linsert_describe shared $len "$idx (const)" 5 $reps] \ + "set L \[linsert \$L $idx X X X X X\]" [list len $len] -reps $reps + } else { + comment Insert multiple times to unshared list with const index + perf measure [linsert_describe unshared $len "$idx (const)" 1 $reps] \ + "set L \[linsert \$L\[set L {}\] $idx X]" [list len $len] -reps $reps + comment Insert multiple items multiple times to unshared list with const index + perf measure [linsert_describe unshared $len "$idx (const)" 5 $reps] \ + "set L \[linsert \$L\[set L {}\] $idx X X X X X]" [list len $len] -reps $reps + } + } } } @@ -350,7 +379,7 @@ namespace eval perf::list { } proc lappend_perf {} { variable Lengths - + print_separator lappend ListPerf create perf -setup {set L [lrepeat [expr {$len/4}] x]} -- cgit v0.12 From 7592daa03ddb6f5d6b6881b06f2485f5cb07cbe5 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 27 May 2022 16:39:25 +0000 Subject: Use more Tcl_ObjCmdProc/Tcl_MethodCallProc typedefs --- generic/tclCompile.h | 16 ++----- generic/tclOOInt.h | 126 ++++++++++++++------------------------------------- 2 files changed, 38 insertions(+), 104 deletions(-) diff --git a/generic/tclCompile.h b/generic/tclCompile.h index 30b364d..ae30c19 100644 --- a/generic/tclCompile.h +++ b/generic/tclCompile.h @@ -1192,18 +1192,10 @@ MODULE_SCOPE void TclReleaseByteCode(ByteCode *codePtr); MODULE_SCOPE void TclReleaseLiteral(Tcl_Interp *interp, Tcl_Obj *objPtr); MODULE_SCOPE void TclInvalidateCmdLiteral(Tcl_Interp *interp, const char *name, Namespace *nsPtr); -MODULE_SCOPE int TclSingleOpCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -MODULE_SCOPE int TclSortingOpCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -MODULE_SCOPE int TclVariadicOpCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -MODULE_SCOPE int TclNoIdentOpCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); +MODULE_SCOPE Tcl_ObjCmdProc TclSingleOpCmd; +MODULE_SCOPE Tcl_ObjCmdProc TclSortingOpCmd; +MODULE_SCOPE Tcl_ObjCmdProc TclVariadicOpCmd; +MODULE_SCOPE Tcl_ObjCmdProc TclNoIdentOpCmd; #ifdef TCL_COMPILE_DEBUG MODULE_SCOPE void TclVerifyGlobalLiteralTable(Interp *iPtr); MODULE_SCOPE void TclVerifyLocalLiteralTable(CompileEnv *envPtr); diff --git a/generic/tclOOInt.h b/generic/tclOOInt.h index 521152e..9488271 100644 --- a/generic/tclOOInt.h +++ b/generic/tclOOInt.h @@ -65,12 +65,12 @@ typedef struct Method { * tuned in their behaviour. */ -typedef int (TclOO_PreCallProc)(ClientData clientData, Tcl_Interp *interp, +typedef int (TclOO_PreCallProc)(void *clientData, Tcl_Interp *interp, Tcl_ObjectContext context, Tcl_CallFrame *framePtr, int *isFinished); -typedef int (TclOO_PostCallProc)(ClientData clientData, Tcl_Interp *interp, +typedef int (TclOO_PostCallProc)(void *clientData, Tcl_Interp *interp, Tcl_ObjectContext context, Tcl_Namespace *namespacePtr, int result); -typedef void (TclOO_PmCDDeleteProc)(ClientData clientData); -typedef ClientData (TclOO_PmCDCloneProc)(ClientData clientData); +typedef void (TclOO_PmCDDeleteProc)(void *clientData); +typedef void *(TclOO_PmCDCloneProc)(void *clientData); /* * Procedure-like methods have the following extra information. @@ -447,98 +447,40 @@ typedef struct { */ MODULE_SCOPE int TclOOInit(Tcl_Interp *interp); -MODULE_SCOPE int TclOODefineObjCmd(ClientData clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const *objv); -MODULE_SCOPE int TclOOObjDefObjCmd(ClientData clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const *objv); -MODULE_SCOPE int TclOODefineConstructorObjCmd(ClientData clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const *objv); -MODULE_SCOPE int TclOODefineDefnNsObjCmd(ClientData clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const *objv); -MODULE_SCOPE int TclOODefineDeleteMethodObjCmd(ClientData clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const *objv); -MODULE_SCOPE int TclOODefineDestructorObjCmd(ClientData clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const *objv); -MODULE_SCOPE int TclOODefineExportObjCmd(ClientData clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const *objv); -MODULE_SCOPE int TclOODefineForwardObjCmd(ClientData clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const *objv); -MODULE_SCOPE int TclOODefineMethodObjCmd(ClientData clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const *objv); -MODULE_SCOPE int TclOODefineRenameMethodObjCmd(ClientData clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const *objv); -MODULE_SCOPE int TclOODefineUnexportObjCmd(ClientData clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const *objv); -MODULE_SCOPE int TclOODefineClassObjCmd(ClientData clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const *objv); -MODULE_SCOPE int TclOODefineSelfObjCmd(ClientData clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const *objv); -MODULE_SCOPE int TclOODefineObjSelfObjCmd(ClientData clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const *objv); -MODULE_SCOPE int TclOODefinePrivateObjCmd(ClientData clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const *objv); -MODULE_SCOPE int TclOOUnknownDefinition(ClientData clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const *objv); -MODULE_SCOPE int TclOOCopyObjectCmd(ClientData clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const *objv); -MODULE_SCOPE int TclOONextObjCmd(ClientData clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const *objv); -MODULE_SCOPE int TclOONextToObjCmd(ClientData clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const *objv); -MODULE_SCOPE int TclOOSelfObjCmd(ClientData clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const *objv); +MODULE_SCOPE Tcl_ObjCmdProc TclOODefineObjCmd; +MODULE_SCOPE Tcl_ObjCmdProc TclOOObjDefObjCmd; +MODULE_SCOPE Tcl_ObjCmdProc TclOODefineConstructorObjCmd; +MODULE_SCOPE Tcl_ObjCmdProc TclOODefineDefnNsObjCmd; +MODULE_SCOPE Tcl_ObjCmdProc TclOODefineDeleteMethodObjCmd; +MODULE_SCOPE Tcl_ObjCmdProc TclOODefineDestructorObjCmd; +MODULE_SCOPE Tcl_ObjCmdProc TclOODefineExportObjCmd; +MODULE_SCOPE Tcl_ObjCmdProc TclOODefineForwardObjCmd; +MODULE_SCOPE Tcl_ObjCmdProc TclOODefineMethodObjCmd; +MODULE_SCOPE Tcl_ObjCmdProc TclOODefineRenameMethodObjCmd; +MODULE_SCOPE Tcl_ObjCmdProc TclOODefineUnexportObjCmd; +MODULE_SCOPE Tcl_ObjCmdProc TclOODefineClassObjCmd; +MODULE_SCOPE Tcl_ObjCmdProc TclOODefineSelfObjCmd; +MODULE_SCOPE Tcl_ObjCmdProc TclOODefineObjSelfObjCmd; +MODULE_SCOPE Tcl_ObjCmdProc TclOODefinePrivateObjCmd; +MODULE_SCOPE Tcl_ObjCmdProc TclOOUnknownDefinition; +MODULE_SCOPE Tcl_ObjCmdProc TclOOCopyObjectCmd; +MODULE_SCOPE Tcl_ObjCmdProc TclOONextObjCmd; +MODULE_SCOPE Tcl_ObjCmdProc TclOONextToObjCmd; +MODULE_SCOPE Tcl_ObjCmdProc TclOOSelfObjCmd; /* * Method implementations (in tclOOBasic.c). */ -MODULE_SCOPE int TclOO_Class_Constructor(ClientData clientData, - Tcl_Interp *interp, Tcl_ObjectContext context, - int objc, Tcl_Obj *const *objv); -MODULE_SCOPE int TclOO_Class_Create(ClientData clientData, - Tcl_Interp *interp, Tcl_ObjectContext context, - int objc, Tcl_Obj *const *objv); -MODULE_SCOPE int TclOO_Class_CreateNs(ClientData clientData, - Tcl_Interp *interp, Tcl_ObjectContext context, - int objc, Tcl_Obj *const *objv); -MODULE_SCOPE int TclOO_Class_New(ClientData clientData, - Tcl_Interp *interp, Tcl_ObjectContext context, - int objc, Tcl_Obj *const *objv); -MODULE_SCOPE int TclOO_Object_Destroy(ClientData clientData, - Tcl_Interp *interp, Tcl_ObjectContext context, - int objc, Tcl_Obj *const *objv); -MODULE_SCOPE int TclOO_Object_Eval(ClientData clientData, - Tcl_Interp *interp, Tcl_ObjectContext context, - int objc, Tcl_Obj *const *objv); -MODULE_SCOPE int TclOO_Object_LinkVar(ClientData clientData, - Tcl_Interp *interp, Tcl_ObjectContext context, - int objc, Tcl_Obj *const *objv); -MODULE_SCOPE int TclOO_Object_Unknown(ClientData clientData, - Tcl_Interp *interp, Tcl_ObjectContext context, - int objc, Tcl_Obj *const *objv); -MODULE_SCOPE int TclOO_Object_VarName(ClientData clientData, - Tcl_Interp *interp, Tcl_ObjectContext context, - int objc, Tcl_Obj *const *objv); +MODULE_SCOPE Tcl_MethodCallProc TclOO_Class_Constructor; +MODULE_SCOPE Tcl_MethodCallProc TclOO_Class_Create; +MODULE_SCOPE Tcl_MethodCallProc TclOO_Class_CreateNs; +MODULE_SCOPE Tcl_MethodCallProc TclOO_Class_New; +MODULE_SCOPE Tcl_MethodCallProc TclOO_Object_Destroy; +MODULE_SCOPE Tcl_MethodCallProc TclOO_Object_Eval; +MODULE_SCOPE Tcl_MethodCallProc TclOO_Object_LinkVar; +MODULE_SCOPE Tcl_MethodCallProc TclOO_Object_Unknown; +MODULE_SCOPE Tcl_MethodCallProc TclOO_Object_VarName; /* * Private definitions, some of which perhaps ought to be exposed properly or @@ -587,7 +529,7 @@ MODULE_SCOPE int TclOOGetSortedMethodList(Object *oPtr, const char ***stringsPtr); MODULE_SCOPE int TclOOInit(Tcl_Interp *interp); MODULE_SCOPE void TclOOInitInfo(Tcl_Interp *interp); -MODULE_SCOPE int TclOOInvokeContext(ClientData clientData, +MODULE_SCOPE int TclOOInvokeContext(void *clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); MODULE_SCOPE int TclNRObjectContextInvokeNext(Tcl_Interp *interp, -- cgit v0.12 From 7d89acd1b25e5c19508234e7cf8e9eb762d24082 Mon Sep 17 00:00:00 2001 From: apnadkarni Date: Sun, 29 May 2022 11:44:27 +0000 Subject: Implement bidirection shift to distribute free space in list stores. --- generic/tclListObj.c | 113 +++++++++++++++++++++++++++++------------------- tests-perf/listPerf.tcl | 14 +----- 2 files changed, 70 insertions(+), 57 deletions(-) diff --git a/generic/tclListObj.c b/generic/tclListObj.c index 71a8190..6a30c97 100644 --- a/generic/tclListObj.c +++ b/generic/tclListObj.c @@ -89,7 +89,7 @@ static int ListRepInit(int objc, Tcl_Obj *const objv[], int flags, ListRep *); static int ListRepInitAttempt(Tcl_Interp *, int objc, Tcl_Obj *const objv[], ListRep *); static void ListRepClone(ListRep *fromRepPtr, ListRep *toRepPtr, int flags); -static void ListRepUnsharedFreeZombies(const ListRep *repPtr); +static void ListRepUnsharedFreeUnreferenced(const ListRep *repPtr); static int TclListObjGetRep(Tcl_Interp *, Tcl_Obj *listPtr, ListRep *repPtr); static void ListRepRange(ListRep *srcRepPtr, int rangeStart, int rangeEnd, int preserveSrcRep, ListRep *rangeRepPtr); @@ -299,7 +299,7 @@ ListSpanMerited( to do even a small span. */ #ifndef TCL_LIST_SPAN_MINSIZE /* May be set on build line */ -#define TCL_LIST_SPAN_MINSIZE 10 +#define TCL_LIST_SPAN_MINSIZE 101 #endif if (length < TCL_LIST_SPAN_MINSIZE) @@ -339,9 +339,9 @@ ListStoreUpSize(int numSlotsRequested) { /* *------------------------------------------------------------------------ * - * ListRepFreeZombies -- + * ListRepFreeUnreferenced -- * - * Inline wrapper for ListRepUnsharedFreeZombies that does quick checks + * Inline wrapper for ListRepUnsharedFreeUnreferenced that does quick checks * before calling it. * * IMPORTANT: this function must not be called on an internal @@ -351,15 +351,15 @@ ListStoreUpSize(int numSlotsRequested) { * None. * * Side effects: - * See comments for ListRepUnsharedFreeZombies. + * See comments for ListRepUnsharedFreeUnreferenced. * *------------------------------------------------------------------------ */ static inline void -ListRepFreeZombies(const ListRep *repPtr) +ListRepFreeUnreferenced(const ListRep *repPtr) { - if (! ListRepIsShared(repPtr)) { - ListRepUnsharedFreeZombies(repPtr); + if (! ListRepIsShared(repPtr) && repPtr->spanPtr) { + ListRepUnsharedFreeUnreferenced(repPtr); } } @@ -963,7 +963,7 @@ ListRepClone(ListRep *fromRepPtr, ListRep *toRepPtr, int flags) /* *------------------------------------------------------------------------ * - * ListRepUnsharedFreeZombies -- + * ListRepUnsharedFreeUnreferenced -- * * Frees any Tcl_Obj's from the "in-use" area of the ListStore for a * ListRep that are not actually references from any lists. @@ -981,7 +981,7 @@ ListRepClone(ListRep *fromRepPtr, ListRep *toRepPtr, int flags) *------------------------------------------------------------------------ */ -static void ListRepUnsharedFreeZombies(const ListRep *repPtr) +static void ListRepUnsharedFreeUnreferenced(const ListRep *repPtr) { int count; ListStore *storePtr; @@ -997,6 +997,7 @@ static void ListRepUnsharedFreeZombies(const ListRep *repPtr) return; } + /* Collect garbage at front */ count = spanPtr->spanStart - storePtr->firstUsed; LIST_ASSERT(count >= 0); if (count > 0) { @@ -1005,6 +1006,7 @@ static void ListRepUnsharedFreeZombies(const ListRep *repPtr) storePtr->numUsed -= count; } + /* Collect garbage at back */ count = (storePtr->firstUsed + storePtr->numUsed) - (spanPtr->spanStart + spanPtr->spanLength); LIST_ASSERT(count >= 0); @@ -1385,7 +1387,7 @@ ListRepRange( /* Take the opportunity to garbage collect */ /* TODO - we probably do not need the preserveSrcRep here unlike later */ if (!preserveSrcRep) { - ListRepFreeZombies(srcRepPtr); + ListRepFreeUnreferenced(srcRepPtr); } if (rangeStart < 0) { @@ -1445,7 +1447,7 @@ ListRepRange( * is mandated. */ if (!preserveSrcRep) { - ListRepFreeZombies(rangeRepPtr); + ListRepFreeUnreferenced(rangeRepPtr); } } else if (preserveSrcRep || ListRepIsShared(srcRepPtr)) { @@ -1467,7 +1469,7 @@ ListRepRange( */ int numAfterRangeEnd; - /* Asserts follow from call to ListRepFreeZombies earlier */ + /* Asserts follow from call to ListRepFreeUnreferenced earlier */ LIST_ASSERT(!preserveSrcRep); LIST_ASSERT(!ListRepIsShared(srcRepPtr)); LIST_ASSERT(ListRepStart(srcRepPtr) == srcRepPtr->storePtr->firstUsed); @@ -1703,7 +1705,7 @@ Tcl_ListObjAppendList( */ int numTailFree; - ListRepFreeZombies(&listRep); /* Collect garbage before checking room */ + ListRepFreeUnreferenced(&listRep); /* Collect garbage before checking room */ LIST_ASSERT(ListRepStart(&listRep) == listRep.storePtr->firstUsed); LIST_ASSERT(ListRepLength(&listRep) == listRep.storePtr->numUsed); @@ -2055,7 +2057,7 @@ Tcl_ListObjReplace( } /* Garbage collect before checking the pure insert optimization */ - ListRepFreeZombies(&listRep); + ListRepFreeUnreferenced(&listRep); /* * Check Case (2) - pure inserts under certain conditions: @@ -2187,7 +2189,7 @@ Tcl_ListObjReplace( * TODO - what about appends to unshared ? Is below sufficiently optimal? */ - /* Following must hold for unshared listreps after ListRepFreeZombies above */ + /* Following must hold for unshared listreps after ListRepFreeUnreferenced above */ LIST_ASSERT(origListLen == listRep.storePtr->numUsed); LIST_ASSERT(origListLen == ListRepLength(&listRep)); LIST_ASSERT(ListRepStart(&listRep) == listRep.storePtr->firstUsed); @@ -2241,11 +2243,13 @@ Tcl_ListObjReplace( } } else { + LIST_ASSERT(lenChange > 0); /* Reminder */ + /* - * lenChange > 0 as numToDelete < numToInsert. We need to make room - * for the insertions. Again we have multiple possibilities. We may - * be able to get by just shifting one segment or need to shift - * both. In the former case, favor shifting the smaller segment. + * We need to make room for the insertions. Again we have multiple + * possibilities. We may be able to get by just shifting one segment + * or need to shift both. In the former case, favor shifting the + * smaller segment. */ int leadSpace = ListRepNumFreeHead(&listRep); int tailSpace = ListRepNumFreeTail(&listRep); @@ -2258,32 +2262,35 @@ Tcl_ListObjReplace( leadShift = -lenChange; tailShift = 0; /* - * Note: we do not need the equivalent of the redistribution of - * free space as below since pure appending is handled earlier - * in this function. + * Redistribute the remaining free space between the front and + * back if either there is no tail space left or if the + * entire list is the head anyways. This is an important + * optimization for further operations like further asymmetric + * insertions. */ + if (finalFreeSpace > 1 && (tailSpace == 0 || tailSegmentLen == 0)) { + int postShiftLeadSpace = leadSpace - lenChange; + if (postShiftLeadSpace > (finalFreeSpace/2)) { + int extraShift = postShiftLeadSpace - (finalFreeSpace / 2); + leadShift -= extraShift; + tailShift = -extraShift; /* Move tail to the front as well */ + } + } + LIST_ASSERT(leadShift >= 0 || leadSpace >= -leadShift); } else if (tailSpace >= lenChange) { /* Move only tail segment to the back to make more room. */ leadShift = 0; tailShift = lenChange; /* - * Redistribute the remaining free space between the front and - * back but only if there is no leading segment since we do not - * want to unnecessarily move two segments instead of one. This - * is an important optimization for continuous prepending. + * See comments above. This is analogous. */ - if (leadSegmentLen == 0) { - int postShiftTailSpace = tailSpace - tailShift; + if (finalFreeSpace > 1 && (leadSpace == 0 || leadSegmentLen == 0)) { + int postShiftTailSpace = tailSpace - lenChange; if (postShiftTailSpace > (finalFreeSpace/2)) { int extraShift = postShiftTailSpace - (finalFreeSpace / 2); tailShift += extraShift; - /* - * Though leadSegmentLen is 0, we will need to update the - * start of used area fields. So update leadShift as well - */ - leadShift = extraShift; /* Yes, even though leadSegment - is 0 len, need to update h */ + leadShift = extraShift; /* Move head to the back as well */ } } LIST_ASSERT(tailShift <= tailSpace); @@ -2321,16 +2328,32 @@ Tcl_ListObjReplace( } } - if (leadShift != 0 && leadSegmentLen != 0) { - memmove(&listObjs[leadShift], - &listObjs[0], - leadSegmentLen * sizeof(Tcl_Obj *)); - } - if (tailShift != 0 && tailSegmentLen != 0) { - int tailStart = leadSegmentLen + numToDelete; - memmove(&listObjs[tailStart + tailShift], - &listObjs[tailStart], - tailSegmentLen * sizeof(Tcl_Obj *)); + /* Careful about order of moves! */ + if (leadShift > 0) { + /* Will happen when we have to make room at bottom */ + if (tailShift != 0 && tailSegmentLen != 0) { + int tailStart = leadSegmentLen + numToDelete; + memmove(&listObjs[tailStart + tailShift], + &listObjs[tailStart], + tailSegmentLen * sizeof(Tcl_Obj *)); + } + if (leadSegmentLen != 0) { + memmove(&listObjs[leadShift], + &listObjs[0], + leadSegmentLen * sizeof(Tcl_Obj *)); + } + } else { + if (leadShift != 0 && leadSegmentLen != 0) { + memmove(&listObjs[leadShift], + &listObjs[0], + leadSegmentLen * sizeof(Tcl_Obj *)); + } + if (tailShift != 0 && tailSegmentLen != 0) { + int tailStart = leadSegmentLen + numToDelete; + memmove(&listObjs[tailStart + tailShift], + &listObjs[tailStart], + tailSegmentLen * sizeof(Tcl_Obj *)); + } } if (numToInsert) { /* Do NOT use ObjArrayCopy here since we have already incr'ed ref counts */ diff --git a/tests-perf/listPerf.tcl b/tests-perf/listPerf.tcl index b8dcd49..3cd17f9 100644 --- a/tests-perf/listPerf.tcl +++ b/tests-perf/listPerf.tcl @@ -269,22 +269,17 @@ namespace eval perf::list { } foreach idx_str [list 0 1 mid end-1 end] { foreach len $Lengths { - if {$len >= 10000} { - set reps 100 - } else { - set reps [expr {100000/$len}] - } if {$idx_str eq "mid"} { set idx [expr {$len/2}] } else { set idx $idx_str } # perf option -reps $reps - set reps 100 + set reps 1000 if {$share_mode eq "shared"} { comment Insert once to shared list with variable index perf measure [linsert_describe shared $len "$idx (var)" 1 1] \ - {linsert $L $idx x} [list len $len idx $idx] -overhead {} -reps 10000 + {linsert $L $idx x} [list len $len idx $idx] -overhead {} -reps 100000 comment Insert multiple times to shared list with variable index perf measure [linsert_describe shared $len "$idx (var)" 1 $reps] { @@ -325,11 +320,6 @@ namespace eval perf::list { } foreach idx_str [list 0 1 mid end end-1] { foreach len $Lengths { - if {$len >= 10000} { - set reps 100 - } else { - set reps [expr {100000/$len}] - } # Note end, end-1 explicitly calculated as otherwise they # are not treated as const if {$idx_str eq "mid"} { -- cgit v0.12 From f59ed66aa0377383e55af5a7a55adde90f5220b1 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Sun, 29 May 2022 21:02:30 +0000 Subject: Function prototypes are not always needed/useful --- generic/tclCkalloc.c | 17 ----------------- unix/dltest/pkga.c | 9 --------- unix/dltest/pkgb.c | 11 ----------- unix/dltest/pkgc.c | 9 --------- unix/dltest/pkgd.c | 9 --------- unix/dltest/pkgua.c | 10 ---------- 6 files changed, 65 deletions(-) diff --git a/generic/tclCkalloc.c b/generic/tclCkalloc.c index 18a6400..0ad2c46 100644 --- a/generic/tclCkalloc.c +++ b/generic/tclCkalloc.c @@ -128,19 +128,6 @@ static Tcl_Mutex *ckallocMutexPtr; static int ckallocInit = 0; /* - * Prototypes for procedures defined in this file: - */ - -static int CheckmemCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -static int MemoryCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -static void ValidateMemory(struct mem_header *memHeaderP, - const char *file, int line, int nukeGuards); - -/* *---------------------------------------------------------------------- * * TclInitDbCkalloc -- @@ -980,10 +967,6 @@ MemoryCmd( * *---------------------------------------------------------------------- */ -static int CheckmemCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); - static int CheckmemCmd( TCL_UNUSED(void *), diff --git a/unix/dltest/pkga.c b/unix/dltest/pkga.c index e00f996..37782ea 100644 --- a/unix/dltest/pkga.c +++ b/unix/dltest/pkga.c @@ -14,15 +14,6 @@ #include "tcl.h" /* - * Prototypes for procedures defined later in this file: - */ - -static int Pkga_EqObjCmd(ClientData clientData, - Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); -static int Pkga_QuoteObjCmd(ClientData clientData, - Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); - -/* *---------------------------------------------------------------------- * * Pkga_EqObjCmd -- diff --git a/unix/dltest/pkgb.c b/unix/dltest/pkgb.c index ebed46d..d28036f 100644 --- a/unix/dltest/pkgb.c +++ b/unix/dltest/pkgb.c @@ -15,17 +15,6 @@ #include "tcl.h" /* - * Prototypes for procedures defined later in this file: - */ - -static int Pkgb_SubObjCmd(ClientData clientData, - Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); -static int Pkgb_UnsafeObjCmd(ClientData clientData, - Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); -static int Pkgb_DemoObjCmd(ClientData clientData, - Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); - -/* *---------------------------------------------------------------------- * * Pkgb_SubObjCmd -- diff --git a/unix/dltest/pkgc.c b/unix/dltest/pkgc.c index 2b46986..cd92cf7 100644 --- a/unix/dltest/pkgc.c +++ b/unix/dltest/pkgc.c @@ -15,15 +15,6 @@ #include "tcl.h" /* - * Prototypes for procedures defined later in this file: - */ - -static int Pkgc_SubObjCmd(ClientData clientData, - Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); -static int Pkgc_UnsafeObjCmd(ClientData clientData, - Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); - -/* *---------------------------------------------------------------------- * * Pkgc_SubObjCmd -- diff --git a/unix/dltest/pkgd.c b/unix/dltest/pkgd.c index ef0035f..0c98ec4 100644 --- a/unix/dltest/pkgd.c +++ b/unix/dltest/pkgd.c @@ -15,15 +15,6 @@ #include "tcl.h" /* - * Prototypes for procedures defined later in this file: - */ - -static int Pkgd_SubObjCmd(ClientData clientData, - Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); -static int Pkgd_UnsafeObjCmd(ClientData clientData, - Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); - -/* *---------------------------------------------------------------------- * * Pkgd_SubObjCmd -- diff --git a/unix/dltest/pkgua.c b/unix/dltest/pkgua.c index a822541..6d64352 100644 --- a/unix/dltest/pkgua.c +++ b/unix/dltest/pkgua.c @@ -14,16 +14,6 @@ #include "tcl.h" /* - * Prototypes for procedures defined later in this file: - */ - -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 * the command tokens created by Tcl_CreateObjCommand in an interpreter, * indexed by the interpreter. In this way, we can find which command tokens -- cgit v0.12 From ae851f4fe02fafc4950f954c24cd8cba649eeebe Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 31 May 2022 10:32:48 +0000 Subject: Tcl_SetCommandTokenInfo() does not exist --- doc/CrtTrace.3 | 6 +----- generic/tclTrace.c | 4 ---- 2 files changed, 1 insertion(+), 9 deletions(-) diff --git a/doc/CrtTrace.3 b/doc/CrtTrace.3 index b1e6483..f1f1d30 100644 --- a/doc/CrtTrace.3 +++ b/doc/CrtTrace.3 @@ -99,11 +99,7 @@ the Tcl interpreter will invoke the command. Any other return code is treated as if the command returned that status, and the command is \fInot\fR invoked. .PP -The \fIobjProc\fR callback must not modify \fIobjv\fR in any way. It -is, however, permissible to change the command by calling -\fBTcl_SetCommandTokenInfo\fR prior to returning. Any such change -takes effect immediately, and the command is invoked with the new -information. +The \fIobjProc\fR callback must not modify \fIobjv\fR in any way. .PP Tracing will only occur for commands at nesting level less than or equal to the \fIlevel\fR parameter (i.e. the \fIlevel\fR diff --git a/generic/tclTrace.c b/generic/tclTrace.c index 0ed57c1..87fe063 100644 --- a/generic/tclTrace.c +++ b/generic/tclTrace.c @@ -2105,10 +2105,6 @@ TraceVarProc( * 'objc' and 'objv' parameters give the parameter vector that will be * passed to the command procedure. Proc does not return a value. * - * It is permissible for 'proc' to call Tcl_SetCommandTokenInfo to change - * the command procedure or client data for the command being evaluated, - * and these changes will take effect with the current evaluation. - * * The 'level' argument specifies the maximum nesting level of calls to * be traced. If the execution depth of the interpreter exceeds 'level', * the trace callback is not executed. -- cgit v0.12 From 830603d46e380fe12ee4792eab9706cd995f5c21 Mon Sep 17 00:00:00 2001 From: apnadkarni Date: Wed, 1 Jun 2022 04:17:50 +0000 Subject: Finish list performance scripts --- tests-perf/listPerf.tcl | 138 ++++++++++++++++++++++++++++++++---------------- 1 file changed, 92 insertions(+), 46 deletions(-) diff --git a/tests-perf/listPerf.tcl b/tests-perf/listPerf.tcl index 3cd17f9..4472810 100644 --- a/tests-perf/listPerf.tcl +++ b/tests-perf/listPerf.tcl @@ -71,7 +71,6 @@ namespace eval perf::list { } set argv [lassign $argv val] set Lengths $val - } -- { # Remaining will be passed back to the caller @@ -364,6 +363,28 @@ namespace eval perf::list { perf destroy } + proc list_describe {len text} { + return "list L\[$len\] $text" + } + proc list_perf {} { + variable Lengths + + print_separator list + + ListPerf create perf + foreach len $Lengths { + set s [join [lrepeat $len x]] + comment Create a list from a string + perf measure [list_describe $len "from a string"] {list $s} [list s $s len $len] + } + foreach len $Lengths { + comment Create a list from expansion - single list (special optimal case) + perf measure [list_describe $len "from a {*}list"] {list {*}$L} [list len $len] + comment Create a list from two lists - real test of expansion speed + perf measure [list_describe $len "from a {*}list {*}list"] {list {*}$L {*}$L} [list len [expr {$len/2}]] + } + } + proc lappend_describe {share_mode len num iters} { return "lappend L\[$len\] $share_mode $num elems $iters times" } @@ -474,26 +495,29 @@ namespace eval perf::list { ListPerf create perf - foreach len $Lengths { - set reps 1000 - comment Reflexive lassign - shared - perf measure [lassign_describe shared $len 1 $reps] { - set L2 $L - set L2 [lassign $L2 v] - } [list len $len] -overhead {set L2 $L} -reps $reps - - set reps [expr {($len >= 1000 ? ($len/2) : $len) - 2}] - comment Reflexive lassign - unshared - perf measure [lassign_describe unshared $len 1 $reps] { - set L [lassign $L v] - } [list len $len] -reps $reps - - set reps 1000 - comment Reflexive lassign - shared, multiple - perf measure [lassign_describe shared $len 5 $reps] { - set L2 $L - set L2 [lassign $L2 a b c d e] - } [list len $len] -overhead {set L2 $L} -reps $reps + foreach share_mode {shared unshared} { + foreach len $Lengths { + if {$share_mode eq "shared"} { + set reps 1000 + comment Reflexive lassign - shared + perf measure [lassign_describe shared $len 1 $reps] { + set L2 $L + set L2 [lassign $L2 v] + } [list len $len] -overhead {set L2 $L} -reps $reps + + comment Reflexive lassign - shared, multiple + perf measure [lassign_describe shared $len 5 $reps] { + set L2 $L + set L2 [lassign $L2 a b c d e] + } [list len $len] -overhead {set L2 $L} -reps $reps + } else { + set reps [expr {($len >= 1000 ? ($len/2) : $len) - 2}] + comment Reflexive lassign - unshared + perf measure [lassign_describe unshared $len 1 $reps] { + set L [lassign $L v] + } [list len $len] -reps $reps + } + } } perf destroy } @@ -532,27 +556,33 @@ namespace eval perf::list { ListPerf create perf -reps 10000 - foreach len $Lengths { - comment Reverse a shared list - perf measure [lreverse_describe shared $len] { - lreverse $L - } [list len $len] - - comment Reverse a unshared list - perf measure [lreverse_describe unshared $len] { - set L [lreverse $L[set L {}]] - } [list len $len] -overhead {set L $L; set L {}} - - if {$len >= 100} { - comment Reverse a shared-span list - perf measure [lreverse_describe shared-span $len] { - lreverse $Lspan - } [list len $len] + foreach share_mode {shared unshared} { + foreach len $Lengths { + if {$share_mode eq "shared"} { + comment Reverse a shared list + perf measure [lreverse_describe shared $len] { + lreverse $L + } [list len $len] - comment Reverse a unshared-span list - perf measure [lreverse_describe unshared-span $len] { - set Lspan [lreverse $Lspan[set Lspan {}]] - } [list len $len] -overhead {set Lspan $Lspan; set Lspan {}} + if {$len > 100} { + comment Reverse a shared-span list + perf measure [lreverse_describe shared-span $len] { + lreverse $Lspan + } [list len $len] + } + } else { + comment Reverse a unshared list + perf measure [lreverse_describe unshared $len] { + set L [lreverse $L[set L {}]] + } [list len $len] -overhead {set L $L; set L {}} + + if {$len >= 100} { + comment Reverse a unshared-span list + perf measure [lreverse_describe unshared-span $len] { + set Lspan [lreverse $Lspan[set Lspan {}]] + } [list len $len] -overhead {set Lspan $Lspan; set Lspan {}} + } + } } } @@ -953,6 +983,22 @@ namespace eval perf::list { perf destroy } + proc split_describe {len} { + return "split L\[$len\]" + } + proc split_perf {} { + variable Lengths + print_separator split + + ListPerf create perf -setup {set S [string repeat "x " $len]} + foreach len $Lengths { + comment Split a string + perf measure [split_describe $len] { + split $S " " + } [list len $len] + } + } + proc join_describe {share_mode len} { return "join L\[$len\] $share_mode" } @@ -1080,16 +1126,16 @@ namespace eval perf::list { lsort $L } {} -setup {set L [perf::list::get_sort_sample]} - comment Sort an unshared list - perf measure [lsort_describe unshared [llength [perf::list::get_sort_sample]]] { - lsort [perf::list::get_sort_sample] - } {} -overhead {perf::list::get_sort_sample} - comment Sort a shared-span list perf measure [lsort_describe shared-span [llength [perf::list::get_sort_sample 1]]] { lsort $L } {} -setup {set L [perf::list::get_sort_sample 1]} + comment Sort an unshared list + perf measure [lsort_describe unshared [llength [perf::list::get_sort_sample]]] { + lsort [perf::list::get_sort_sample] + } {} -overhead {perf::list::get_sort_sample} + comment Sort an unshared-span list perf measure [lsort_describe unshared-span [llength [perf::list::get_sort_sample 1]]] { lsort [perf::list::get_sort_sample 1] -- cgit v0.12 From cacfaf16ecf05b44bacecbba3b2f673bf810e64c Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 1 Jun 2022 19:34:43 +0000 Subject: TIP #627 implementation --- doc/CrtObjCmd.3 | 19 ++- doc/CrtTrace.3 | 10 +- doc/NRE.3 | 11 ++ generic/tcl.decls | 17 +++ generic/tcl.h | 12 ++ generic/tclBasic.c | 142 +++++++++++++++++++++- generic/tclDecls.h | 33 ++++++ generic/tclStubInit.c | 6 + generic/tclTest.c | 320 ++++++++++++++++++++++++++------------------------ generic/tclTestObj.c | 55 ++++----- generic/tclTrace.c | 44 +++++++ 11 files changed, 484 insertions(+), 185 deletions(-) diff --git a/doc/CrtObjCmd.3 b/doc/CrtObjCmd.3 index 8d10418..57834da 100644 --- a/doc/CrtObjCmd.3 +++ b/doc/CrtObjCmd.3 @@ -8,7 +8,7 @@ .so man.macros .BS .SH NAME -Tcl_CreateObjCommand, Tcl_DeleteCommand, Tcl_DeleteCommandFromToken, Tcl_GetCommandInfo, Tcl_GetCommandInfoFromToken, Tcl_SetCommandInfo, Tcl_SetCommandInfoFromToken, Tcl_GetCommandName, Tcl_GetCommandFullName, Tcl_GetCommandFromObj \- implement new commands in C +Tcl_CreateObjCommand, Tcl_CreateObjCommand2, Tcl_DeleteCommand, Tcl_DeleteCommandFromToken, Tcl_GetCommandInfo, Tcl_GetCommandInfoFromToken, Tcl_SetCommandInfo, Tcl_SetCommandInfoFromToken, Tcl_GetCommandName, Tcl_GetCommandFullName, Tcl_GetCommandFromObj \- implement new commands in C .SH SYNOPSIS .nf \fB#include \fR @@ -16,6 +16,9 @@ Tcl_CreateObjCommand, Tcl_DeleteCommand, Tcl_DeleteCommandFromToken, Tcl_GetComm Tcl_Command \fBTcl_CreateObjCommand\fR(\fIinterp, cmdName, proc, clientData, deleteProc\fR) .sp +Tcl_Command +\fBTcl_CreateObjCommand2\fR(\fIinterp, cmdName, proc2, clientData, deleteProc\fR) +.sp int \fBTcl_DeleteCommand\fR(\fIinterp, cmdName\fR) .sp @@ -52,6 +55,9 @@ Name of command. .AP Tcl_ObjCmdProc *proc in Implementation of the new command: \fIproc\fR will be called whenever \fIcmdName\fR is invoked as a command. +.AP Tcl_ObjCmdProc2 *proc2 in +Implementation of the new command: \fIproc2\fR will be called whenever +\fIcmdName\fR is invoked as a command. .AP ClientData clientData in Arbitrary one-word value to pass to \fIproc\fR and \fIdeleteProc\fR. .AP Tcl_CmdDeleteProc *deleteProc in @@ -174,6 +180,17 @@ typedef void \fBTcl_CmdDeleteProc\fR( The \fIclientData\fR argument will be the same as the \fIclientData\fR argument passed to \fBTcl_CreateObjCommand\fR. .PP +\fBTcl_CreateObjCommand2\fR does the same as \fBTcl_CreateObjCommand2\fR, +except its \fIproc2\fR argument is of type \fBTcl_ObjCmdProc2\fR(. +.PP +.CS +typedef int \fBTcl_ObjCmdProc2\fR( + ClientData \fIclientData\fR, + Tcl_Interp *\fIinterp\fR, + size_t \fIobjc\fR, + Tcl_Obj *const \fIobjv\fR[]); +.CE +.PP \fBTcl_DeleteCommand\fR deletes a command from a command interpreter. Once the call completes, attempts to invoke \fIcmdName\fR in \fIinterp\fR will result in errors. diff --git a/doc/CrtTrace.3 b/doc/CrtTrace.3 index 620c081..417c892 100644 --- a/doc/CrtTrace.3 +++ b/doc/CrtTrace.3 @@ -10,7 +10,7 @@ .so man.macros .BS .SH NAME -Tcl_CreateTrace, Tcl_CreateObjTrace, Tcl_DeleteTrace \- arrange for command execution to be traced +Tcl_CreateTrace, Tcl_CreateObjTrace, Tcl_CreateObjTrace2, Tcl_DeleteTrace \- arrange for command execution to be traced .SH SYNOPSIS .nf \fB#include \fR @@ -21,6 +21,9 @@ Tcl_Trace Tcl_Trace \fBTcl_CreateObjTrace\fR(\fIinterp, level, flags, objProc, clientData, deleteProc\fR) .sp +Tcl_Trace +\fBTcl_CreateObjTrace2\fR(\fIinterp, level, flags, objProc2, clientData, deleteProc\fR) +.sp \fBTcl_DeleteTrace\fR(\fIinterp, trace\fR) .SH ARGUMENTS .AS Tcl_CmdObjTraceDeleteProc *deleteProc @@ -38,11 +41,14 @@ Flags governing the trace execution. See below for details. .AP Tcl_CmdObjTraceProc *objProc in Procedure to call for each command that is executed. See below for details of the calling sequence. +.AP Tcl_CmdObjTraceProc2 *objProc2 in +Procedure to call for each command that is executed. See below for +details of the calling sequence. .AP Tcl_CmdTraceProc *proc in Procedure to call for each command that is executed. See below for details on the calling sequence. .AP ClientData clientData in -Arbitrary one-word value to pass to \fIobjProc\fR or \fIproc\fR. +Arbitrary one-word value to pass to \fIobjProc\fR, \fIobjProc2\fR or \fIproc\fR. .AP Tcl_CmdObjTraceDeleteProc *deleteProc in Procedure to call when the trace is deleted. See below for details of the calling sequence. A NULL pointer is permissible and results in no diff --git a/doc/NRE.3 b/doc/NRE.3 index 72bb370..f3e0735 100644 --- a/doc/NRE.3 +++ b/doc/NRE.3 @@ -18,6 +18,10 @@ Tcl_Command \fBTcl_NRCreateCommand\fR(\fIinterp, cmdName, proc, nreProc, clientData, deleteProc\fR) .sp +Tcl_Command +\fBTcl_NRCreateCommand2\fR(\fIinterp, cmdName, proc2, nreProc2, clientData, + deleteProc\fR) +.sp int \fBTcl_NRCallObjProc\fR(\fIinterp, nreProc, clientData, objc, objv\fR) .sp @@ -47,8 +51,12 @@ Called in order to evaluate a command. Is often just a small wrapper that uses \fBTcl_NRCallObjProc\fR to call \fInreProc\fR using a new trampoline. Behaves in the same way as the \fIproc\fR argument to \fBTcl_CreateObjCommand\fR(3) (\fIq.v.\fR). +.AP Tcl_ObjCmdProc2 *proc2 in +Same as \fIproc\fR, but handles more arguments. .AP Tcl_ObjCmdProc *nreProc in Called instead of \fIproc\fR when a trampoline is already in use. +.AP Tcl_ObjCmdProc2 *nreProc2 in +Called instead of \fIproc2\fR when a trampoline is already in use. .AP ClientData clientData in Arbitrary one-word value passed to \fIproc\fR, \fInreProc\fR, \fIdeleteProc\fR and \fIobjProc\fR. @@ -104,6 +112,9 @@ first deleted. If \fIinterp\fR is in the process of being deleted \fBTcl_NRCreateCommand\fR does not create any command, does not delete any command, and returns NULL. .PP +\fBTcl_NRCreateCommand2\fR, is an alternative to \fBTcl_CreateObjCommand2\fR +in the same way as fBTcl_NRCreateCommand\fR. +.PP \fBTcl_NREvalObj\fR pushes a function that is like \fBTcl_EvalObjEx\fR but consumes no space on the C stack. .PP diff --git a/generic/tcl.decls b/generic/tcl.decls index 309eeb4..c39be2a 100644 --- a/generic/tcl.decls +++ b/generic/tcl.decls @@ -2470,6 +2470,23 @@ declare 673 { int TclGetUniChar(Tcl_Obj *objPtr, int index) } +declare 676 { + Tcl_Command Tcl_CreateObjCommand2(Tcl_Interp *interp, + const char *cmdName, + Tcl_ObjCmdProc2 *proc2, void *clientData, + Tcl_CmdDeleteProc *deleteProc) +} +declare 677 { + Tcl_Trace Tcl_CreateObjTrace2(Tcl_Interp *interp, int level, int flags, + Tcl_CmdObjTraceProc2 *objProc2, void *clientData, + Tcl_CmdObjTraceDeleteProc *delProc) +} +declare 679 { + Tcl_Command Tcl_NRCreateCommand2(Tcl_Interp *interp, + const char *cmdName, Tcl_ObjCmdProc2 *proc, + Tcl_ObjCmdProc2 *nreProc2, void *clientData, + Tcl_CmdDeleteProc *deleteProc) +} # ----- BASELINE -- FOR -- 8.7.0 ----- # diff --git a/generic/tcl.h b/generic/tcl.h index 274be35..886e42e 100644 --- a/generic/tcl.h +++ b/generic/tcl.h @@ -673,6 +673,9 @@ typedef void (Tcl_CmdTraceProc) (ClientData clientData, Tcl_Interp *interp, typedef int (Tcl_CmdObjTraceProc) (ClientData clientData, Tcl_Interp *interp, int level, const char *command, Tcl_Command commandInfo, int objc, struct Tcl_Obj *const *objv); +typedef int (Tcl_CmdObjTraceProc2) (void *clientData, Tcl_Interp *interp, + int level, const char *command, Tcl_Command commandInfo, size_t objc, + struct Tcl_Obj *const objv[]); typedef void (Tcl_CmdObjTraceDeleteProc) (ClientData clientData); typedef void (Tcl_DupInternalRepProc) (struct Tcl_Obj *srcPtr, struct Tcl_Obj *dupPtr); @@ -697,6 +700,8 @@ typedef int (Tcl_MathProc) (ClientData clientData, Tcl_Interp *interp, typedef void (Tcl_NamespaceDeleteProc) (ClientData clientData); typedef int (Tcl_ObjCmdProc) (ClientData clientData, Tcl_Interp *interp, int objc, struct Tcl_Obj *const *objv); +typedef int (Tcl_ObjCmdProc2) (void *clientData, Tcl_Interp *interp, + size_t objc, struct Tcl_Obj *const *objv); typedef int (Tcl_LibraryInitProc) (Tcl_Interp *interp); typedef int (Tcl_LibraryUnloadProc) (Tcl_Interp *interp, int flags); typedef void (Tcl_PanicProc) (const char *format, ...); @@ -916,6 +921,13 @@ typedef struct Tcl_CmdInfo { * change a command's namespace; use * TclRenameCommand or Tcl_Eval (of 'rename') * to do that. */ +#if (TCL_MAJOR_VERSION > 8) || defined(TCL_NO_DEPRECATED) + Tcl_ObjCmdProc2 *objProc2; /* Command's object-based function. */ + void *objClientData2; /* ClientData for object proc. */ +#else + void *reserved1; + void *reserved2; +#endif } Tcl_CmdInfo; /* diff --git a/generic/tclBasic.c b/generic/tclBasic.c index f87e1e1..c1dd8cb 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -2689,6 +2689,58 @@ Tcl_CreateCommand( *---------------------------------------------------------------------- */ +typedef struct { + void *clientData; /* Arbitrary value to pass to object function. */ + Tcl_ObjCmdProc2 *proc; + Tcl_CmdDeleteProc *deleteProc; +} CmdWrapperInfo; + + +static int cmdWrapperProc(void *clientData, + Tcl_Interp *interp, + int objc, + struct Tcl_Obj * const *objv) +{ + CmdWrapperInfo *info = (CmdWrapperInfo *)clientData; + return info->proc(info->clientData, interp, objc, objv); +} + +static void cmdWrapperDeleteProc(void *clientData) { + CmdWrapperInfo *info = (CmdWrapperInfo *)clientData; + + clientData = info->clientData; + Tcl_CmdDeleteProc *deleteProc = info->deleteProc; + Tcl_Free(info); + if (deleteProc != NULL) { + deleteProc(clientData); + } +} + +Tcl_Command +Tcl_CreateObjCommand2( + Tcl_Interp *interp, /* Token for command interpreter (returned by + * previous call to Tcl_CreateInterp). */ + const char *cmdName, /* Name of command. If it contains namespace + * qualifiers, the new command is put in the + * specified namespace; otherwise it is put in + * the global namespace. */ + Tcl_ObjCmdProc2 *proc, /* Object-based function to associate with + * name. */ + void *clientData, /* Arbitrary value to pass to object + * function. */ + Tcl_CmdDeleteProc *deleteProc + /* If not NULL, gives a function to call when + * this command is deleted. */ +) +{ + CmdWrapperInfo *info = (CmdWrapperInfo *)Tcl_Alloc(sizeof(CmdWrapperInfo)); + info->proc = proc; + info->deleteProc = deleteProc; + info->clientData = clientData; + + return Tcl_CreateObjCommand(interp, cmdName, cmdWrapperProc, info, cmdWrapperDeleteProc); +} + Tcl_Command Tcl_CreateObjCommand( Tcl_Interp *interp, /* Token for command interpreter (returned by @@ -3377,6 +3429,21 @@ Tcl_GetCommandInfo( *---------------------------------------------------------------------- */ +#if TCL_MAJOR_VERSION > 8 || defined(TCL_NO_DEPRECATED) +static int cmdWrapper2Proc(void *clientData, + Tcl_Interp *interp, + size_t objc, + Tcl_Obj *const objv[]) +{ + Command *cmdPtr = (Command *)clientData; + if (objc > INT_MAX) { + Tcl_WrongNumArgs(interp, 1, objv, "?args?"); + return TCL_ERROR; + } + return cmdPtr->objProc(cmdPtr->objClientData, interp, objc, objv); +} +#endif + int Tcl_GetCommandInfoFromToken( Tcl_Command cmd, @@ -3403,7 +3470,17 @@ Tcl_GetCommandInfoFromToken( infoPtr->deleteProc = cmdPtr->deleteProc; infoPtr->deleteData = cmdPtr->deleteData; infoPtr->namespacePtr = (Tcl_Namespace *) cmdPtr->nsPtr; - +#if TCL_MAJOR_VERSION > 8 || defined(TCL_NO_DEPRECATED) + if (infoPtr->objProc == cmdWrapperProc) { + CmdWrapperInfo *info = (CmdWrapperInfo *)cmdPtr->objClientData; + infoPtr->objProc2 = info->proc; + infoPtr->objClientData2 = info->clientData; + infoPtr->isNativeObjectProc = 2; + } else { + infoPtr->objProc2 = cmdWrapper2Proc; + infoPtr->objClientData2 = cmdPtr; + } +#endif return 1; } @@ -9125,6 +9202,69 @@ Tcl_NRCallObjProc( *---------------------------------------------------------------------- */ +typedef struct { + Tcl_ObjCmdProc2 *proc; + Tcl_ObjCmdProc2 *nreProc; + Tcl_CmdDeleteProc *delProc; + void *clientData; +} NRCommandWrapper; + +static int wrapperProc2( + void *clientData, + Tcl_Interp *interp, + int objc, + struct Tcl_Obj *const objv[]) +{ + NRCommandWrapper *wrapper = (NRCommandWrapper *)clientData; + return wrapper->proc(wrapper->clientData, interp, objc, objv); +} + +static int wrapperNRProc2( + void *clientData, + Tcl_Interp *interp, + int objc, + struct Tcl_Obj *const objv[]) +{ + NRCommandWrapper *wrapper = (NRCommandWrapper *)clientData; + return wrapper->nreProc(wrapper->clientData, interp, objc, objv); +} + +static void wrapperDelProc2(void *clientData) +{ + NRCommandWrapper *wrapper = (NRCommandWrapper *)clientData; + clientData = wrapper->clientData; + wrapper->delProc(clientData); + Tcl_Free(wrapper); +} + + +Tcl_Command +Tcl_NRCreateCommand2( + Tcl_Interp *interp, /* Token for command interpreter (returned by + * previous call to Tcl_CreateInterp). */ + const char *cmdName, /* Name of command. If it contains namespace + * qualifiers, the new command is put in the + * specified namespace; otherwise it is put in + * the global namespace. */ + Tcl_ObjCmdProc2 *proc, /* Object-based function to associate with + * name, provides direct access for direct + * calls. */ + Tcl_ObjCmdProc2 *nreProc, /* Object-based function to associate with + * name, provides NR implementation */ + void *clientData, /* Arbitrary value to pass to object + * function. */ + Tcl_CmdDeleteProc *deleteProc) + /* If not NULL, gives a function to call when + * this command is deleted. */ +{ + NRCommandWrapper *wrapper = (NRCommandWrapper *)Tcl_Alloc(sizeof(NRCommandWrapper)); + wrapper->proc = proc; + wrapper->nreProc = nreProc; + wrapper->delProc = deleteProc; + wrapper->clientData = clientData; + return Tcl_NRCreateCommand(interp, cmdName, wrapperProc2, wrapperNRProc2, wrapper, wrapperDelProc2); +} + Tcl_Command Tcl_NRCreateCommand( Tcl_Interp *interp, /* Token for command interpreter (returned by diff --git a/generic/tclDecls.h b/generic/tclDecls.h index ee9e02f..efc185a 100644 --- a/generic/tclDecls.h +++ b/generic/tclDecls.h @@ -1974,6 +1974,24 @@ EXTERN const char * TclUtfAtIndex(const char *src, int index); EXTERN Tcl_Obj * TclGetRange(Tcl_Obj *objPtr, int first, int last); /* 673 */ EXTERN int TclGetUniChar(Tcl_Obj *objPtr, int index); +/* Slot 674 is reserved */ +/* Slot 675 is reserved */ +/* 676 */ +EXTERN Tcl_Command Tcl_CreateObjCommand2(Tcl_Interp *interp, + const char *cmdName, Tcl_ObjCmdProc2 *proc2, + void *clientData, + Tcl_CmdDeleteProc *deleteProc); +/* 677 */ +EXTERN Tcl_Trace Tcl_CreateObjTrace2(Tcl_Interp *interp, int level, + int flags, Tcl_CmdObjTraceProc2 *objProc2, + void *clientData, + Tcl_CmdObjTraceDeleteProc *delProc); +/* Slot 678 is reserved */ +/* 679 */ +EXTERN Tcl_Command Tcl_NRCreateCommand2(Tcl_Interp *interp, + const char *cmdName, Tcl_ObjCmdProc2 *proc, + Tcl_ObjCmdProc2 *nreProc2, void *clientData, + Tcl_CmdDeleteProc *deleteProc); typedef struct { const struct TclPlatStubs *tclPlatStubs; @@ -2683,6 +2701,12 @@ typedef struct TclStubs { const char * (*tclUtfAtIndex) (const char *src, int index); /* 671 */ Tcl_Obj * (*tclGetRange) (Tcl_Obj *objPtr, int first, int last); /* 672 */ int (*tclGetUniChar) (Tcl_Obj *objPtr, int index); /* 673 */ + void (*reserved674)(void); + void (*reserved675)(void); + Tcl_Command (*tcl_CreateObjCommand2) (Tcl_Interp *interp, const char *cmdName, Tcl_ObjCmdProc2 *proc2, void *clientData, Tcl_CmdDeleteProc *deleteProc); /* 676 */ + Tcl_Trace (*tcl_CreateObjTrace2) (Tcl_Interp *interp, int level, int flags, Tcl_CmdObjTraceProc2 *objProc2, void *clientData, Tcl_CmdObjTraceDeleteProc *delProc); /* 677 */ + void (*reserved678)(void); + Tcl_Command (*tcl_NRCreateCommand2) (Tcl_Interp *interp, const char *cmdName, Tcl_ObjCmdProc2 *proc, Tcl_ObjCmdProc2 *nreProc2, void *clientData, Tcl_CmdDeleteProc *deleteProc); /* 679 */ } TclStubs; extern const TclStubs *tclStubsPtr; @@ -4054,6 +4078,15 @@ extern const TclStubs *tclStubsPtr; (tclStubsPtr->tclGetRange) /* 672 */ #define TclGetUniChar \ (tclStubsPtr->tclGetUniChar) /* 673 */ +/* Slot 674 is reserved */ +/* Slot 675 is reserved */ +#define Tcl_CreateObjCommand2 \ + (tclStubsPtr->tcl_CreateObjCommand2) /* 676 */ +#define Tcl_CreateObjTrace2 \ + (tclStubsPtr->tcl_CreateObjTrace2) /* 677 */ +/* Slot 678 is reserved */ +#define Tcl_NRCreateCommand2 \ + (tclStubsPtr->tcl_NRCreateCommand2) /* 679 */ #endif /* defined(USE_TCL_STUBS) */ diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c index d34aff4..0f49f93 100644 --- a/generic/tclStubInit.c +++ b/generic/tclStubInit.c @@ -1968,6 +1968,12 @@ const TclStubs tclStubs = { TclUtfAtIndex, /* 671 */ TclGetRange, /* 672 */ TclGetUniChar, /* 673 */ + 0, /* 674 */ + 0, /* 675 */ + Tcl_CreateObjCommand2, /* 676 */ + Tcl_CreateObjTrace2, /* 677 */ + 0, /* 678 */ + Tcl_NRCreateCommand2, /* 679 */ }; /* !END!: Do not edit above this line. */ diff --git a/generic/tclTest.c b/generic/tclTest.c index c740109..8502ccd 100644 --- a/generic/tclTest.c +++ b/generic/tclTest.c @@ -203,25 +203,25 @@ static int EncodingFromUtfProc(void *clientData, int *dstCharsPtr); static void ExitProcEven(void *clientData); static void ExitProcOdd(void *clientData); -static Tcl_ObjCmdProc GetTimesObjCmd; +static Tcl_ObjCmdProc2 GetTimesObjCmd; static Tcl_ResolveCompiledVarProc InterpCompiledVarResolver; static void MainLoop(void); static Tcl_CmdProc NoopCmd; -static Tcl_ObjCmdProc NoopObjCmd; +static Tcl_ObjCmdProc2 NoopObjCmd; static int ObjTraceProc(void *clientData, Tcl_Interp *interp, int level, const char *command, - Tcl_Command commandToken, int objc, + Tcl_Command commandToken, size_t objc, Tcl_Obj *const objv[]); static void ObjTraceDeleteProc(void *clientData); static void PrintParse(Tcl_Interp *interp, Tcl_Parse *parsePtr); static void SpecialFree(char *blockPtr); static int StaticInitProc(Tcl_Interp *interp); static Tcl_CmdProc TestasyncCmd; -static Tcl_ObjCmdProc TestbumpinterpepochObjCmd; -static Tcl_ObjCmdProc TestbytestringObjCmd; -static Tcl_ObjCmdProc TestsetbytearraylengthObjCmd; -static Tcl_ObjCmdProc TestpurebytesobjObjCmd; -static Tcl_ObjCmdProc TeststringbytesObjCmd; +static Tcl_ObjCmdProc2 TestbumpinterpepochObjCmd; +static Tcl_ObjCmdProc2 TestbytestringObjCmd; +static Tcl_ObjCmdProc2 TestsetbytearraylengthObjCmd; +static Tcl_ObjCmdProc2 TestpurebytesobjObjCmd; +static Tcl_ObjCmdProc2 TeststringbytesObjCmd; static Tcl_CmdProc TestcmdinfoCmd; static Tcl_CmdProc TestcmdtokenCmd; static Tcl_CmdProc TestcmdtraceCmd; @@ -230,70 +230,70 @@ static Tcl_CmdProc TestcreatecommandCmd; static Tcl_CmdProc TestdcallCmd; static Tcl_CmdProc TestdelCmd; static Tcl_CmdProc TestdelassocdataCmd; -static Tcl_ObjCmdProc TestdoubledigitsObjCmd; +static Tcl_ObjCmdProc2 TestdoubledigitsObjCmd; static Tcl_CmdProc TestdstringCmd; -static Tcl_ObjCmdProc TestencodingObjCmd; -static Tcl_ObjCmdProc TestevalexObjCmd; -static Tcl_ObjCmdProc TestevalobjvObjCmd; -static Tcl_ObjCmdProc TesteventObjCmd; +static Tcl_ObjCmdProc2 TestencodingObjCmd; +static Tcl_ObjCmdProc2 TestevalexObjCmd; +static Tcl_ObjCmdProc2 TestevalobjvObjCmd; +static Tcl_ObjCmdProc2 TesteventObjCmd; static int TesteventProc(Tcl_Event *event, int flags); static int TesteventDeleteProc(Tcl_Event *event, void *clientData); static Tcl_CmdProc TestexithandlerCmd; static Tcl_CmdProc TestexprlongCmd; -static Tcl_ObjCmdProc TestexprlongobjCmd; +static Tcl_ObjCmdProc2 TestexprlongobjCmd; static Tcl_CmdProc TestexprdoubleCmd; -static Tcl_ObjCmdProc TestexprdoubleobjCmd; -static Tcl_ObjCmdProc TestexprparserObjCmd; +static Tcl_ObjCmdProc2 TestexprdoubleobjCmd; +static Tcl_ObjCmdProc2 TestexprparserObjCmd; static Tcl_CmdProc TestexprstringCmd; -static Tcl_ObjCmdProc TestfileCmd; -static Tcl_ObjCmdProc TestfilelinkCmd; +static Tcl_ObjCmdProc2 TestfileCmd; +static Tcl_ObjCmdProc2 TestfilelinkCmd; static Tcl_CmdProc TestfeventCmd; static Tcl_CmdProc TestgetassocdataCmd; static Tcl_CmdProc TestgetintCmd; static Tcl_CmdProc TestlongsizeCmd; static Tcl_CmdProc TestgetplatformCmd; -static Tcl_ObjCmdProc TestgetvarfullnameCmd; +static Tcl_ObjCmdProc2 TestgetvarfullnameCmd; static Tcl_CmdProc TestinterpdeleteCmd; static Tcl_CmdProc TestlinkCmd; -static Tcl_ObjCmdProc TestlinkarrayCmd; -static Tcl_ObjCmdProc TestlocaleCmd; +static Tcl_ObjCmdProc2 TestlinkarrayCmd; +static Tcl_ObjCmdProc2 TestlocaleCmd; static Tcl_CmdProc TestmainthreadCmd; static Tcl_CmdProc TestsetmainloopCmd; static Tcl_CmdProc TestexitmainloopCmd; static Tcl_CmdProc TestpanicCmd; -static Tcl_ObjCmdProc TestparseargsCmd; -static Tcl_ObjCmdProc TestparserObjCmd; -static Tcl_ObjCmdProc TestparsevarObjCmd; -static Tcl_ObjCmdProc TestparsevarnameObjCmd; -static Tcl_ObjCmdProc TestpreferstableObjCmd; -static Tcl_ObjCmdProc TestprintObjCmd; -static Tcl_ObjCmdProc TestregexpObjCmd; -static Tcl_ObjCmdProc TestreturnObjCmd; +static Tcl_ObjCmdProc2 TestparseargsCmd; +static Tcl_ObjCmdProc2 TestparserObjCmd; +static Tcl_ObjCmdProc2 TestparsevarObjCmd; +static Tcl_ObjCmdProc2 TestparsevarnameObjCmd; +static Tcl_ObjCmdProc2 TestpreferstableObjCmd; +static Tcl_ObjCmdProc2 TestprintObjCmd; +static Tcl_ObjCmdProc2 TestregexpObjCmd; +static Tcl_ObjCmdProc2 TestreturnObjCmd; static void TestregexpXflags(const char *string, int length, int *cflagsPtr, int *eflagsPtr); -static Tcl_ObjCmdProc TestsaveresultCmd; +static Tcl_ObjCmdProc2 TestsaveresultCmd; static void TestsaveresultFree(char *blockPtr); static Tcl_CmdProc TestsetassocdataCmd; static Tcl_CmdProc TestsetCmd; static Tcl_CmdProc Testset2Cmd; static Tcl_CmdProc TestseterrorcodeCmd; -static Tcl_ObjCmdProc TestsetobjerrorcodeCmd; +static Tcl_ObjCmdProc2 TestsetobjerrorcodeCmd; static Tcl_CmdProc TestsetplatformCmd; static Tcl_CmdProc TeststaticlibraryCmd; static Tcl_CmdProc TesttranslatefilenameCmd; static Tcl_CmdProc TestupvarCmd; -static Tcl_ObjCmdProc TestWrongNumArgsObjCmd; -static Tcl_ObjCmdProc TestGetIndexFromObjStructObjCmd; +static Tcl_ObjCmdProc2 TestWrongNumArgsObjCmd; +static Tcl_ObjCmdProc2 TestGetIndexFromObjStructObjCmd; static Tcl_CmdProc TestChannelCmd; static Tcl_CmdProc TestChannelEventCmd; static Tcl_CmdProc TestSocketCmd; -static Tcl_ObjCmdProc TestFilesystemObjCmd; -static Tcl_ObjCmdProc TestSimpleFilesystemObjCmd; +static Tcl_ObjCmdProc2 TestFilesystemObjCmd; +static Tcl_ObjCmdProc2 TestSimpleFilesystemObjCmd; static void TestReport(const char *cmd, Tcl_Obj *arg1, Tcl_Obj *arg2); -static Tcl_ObjCmdProc TestgetencpathObjCmd; -static Tcl_ObjCmdProc TestsetencpathObjCmd; +static Tcl_ObjCmdProc2 TestgetencpathObjCmd; +static Tcl_ObjCmdProc2 TestsetencpathObjCmd; static Tcl_Obj * TestReportGetNativePath(Tcl_Obj *pathPtr); static Tcl_FSStatProc TestReportStat; static Tcl_FSAccessProc TestReportAccess; @@ -326,20 +326,20 @@ static Tcl_FSListVolumesProc SimpleListVolumes; static Tcl_FSPathInFilesystemProc SimplePathInFilesystem; static Tcl_Obj * SimpleRedirect(Tcl_Obj *pathPtr); static Tcl_FSMatchInDirectoryProc SimpleMatchInDirectory; -static Tcl_ObjCmdProc TestUtfNextCmd; -static Tcl_ObjCmdProc TestUtfPrevCmd; -static Tcl_ObjCmdProc TestNumUtfCharsCmd; -static Tcl_ObjCmdProc TestFindFirstCmd; -static Tcl_ObjCmdProc TestFindLastCmd; -static Tcl_ObjCmdProc TestHashSystemHashCmd; -static Tcl_ObjCmdProc TestGetIntForIndexCmd; +static Tcl_ObjCmdProc2 TestUtfNextCmd; +static Tcl_ObjCmdProc2 TestUtfPrevCmd; +static Tcl_ObjCmdProc2 TestNumUtfCharsCmd; +static Tcl_ObjCmdProc2 TestFindFirstCmd; +static Tcl_ObjCmdProc2 TestFindLastCmd; +static Tcl_ObjCmdProc2 TestHashSystemHashCmd; +static Tcl_ObjCmdProc2 TestGetIntForIndexCmd; static Tcl_NRPostProc NREUnwind_callback; -static Tcl_ObjCmdProc TestNREUnwind; -static Tcl_ObjCmdProc TestNRELevels; -static Tcl_ObjCmdProc TestInterpResolverCmd; +static Tcl_ObjCmdProc2 TestNREUnwind; +static Tcl_ObjCmdProc2 TestNRELevels; +static Tcl_ObjCmdProc2 TestInterpResolverCmd; #if defined(HAVE_CPUID) && !defined(MAC_OSX_TCL) -static Tcl_ObjCmdProc TestcpuidCmd; +static Tcl_ObjCmdProc2 TestcpuidCmd; #endif static const Tcl_Filesystem testReportingFilesystem = { @@ -522,7 +522,7 @@ Tcltest_Init( { Tcl_CmdInfo info; Tcl_Obj **objv, *objPtr; - int objc, index; + size_t objc, index; static const char *const specialOptions[] = { "-appinitprocerror", "-appinitprocdeleteinterp", "-appinitprocclosestderr", "-appinitprocsetrcfile", NULL @@ -552,23 +552,23 @@ Tcltest_Init( * Create additional commands and math functions for testing Tcl. */ - Tcl_CreateObjCommand(interp, "gettimes", GetTimesObjCmd, NULL, NULL); + Tcl_CreateObjCommand2(interp, "gettimes", GetTimesObjCmd, NULL, NULL); Tcl_CreateCommand(interp, "noop", NoopCmd, NULL, NULL); - Tcl_CreateObjCommand(interp, "noop", NoopObjCmd, NULL, NULL); - Tcl_CreateObjCommand(interp, "testpurebytesobj", TestpurebytesobjObjCmd, NULL, NULL); - Tcl_CreateObjCommand(interp, "testsetbytearraylength", TestsetbytearraylengthObjCmd, NULL, NULL); - Tcl_CreateObjCommand(interp, "testbytestring", TestbytestringObjCmd, NULL, NULL); - Tcl_CreateObjCommand(interp, "teststringbytes", TeststringbytesObjCmd, NULL, NULL); - Tcl_CreateObjCommand(interp, "testwrongnumargs", TestWrongNumArgsObjCmd, + Tcl_CreateObjCommand2(interp, "noop", NoopObjCmd, NULL, NULL); + Tcl_CreateObjCommand2(interp, "testpurebytesobj", TestpurebytesobjObjCmd, NULL, NULL); + Tcl_CreateObjCommand2(interp, "testsetbytearraylength", TestsetbytearraylengthObjCmd, NULL, NULL); + Tcl_CreateObjCommand2(interp, "testbytestring", TestbytestringObjCmd, NULL, NULL); + Tcl_CreateObjCommand2(interp, "teststringbytes", TeststringbytesObjCmd, NULL, NULL); + Tcl_CreateObjCommand2(interp, "testwrongnumargs", TestWrongNumArgsObjCmd, NULL, NULL); - Tcl_CreateObjCommand(interp, "testfilesystem", TestFilesystemObjCmd, + Tcl_CreateObjCommand2(interp, "testfilesystem", TestFilesystemObjCmd, NULL, NULL); - Tcl_CreateObjCommand(interp, "testsimplefilesystem", TestSimpleFilesystemObjCmd, + Tcl_CreateObjCommand2(interp, "testsimplefilesystem", TestSimpleFilesystemObjCmd, NULL, NULL); - Tcl_CreateObjCommand(interp, "testgetindexfromobjstruct", + Tcl_CreateObjCommand2(interp, "testgetindexfromobjstruct", TestGetIndexFromObjStructObjCmd, NULL, NULL); Tcl_CreateCommand(interp, "testasync", TestasyncCmd, NULL, NULL); - Tcl_CreateObjCommand(interp, "testbumpinterpepoch", + Tcl_CreateObjCommand2(interp, "testbumpinterpepoch", TestbumpinterpepochObjCmd, NULL, NULL); Tcl_CreateCommand(interp, "testchannel", TestChannelCmd, NULL, NULL); @@ -588,40 +588,40 @@ Tcltest_Init( Tcl_CreateCommand(interp, "testdel", TestdelCmd, NULL, NULL); Tcl_CreateCommand(interp, "testdelassocdata", TestdelassocdataCmd, NULL, NULL); - Tcl_CreateObjCommand(interp, "testdoubledigits", TestdoubledigitsObjCmd, + Tcl_CreateObjCommand2(interp, "testdoubledigits", TestdoubledigitsObjCmd, NULL, NULL); Tcl_DStringInit(&dstring); Tcl_CreateCommand(interp, "testdstring", TestdstringCmd, NULL, NULL); - Tcl_CreateObjCommand(interp, "testencoding", TestencodingObjCmd, NULL, + Tcl_CreateObjCommand2(interp, "testencoding", TestencodingObjCmd, NULL, NULL); - Tcl_CreateObjCommand(interp, "testevalex", TestevalexObjCmd, + Tcl_CreateObjCommand2(interp, "testevalex", TestevalexObjCmd, NULL, NULL); - Tcl_CreateObjCommand(interp, "testevalobjv", TestevalobjvObjCmd, + Tcl_CreateObjCommand2(interp, "testevalobjv", TestevalobjvObjCmd, NULL, NULL); - Tcl_CreateObjCommand(interp, "testevent", TesteventObjCmd, + Tcl_CreateObjCommand2(interp, "testevent", TesteventObjCmd, NULL, NULL); Tcl_CreateCommand(interp, "testexithandler", TestexithandlerCmd, NULL, NULL); Tcl_CreateCommand(interp, "testexprlong", TestexprlongCmd, NULL, NULL); - Tcl_CreateObjCommand(interp, "testexprlongobj", TestexprlongobjCmd, + Tcl_CreateObjCommand2(interp, "testexprlongobj", TestexprlongobjCmd, NULL, NULL); Tcl_CreateCommand(interp, "testexprdouble", TestexprdoubleCmd, NULL, NULL); - Tcl_CreateObjCommand(interp, "testexprdoubleobj", TestexprdoubleobjCmd, + Tcl_CreateObjCommand2(interp, "testexprdoubleobj", TestexprdoubleobjCmd, NULL, NULL); - Tcl_CreateObjCommand(interp, "testexprparser", TestexprparserObjCmd, + Tcl_CreateObjCommand2(interp, "testexprparser", TestexprparserObjCmd, NULL, NULL); Tcl_CreateCommand(interp, "testexprstring", TestexprstringCmd, NULL, NULL); Tcl_CreateCommand(interp, "testfevent", TestfeventCmd, NULL, NULL); - Tcl_CreateObjCommand(interp, "testfilelink", TestfilelinkCmd, + Tcl_CreateObjCommand2(interp, "testfilelink", TestfilelinkCmd, NULL, NULL); - Tcl_CreateObjCommand(interp, "testfile", TestfileCmd, + Tcl_CreateObjCommand2(interp, "testfile", TestfileCmd, NULL, NULL); - Tcl_CreateObjCommand(interp, "testhashsystemhash", + Tcl_CreateObjCommand2(interp, "testhashsystemhash", TestHashSystemHashCmd, NULL, NULL); Tcl_CreateCommand(interp, "testgetassocdata", TestgetassocdataCmd, NULL, NULL); @@ -631,31 +631,31 @@ Tcltest_Init( NULL, NULL); Tcl_CreateCommand(interp, "testgetplatform", TestgetplatformCmd, NULL, NULL); - Tcl_CreateObjCommand(interp, "testgetvarfullname", + Tcl_CreateObjCommand2(interp, "testgetvarfullname", TestgetvarfullnameCmd, NULL, NULL); Tcl_CreateCommand(interp, "testinterpdelete", TestinterpdeleteCmd, NULL, NULL); Tcl_CreateCommand(interp, "testlink", TestlinkCmd, NULL, NULL); - Tcl_CreateObjCommand(interp, "testlinkarray", TestlinkarrayCmd, NULL, NULL); - Tcl_CreateObjCommand(interp, "testlocale", TestlocaleCmd, NULL, + Tcl_CreateObjCommand2(interp, "testlinkarray", TestlinkarrayCmd, NULL, NULL); + Tcl_CreateObjCommand2(interp, "testlocale", TestlocaleCmd, NULL, NULL); Tcl_CreateCommand(interp, "testpanic", TestpanicCmd, NULL, NULL); - Tcl_CreateObjCommand(interp, "testparseargs", TestparseargsCmd,NULL,NULL); - Tcl_CreateObjCommand(interp, "testparser", TestparserObjCmd, + Tcl_CreateObjCommand2(interp, "testparseargs", TestparseargsCmd,NULL,NULL); + Tcl_CreateObjCommand2(interp, "testparser", TestparserObjCmd, NULL, NULL); - Tcl_CreateObjCommand(interp, "testparsevar", TestparsevarObjCmd, + Tcl_CreateObjCommand2(interp, "testparsevar", TestparsevarObjCmd, NULL, NULL); - Tcl_CreateObjCommand(interp, "testparsevarname", TestparsevarnameObjCmd, + Tcl_CreateObjCommand2(interp, "testparsevarname", TestparsevarnameObjCmd, NULL, NULL); - Tcl_CreateObjCommand(interp, "testpreferstable", TestpreferstableObjCmd, + Tcl_CreateObjCommand2(interp, "testpreferstable", TestpreferstableObjCmd, NULL, NULL); - Tcl_CreateObjCommand(interp, "testprint", TestprintObjCmd, + Tcl_CreateObjCommand2(interp, "testprint", TestprintObjCmd, NULL, NULL); - Tcl_CreateObjCommand(interp, "testregexp", TestregexpObjCmd, + Tcl_CreateObjCommand2(interp, "testregexp", TestregexpObjCmd, NULL, NULL); - Tcl_CreateObjCommand(interp, "testreturn", TestreturnObjCmd, + Tcl_CreateObjCommand2(interp, "testreturn", TestreturnObjCmd, NULL, NULL); - Tcl_CreateObjCommand(interp, "testsaveresult", TestsaveresultCmd, + Tcl_CreateObjCommand2(interp, "testsaveresult", TestsaveresultCmd, NULL, NULL); Tcl_CreateCommand(interp, "testservicemode", TestServiceModeCmd, NULL, NULL); @@ -669,19 +669,19 @@ Tcltest_Init( INT2PTR(TCL_LEAVE_ERR_MSG), NULL); Tcl_CreateCommand(interp, "testseterrorcode", TestseterrorcodeCmd, NULL, NULL); - Tcl_CreateObjCommand(interp, "testsetobjerrorcode", + Tcl_CreateObjCommand2(interp, "testsetobjerrorcode", TestsetobjerrorcodeCmd, NULL, NULL); - Tcl_CreateObjCommand(interp, "testutfnext", + Tcl_CreateObjCommand2(interp, "testutfnext", TestUtfNextCmd, NULL, NULL); - Tcl_CreateObjCommand(interp, "testutfprev", + Tcl_CreateObjCommand2(interp, "testutfprev", TestUtfPrevCmd, NULL, NULL); - Tcl_CreateObjCommand(interp, "testnumutfchars", + Tcl_CreateObjCommand2(interp, "testnumutfchars", TestNumUtfCharsCmd, NULL, NULL); - Tcl_CreateObjCommand(interp, "testfindfirst", + Tcl_CreateObjCommand2(interp, "testfindfirst", TestFindFirstCmd, NULL, NULL); - Tcl_CreateObjCommand(interp, "testfindlast", + Tcl_CreateObjCommand2(interp, "testfindlast", TestFindLastCmd, NULL, NULL); - Tcl_CreateObjCommand(interp, "testgetintforindex", + Tcl_CreateObjCommand2(interp, "testgetintforindex", TestGetIntForIndexCmd, NULL, NULL); Tcl_CreateCommand(interp, "testsetplatform", TestsetplatformCmd, NULL, NULL); @@ -699,18 +699,18 @@ Tcltest_Init( Tcl_CreateCommand(interp, "testexitmainloop", TestexitmainloopCmd, NULL, NULL); #if defined(HAVE_CPUID) && !defined(MAC_OSX_TCL) - Tcl_CreateObjCommand(interp, "testcpuid", TestcpuidCmd, + Tcl_CreateObjCommand2(interp, "testcpuid", TestcpuidCmd, NULL, NULL); #endif - Tcl_CreateObjCommand(interp, "testnreunwind", TestNREUnwind, + Tcl_CreateObjCommand2(interp, "testnreunwind", TestNREUnwind, NULL, NULL); - Tcl_CreateObjCommand(interp, "testnrelevels", TestNRELevels, + Tcl_CreateObjCommand2(interp, "testnrelevels", TestNRELevels, NULL, NULL); - Tcl_CreateObjCommand(interp, "testinterpresolver", TestInterpResolverCmd, + Tcl_CreateObjCommand2(interp, "testinterpresolver", TestInterpResolverCmd, NULL, NULL); - Tcl_CreateObjCommand(interp, "testgetencpath", TestgetencpathObjCmd, + Tcl_CreateObjCommand2(interp, "testgetencpath", TestgetencpathObjCmd, NULL, NULL); - Tcl_CreateObjCommand(interp, "testsetencpath", TestsetencpathObjCmd, + Tcl_CreateObjCommand2(interp, "testsetencpath", TestsetencpathObjCmd, NULL, NULL); if (TclObjTest_Init(interp) != TCL_OK) { @@ -731,9 +731,11 @@ Tcltest_Init( objPtr = Tcl_GetVar2Ex(interp, "argv", NULL, TCL_GLOBAL_ONLY); if (objPtr != NULL) { - if (Tcl_ListObjGetElements(interp, objPtr, &objc, &objv) != TCL_OK) { + int val; + if (Tcl_ListObjGetElements(interp, objPtr, &val, &objv) != TCL_OK) { return TCL_ERROR; } + objc = val; if (objc && (Tcl_GetIndexFromObj(NULL, objv[0], specialOptions, NULL, TCL_EXACT, &index) == TCL_OK)) { switch (index) { @@ -1025,7 +1027,7 @@ static int TestbumpinterpepochObjCmd( TCL_UNUSED(void *), Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ + size_t objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { Interp *iPtr = (Interp *)interp; @@ -1101,7 +1103,9 @@ TestcmdinfoCmd( Tcl_AppendResult(interp, " unknown", NULL); } Tcl_AppendResult(interp, " ", info.namespacePtr->fullName, NULL); - if (info.isNativeObjectProc) { + if (info.isNativeObjectProc == 2) { + Tcl_AppendResult(interp, " nativeObjectProc2", NULL); + } else if (info.isNativeObjectProc == 1) { Tcl_AppendResult(interp, " nativeObjectProc", NULL); } else { Tcl_AppendResult(interp, " stringProc", NULL); @@ -1111,6 +1115,10 @@ TestcmdinfoCmd( info.clientData = (void *) "new_command_data"; info.objProc = NULL; info.objClientData = NULL; +#if TCL_MAJOR_VERSION > 8 || defined(TCL_NO_DEPRECATED) + info.objProc2 = NULL; + info.objClientData2 = NULL; +#endif info.deleteProc = CmdDelProc2; info.deleteData = (void *) "new_delete_data"; if (Tcl_SetCommandInfo(interp, argv[2], &info) == 0) { @@ -1302,7 +1310,7 @@ TestcmdtraceCmd( static int deleteCalled; deleteCalled = 0; - cmdTrace = Tcl_CreateObjTrace(interp, 50000, + cmdTrace = Tcl_CreateObjTrace2(interp, 50000, TCL_ALLOW_INLINE_COMPILATION, ObjTraceProc, &deleteCalled, ObjTraceDeleteProc); result = Tcl_EvalEx(interp, argv[2], -1, 0); @@ -1388,7 +1396,7 @@ ObjTraceProc( TCL_UNUSED(int) /*level*/, const char *command, TCL_UNUSED(Tcl_Command), - TCL_UNUSED(int) /*objc*/, + TCL_UNUSED(size_t) /*objc*/, Tcl_Obj *const objv[]) /* Argument objects. */ { const char *word = Tcl_GetString(objv[0]); @@ -1708,7 +1716,7 @@ static int TestdoubledigitsObjCmd( TCL_UNUSED(void *), Tcl_Interp* interp, /* Tcl interpreter */ - int objc, /* Parameter count */ + size_t objc, /* Parameter count */ Tcl_Obj* const objv[]) /* Parameter vector */ { static const char *options[] = { @@ -1921,7 +1929,7 @@ static int TestencodingObjCmd( TCL_UNUSED(void *), Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ + size_t objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { Tcl_Encoding encoding; @@ -2081,7 +2089,7 @@ static int TestevalexObjCmd( TCL_UNUSED(void *), Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ + size_t objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { int length, flags; @@ -2126,7 +2134,7 @@ static int TestevalobjvObjCmd( TCL_UNUSED(void *), Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ + size_t objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { int evalGlobal; @@ -2175,7 +2183,7 @@ static int TesteventObjCmd( TCL_UNUSED(void *), Tcl_Interp *interp, /* Tcl interpreter */ - int objc, /* Parameter count */ + size_t objc, /* Parameter count */ Tcl_Obj *const objv[]) /* Parameter vector */ { static const char *const subcommands[] = { /* Possible subcommands */ @@ -2473,7 +2481,7 @@ static int TestexprlongobjCmd( TCL_UNUSED(void *), Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ + size_t objc, /* Number of arguments. */ Tcl_Obj *const *objv) /* Argument objects. */ { long exprResult; @@ -2559,7 +2567,7 @@ static int TestexprdoubleobjCmd( TCL_UNUSED(void *), Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ + size_t objc, /* Number of arguments. */ Tcl_Obj *const *objv) /* Argument objects. */ { double exprResult; @@ -2633,7 +2641,7 @@ static int TestfilelinkCmd( TCL_UNUSED(void *), Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ + size_t objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* The argument objects. */ { Tcl_Obj *contents; @@ -3286,7 +3294,7 @@ static int TestlinkarrayCmd( TCL_UNUSED(void *), Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ + size_t objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { static const char *LinkOption[] = { @@ -3305,7 +3313,8 @@ TestlinkarrayCmd( TCL_LINK_FLOAT, TCL_LINK_DOUBLE, TCL_LINK_STRING, TCL_LINK_CHARS, TCL_LINK_BINARY }; - int optionIndex, typeIndex, readonly, i, size, length; + int optionIndex, typeIndex, readonly, size, length; + size_t i; char *name, *arg; Tcl_WideInt addr; @@ -3404,7 +3413,7 @@ static int TestlocaleCmd( TCL_UNUSED(void *), Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ + size_t objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* The argument objects. */ { int index; @@ -3490,7 +3499,7 @@ static int TestparserObjCmd( TCL_UNUSED(void *), Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ + size_t objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* The argument objects. */ { const char *script; @@ -3546,7 +3555,7 @@ static int TestexprparserObjCmd( TCL_UNUSED(void *), Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ + size_t objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* The argument objects. */ { const char *script; @@ -3694,7 +3703,7 @@ static int TestparsevarObjCmd( TCL_UNUSED(void *), Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ + size_t objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* The argument objects. */ { const char *value, *name, *termPtr; @@ -3735,7 +3744,7 @@ static int TestparsevarnameObjCmd( TCL_UNUSED(void *), Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ + size_t objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* The argument objects. */ { const char *script; @@ -3798,7 +3807,7 @@ static int TestpreferstableObjCmd( TCL_UNUSED(void *), Tcl_Interp *interp, /* Current interpreter. */ - TCL_UNUSED(int) /*objc*/, + TCL_UNUSED(size_t) /*objc*/, TCL_UNUSED(Tcl_Obj *const *) /*objv*/) { Interp *iPtr = (Interp *) interp; @@ -3828,7 +3837,7 @@ static int TestprintObjCmd( TCL_UNUSED(void *), Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ + size_t objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* The argument objects. */ { Tcl_WideInt argv1 = 0; @@ -3869,10 +3878,11 @@ static int TestregexpObjCmd( TCL_UNUSED(void *), Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ + size_t objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - int i, ii, indices, stringLength, match, about; + int ii, indices, stringLength, match, about; + size_t i; int hasxflags, cflags, eflags; Tcl_RegExp regExpr; const char *string; @@ -3941,7 +3951,7 @@ TestregexpObjCmd( } endOfForLoop: - if (objc - i < hasxflags + 2 - about) { + if (objc + about < hasxflags + i + 2) { Tcl_WrongNumArgs(interp, 1, objv, "?-switch ...? exp string ?matchVar? ?subMatchVar ...?"); return TCL_ERROR; @@ -4192,7 +4202,7 @@ static int TestreturnObjCmd( TCL_UNUSED(void *), TCL_UNUSED(Tcl_Interp *), - TCL_UNUSED(int) /*objc*/, + TCL_UNUSED(size_t) /*objc*/, TCL_UNUSED(Tcl_Obj *const *) /*objv*/) { return TCL_RETURN; @@ -4516,7 +4526,7 @@ static int TestsetobjerrorcodeCmd( TCL_UNUSED(void *), Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ + size_t objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* The argument objects. */ { Tcl_SetObjErrorCode(interp, Tcl_ConcatObj(objc - 1, objv + 1)); @@ -4635,10 +4645,11 @@ static int TestfileCmd( TCL_UNUSED(void *), Tcl_Interp *interp, /* Current interpreter. */ - int argc, /* Number of arguments. */ + size_t argc, /* Number of arguments. */ Tcl_Obj *const argv[]) /* The argument objects. */ { - int force, i, j, result; + int force, result; + size_t i, j; Tcl_Obj *error = NULL; const char *subcmd; @@ -4717,7 +4728,7 @@ static int TestgetvarfullnameCmd( TCL_UNUSED(void *), Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ + size_t objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* The argument objects. */ { const char *name, *arg; @@ -4791,7 +4802,7 @@ static int GetTimesObjCmd( TCL_UNUSED(void *), Tcl_Interp *interp, /* The current interpreter. */ - TCL_UNUSED(int) /*cobjc*/, + TCL_UNUSED(size_t) /*cobjc*/, TCL_UNUSED(Tcl_Obj *const *) /*cobjv*/) { Interp *iPtr = (Interp *) interp; @@ -4997,7 +5008,7 @@ static int NoopObjCmd( TCL_UNUSED(void *), TCL_UNUSED(Tcl_Interp *), - TCL_UNUSED(int) /*objc*/, + TCL_UNUSED(size_t) /*objc*/, TCL_UNUSED(Tcl_Obj *const *) /*objv*/) { return TCL_OK; @@ -5022,7 +5033,7 @@ static int TeststringbytesObjCmd( TCL_UNUSED(void *), Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ + size_t objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* The argument objects. */ { int n; @@ -5062,7 +5073,7 @@ static int TestpurebytesobjObjCmd( TCL_UNUSED(void *), Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ + size_t objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* The argument objects. */ { Tcl_Obj *objPtr; @@ -5109,7 +5120,7 @@ static int TestsetbytearraylengthObjCmd( TCL_UNUSED(void *), Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ + size_t objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* The argument objects. */ { int n; @@ -5153,7 +5164,7 @@ static int TestbytestringObjCmd( TCL_UNUSED(void *), Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ + size_t objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* The argument objects. */ { size_t n = 0; @@ -5275,7 +5286,7 @@ static int TestsaveresultCmd( TCL_UNUSED(void *), Tcl_Interp *interp,/* Current interpreter. */ - int objc, /* Number of arguments. */ + size_t objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* The argument objects. */ { Interp* iPtr = (Interp*) interp; @@ -6318,10 +6329,11 @@ static int TestWrongNumArgsObjCmd( TCL_UNUSED(void *), Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ + size_t objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - int i, length; + Tcl_WideInt i; + int length; const char *msg; if (objc < 3) { @@ -6333,7 +6345,7 @@ TestWrongNumArgsObjCmd( return TCL_ERROR; } - if (Tcl_GetIntFromObj(interp, objv[1], &i) != TCL_OK) { + if (Tcl_GetWideIntFromObj(interp, objv[1], &i) != TCL_OK) { return TCL_ERROR; } @@ -6342,7 +6354,7 @@ TestWrongNumArgsObjCmd( msg = NULL; } - if (i > objc - 3) { + if ((size_t)i + 3 > objc) { /* * Asked for more arguments than were given. */ @@ -6374,7 +6386,7 @@ static int TestGetIndexFromObjStructObjCmd( TCL_UNUSED(void *), Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ + size_t objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { const char *const ary[] = { @@ -6436,7 +6448,7 @@ static int TestFilesystemObjCmd( TCL_UNUSED(void *), Tcl_Interp *interp, - int objc, + size_t objc, Tcl_Obj *const objv[]) { int res, boolVal; @@ -6807,7 +6819,7 @@ static int TestSimpleFilesystemObjCmd( TCL_UNUSED(void *), Tcl_Interp *interp, - int objc, + size_t objc, Tcl_Obj *const objv[]) { int res, boolVal; @@ -6969,7 +6981,7 @@ static int TestUtfNextCmd( TCL_UNUSED(void *), Tcl_Interp *interp, - int objc, + size_t objc, Tcl_Obj *const objv[]) { int numBytes; @@ -7030,7 +7042,7 @@ static int TestUtfPrevCmd( TCL_UNUSED(void *), Tcl_Interp *interp, - int objc, + size_t objc, Tcl_Obj *const objv[]) { int numBytes, offset; @@ -7070,7 +7082,7 @@ static int TestNumUtfCharsCmd( TCL_UNUSED(void *), Tcl_Interp *interp, - int objc, + size_t objc, Tcl_Obj *const objv[]) { if (objc > 1) { @@ -7099,7 +7111,7 @@ static int TestFindFirstCmd( TCL_UNUSED(void *), Tcl_Interp *interp, - int objc, + size_t objc, Tcl_Obj *const objv[]) { if (objc > 1) { @@ -7121,7 +7133,7 @@ static int TestFindLastCmd( TCL_UNUSED(void *), Tcl_Interp *interp, - int objc, + size_t objc, Tcl_Obj *const objv[]) { if (objc > 1) { @@ -7139,7 +7151,7 @@ static int TestGetIntForIndexCmd( TCL_UNUSED(void *), Tcl_Interp *interp, - int objc, + size_t objc, Tcl_Obj *const objv[]) { int result; @@ -7190,7 +7202,7 @@ static int TestcpuidCmd( TCL_UNUSED(void *), Tcl_Interp* interp, /* Tcl interpreter */ - int objc, /* Parameter count */ + size_t objc, /* Parameter count */ Tcl_Obj *const * objv) /* Parameter vector */ { int status, index, i; @@ -7226,7 +7238,7 @@ static int TestHashSystemHashCmd( TCL_UNUSED(void *), Tcl_Interp *interp, - int objc, + size_t objc, Tcl_Obj *const objv[]) { static const Tcl_HashKeyType hkType = { @@ -7371,7 +7383,7 @@ static int TestNREUnwind( TCL_UNUSED(void *), Tcl_Interp *interp, - TCL_UNUSED(int) /*objc*/, + TCL_UNUSED(size_t) /*objc*/, TCL_UNUSED(Tcl_Obj *const *) /*objv*/) { /* @@ -7389,7 +7401,7 @@ static int TestNRELevels( TCL_UNUSED(void *), Tcl_Interp *interp, - TCL_UNUSED(int) /*objc*/, + TCL_UNUSED(size_t) /*objc*/, TCL_UNUSED(Tcl_Obj *const *) /*objv*/) { Interp *iPtr = (Interp *) interp; @@ -7735,7 +7747,7 @@ static int TestgetencpathObjCmd( TCL_UNUSED(void *), Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ + size_t objc, /* Number of arguments. */ Tcl_Obj *const *objv) /* Argument strings. */ { if (objc != 1) { @@ -7768,7 +7780,7 @@ static int TestsetencpathObjCmd( TCL_UNUSED(void *), Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ + size_t objc, /* Number of arguments. */ Tcl_Obj *const *objv) /* Argument strings. */ { if (objc != 2) { @@ -7802,7 +7814,7 @@ static int TestparseargsCmd( TCL_UNUSED(void *), Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ + size_t objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Arguments. */ { static int foo = 0; @@ -8041,7 +8053,7 @@ static int TestInterpResolverCmd( TCL_UNUSED(void *), Tcl_Interp *interp, - int objc, + size_t objc, Tcl_Obj *const objv[]) { static const char *const table[] = { diff --git a/generic/tclTestObj.c b/generic/tclTestObj.c index 223eb98..52bbff8 100644 --- a/generic/tclTestObj.c +++ b/generic/tclTestObj.c @@ -42,14 +42,14 @@ static int CheckIfVarUnset(Tcl_Interp *interp, Tcl_Obj **varPtr, size_t varInde static int GetVariableIndex(Tcl_Interp *interp, 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; -static Tcl_ObjCmdProc TestindexobjCmd; -static Tcl_ObjCmdProc TestintobjCmd; -static Tcl_ObjCmdProc TestlistobjCmd; -static Tcl_ObjCmdProc TestobjCmd; -static Tcl_ObjCmdProc TeststringobjCmd; +static Tcl_ObjCmdProc2 TestbignumobjCmd; +static Tcl_ObjCmdProc2 TestbooleanobjCmd; +static Tcl_ObjCmdProc2 TestdoubleobjCmd; +static Tcl_ObjCmdProc2 TestindexobjCmd; +static Tcl_ObjCmdProc2 TestintobjCmd; +static Tcl_ObjCmdProc2 TestlistobjCmd; +static Tcl_ObjCmdProc2 TestobjCmd; +static Tcl_ObjCmdProc2 TeststringobjCmd; #define VARPTR_KEY "TCLOBJTEST_VARPTR" #define NUMBER_OF_OBJECT_VARS 20 @@ -110,20 +110,20 @@ TclObjTest_Init( varPtr[i] = NULL; } - Tcl_CreateObjCommand(interp, "testbignumobj", TestbignumobjCmd, + Tcl_CreateObjCommand2(interp, "testbignumobj", TestbignumobjCmd, NULL, NULL); - Tcl_CreateObjCommand(interp, "testbooleanobj", TestbooleanobjCmd, + Tcl_CreateObjCommand2(interp, "testbooleanobj", TestbooleanobjCmd, NULL, NULL); - Tcl_CreateObjCommand(interp, "testdoubleobj", TestdoubleobjCmd, + Tcl_CreateObjCommand2(interp, "testdoubleobj", TestdoubleobjCmd, NULL, NULL); - Tcl_CreateObjCommand(interp, "testintobj", TestintobjCmd, + Tcl_CreateObjCommand2(interp, "testintobj", TestintobjCmd, NULL, NULL); - Tcl_CreateObjCommand(interp, "testindexobj", TestindexobjCmd, + Tcl_CreateObjCommand2(interp, "testindexobj", TestindexobjCmd, NULL, NULL); - Tcl_CreateObjCommand(interp, "testlistobj", TestlistobjCmd, + Tcl_CreateObjCommand2(interp, "testlistobj", TestlistobjCmd, NULL, NULL); - Tcl_CreateObjCommand(interp, "testobj", TestobjCmd, NULL, NULL); - Tcl_CreateObjCommand(interp, "teststringobj", TeststringobjCmd, + Tcl_CreateObjCommand2(interp, "testobj", TestobjCmd, NULL, NULL); + Tcl_CreateObjCommand2(interp, "teststringobj", TeststringobjCmd, NULL, NULL); return TCL_OK; } @@ -150,7 +150,7 @@ static int TestbignumobjCmd( TCL_UNUSED(void *), Tcl_Interp *interp, /* Tcl interpreter */ - int objc, /* Argument count */ + size_t objc, /* Argument count */ Tcl_Obj *const objv[]) /* Argument vector */ { const char *const subcmds[] = { @@ -349,7 +349,7 @@ static int TestbooleanobjCmd( TCL_UNUSED(void *), Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ + size_t objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { size_t varIndex; @@ -449,7 +449,7 @@ static int TestdoubleobjCmd( TCL_UNUSED(void *), Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ + size_t objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { size_t varIndex; @@ -565,10 +565,11 @@ static int TestindexobjCmd( TCL_UNUSED(void *), Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ + size_t objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - int allowAbbrev, index, setError, i, result; + int allowAbbrev, index, setError, result; + size_t i; Tcl_WideInt index2; const char **argv; static const char *const tablePtr[] = {"a", "b", "check", NULL}; @@ -655,7 +656,7 @@ static int TestintobjCmd( TCL_UNUSED(void *), Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ + size_t objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { size_t varIndex; @@ -854,7 +855,7 @@ static int TestlistobjCmd( TCL_UNUSED(void *), Tcl_Interp *interp, /* Tcl interpreter */ - int objc, /* Number of arguments */ + size_t objc, /* Number of arguments */ Tcl_Obj *const objv[]) /* Argument objects */ { /* Subcommands supported by this command */ @@ -948,7 +949,7 @@ static int TestobjCmd( TCL_UNUSED(void *), Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ + size_t objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { size_t varIndex, destIndex; @@ -1151,12 +1152,12 @@ static int TeststringobjCmd( TCL_UNUSED(void *), Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ + size_t objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { unsigned short *unicode; - size_t varIndex; - int size, option, i; + size_t varIndex, i; + int size, option; Tcl_WideInt length; #define MAX_STRINGS 11 const char *string, *strings[MAX_STRINGS+1]; diff --git a/generic/tclTrace.c b/generic/tclTrace.c index c8f10e3..d84e183 100644 --- a/generic/tclTrace.c +++ b/generic/tclTrace.c @@ -2121,6 +2121,50 @@ TraceVarProc( *---------------------------------------------------------------------- */ +typedef struct { + Tcl_CmdObjTraceProc2 *proc; + Tcl_CmdObjTraceDeleteProc *delProc; + void *clientData; +} TraceWrapper; + +static int wrapperProc2( + void *clientData, + Tcl_Interp *interp, + int level, + const char *command, + Tcl_Command commandInfo, + int objc, + struct Tcl_Obj *const objv[]) +{ + TraceWrapper *wrapper = (TraceWrapper *)clientData; + return wrapper->proc(wrapper->clientData, interp, level, command, commandInfo, objc, objv); +} + +static void wrapperDelProc2(void *clientData) +{ + TraceWrapper *wrapper = (TraceWrapper *)clientData; + clientData = wrapper->clientData; + wrapper->delProc(clientData); + Tcl_Free(wrapper); +} + +Tcl_Trace +Tcl_CreateObjTrace2( + Tcl_Interp *interp, /* Tcl interpreter */ + int level, /* Maximum nesting level */ + int flags, /* Flags, see above */ + Tcl_CmdObjTraceProc2 *proc, /* Trace callback */ + void *clientData, /* Client data for the callback */ + Tcl_CmdObjTraceDeleteProc *delProc) + /* Function to call when trace is deleted */ +{ + TraceWrapper *wrapper = (TraceWrapper *)Tcl_Alloc(sizeof(TraceWrapper)); + wrapper->proc = proc; + wrapper->delProc = delProc; + wrapper->clientData = clientData; + return Tcl_CreateObjTrace(interp, level, flags, wrapperProc2, wrapper, wrapperDelProc2); +} + Tcl_Trace Tcl_CreateObjTrace( Tcl_Interp *interp, /* Tcl interpreter */ -- cgit v0.12 From d4181179bc599205f6114102403ebf49656ec03f Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 2 Jun 2022 12:10:50 +0000 Subject: typo --- generic/tclTest.c | 2 +- tests-perf/clock.perf.tcl | 2 +- tests-perf/test-performance.tcl | 2 +- 3 files changed, 3 insertions(+), 3 deletions(-) diff --git a/generic/tclTest.c b/generic/tclTest.c index 8f12715..88e32bc 100644 --- a/generic/tclTest.c +++ b/generic/tclTest.c @@ -4169,7 +4169,7 @@ TestsetplatformCmd( * A standard Tcl result. * * Side effects: - * When the packge given by argv[1] is loaded into an interpeter, + * When the packge given by argv[1] is loaded into an interpreter, * variable "x" in that interpreter is set to "loaded". * *---------------------------------------------------------------------- diff --git a/tests-perf/clock.perf.tcl b/tests-perf/clock.perf.tcl index c0da0ab..35fe219 100644 --- a/tests-perf/clock.perf.tcl +++ b/tests-perf/clock.perf.tcl @@ -32,7 +32,7 @@ namespace path {::tclTestPerf} ## set testing defaults: set ::env(TCL_TZ) :CET -# warm-up interpeter compiler env, clock platform-related features: +# warm-up interpreter compiler env, clock platform-related features: ## warm-up test-related features (load clock.tcl, system zones, locales, etc.): clock scan "" -gmt 1 diff --git a/tests-perf/test-performance.tcl b/tests-perf/test-performance.tcl index a715c8a..749e85e 100644 --- a/tests-perf/test-performance.tcl +++ b/tests-perf/test-performance.tcl @@ -16,7 +16,7 @@ # namespace eval ::tclTestPerf { -# warm-up interpeter compiler env, calibrate timerate measurement functionality: +# warm-up interpreter compiler env, calibrate timerate measurement functionality: # if no timerate here - import from unsupported: if {[namespace which -command timerate] eq {}} { -- cgit v0.12 From 08e46d1fd595ff2b9cb385169d90601c8b37fbf4 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 2 Jun 2022 15:01:39 +0000 Subject: More int -> size_t, in regexp handling (should of been part of TIP #537/494) --- generic/regc_cvec.c | 12 ++++++------ generic/regc_nfa.c | 36 ++++++++++++++++++------------------ generic/regcomp.c | 16 ++++++++-------- generic/rege_dfa.c | 39 ++++++++++++++++++++------------------- generic/regexec.c | 24 ++++++++++++------------ generic/regguts.h | 32 ++++++++++++++++---------------- 6 files changed, 80 insertions(+), 79 deletions(-) diff --git a/generic/regc_cvec.c b/generic/regc_cvec.c index 3b4f1e4..dc699cf 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/regc_nfa.c b/generic/regc_nfa.c index f676a45..94a9f99 100644 --- a/generic/regc_nfa.c +++ b/generic/regc_nfa.c @@ -108,7 +108,7 @@ freenfa( } nfa->slast = NULL; - nfa->nstates = -1; + nfa->nstates = FREESTATE; nfa->pre = NULL; nfa->post = NULL; FREE(nfa); @@ -143,7 +143,7 @@ newstate( s->noas = 0; } - assert(nfa->nstates >= 0); + assert(nfa->nstates != FREESTATE); s->no = nfa->nstates++; s->flag = 0; if (nfa->states == NULL) { @@ -2494,7 +2494,7 @@ clonesuccessorstates( struct arc * refarc, char *curdonemap, char *outerdonemap, - int nstates) + size_t nstates) { char *donemap; struct arc *a; @@ -2691,7 +2691,7 @@ cleanup( { struct state *s; struct state *nexts; - int n; + size_t n; /* * Clear out unreachable or dead-end states. Use pre to mark reachable, @@ -2847,7 +2847,7 @@ compact( ca = cnfa->arcs; for (s = nfa->states; s != NULL; s = s->next) { - assert((size_t) s->no < nstates); + assert(s->no < nstates); cnfa->stflags[s->no] = 0; cnfa->states[s->no] = ca; first = ca; @@ -2951,10 +2951,10 @@ dumpnfa( { #ifdef REG_DEBUG struct state *s; - int nstates = 0; - int narcs = 0; + size_t nstates = 0; + size_t narcs = 0; - fprintf(f, "pre %d, post %d", nfa->pre->no, nfa->post->no); + fprintf(f, "pre %" TCL_Z_MODIFIER "u, post %" TCL_Z_MODIFIER "u", nfa->pre->no, nfa->post->no); if (nfa->bos[0] != COLORLESS) { fprintf(f, ", bos [%ld]", (long) nfa->bos[0]); } @@ -2973,7 +2973,7 @@ dumpnfa( nstates++; narcs += s->nouts; } - fprintf(f, "total of %d states, %d arcs\n", nstates, narcs); + fprintf(f, "total of %" TCL_Z_MODIFIER "u states, %" TCL_Z_MODIFIER "u arcs\n", nstates, narcs); if (nfa->parent == NULL) { dumpcolors(nfa->cm, f); } @@ -3000,7 +3000,7 @@ dumpstate( { struct arc *a; - fprintf(f, "%d%s%c", s->no, (s->tmp != NULL) ? "T" : "", + fprintf(f, "%" TCL_Z_MODIFIER "u%s%c", s->no, (s->tmp != NULL) ? "T" : "", (s->flag) ? s->flag : '.'); if (s->prev != NULL && s->prev->next != s) { fprintf(f, "\tstate chain bad\n"); @@ -3013,7 +3013,7 @@ dumpstate( fflush(f); for (a = s->ins; a != NULL; a = a->inchain) { if (a->to != s) { - fprintf(f, "\tlink from %d to %d on %d's in-chain\n", + fprintf(f, "\tlink from %" TCL_Z_MODIFIER "u to %" TCL_Z_MODIFIER "u on %" TCL_Z_MODIFIER "u's in-chain\n", a->from->no, a->to->no, s->no); } } @@ -3091,7 +3091,7 @@ dumparc( break; } if (a->from != s) { - fprintf(f, "?%d?", a->from->no); + fprintf(f, "?%" TCL_Z_MODIFIER "u?", a->from->no); } for (ab = &a->from->oas; ab != NULL; ab = ab->next) { for (aa = &ab->a[0]; aa < &ab->a[ABSIZE]; aa++) { @@ -3111,7 +3111,7 @@ dumparc( fprintf(f, "NULL"); return; } - fprintf(f, "%d", a->to->no); + fprintf(f, "%" TCL_Z_MODIFIER "u", a->to->no); for (aa = a->to->ins; aa != NULL; aa = aa->inchain) { if (aa == a) { break; /* NOTE BREAK OUT */ @@ -3137,9 +3137,9 @@ dumpcnfa( FILE *f) { #ifdef REG_DEBUG - int st; + size_t st; - fprintf(f, "pre %d, post %d", cnfa->pre, cnfa->post); + fprintf(f, "pre %" TCL_Z_MODIFIER "u, post %" TCL_Z_MODIFIER "u", cnfa->pre, cnfa->post); if (cnfa->bos[0] != COLORLESS) { fprintf(f, ", bos [%ld]", (long) cnfa->bos[0]); } @@ -3182,15 +3182,15 @@ dumpcstate( FILE *f) { struct carc *ca; - int pos; + size_t pos; fprintf(f, "%d%s", st, (cnfa->stflags[st] & CNFA_NOPROGRESS) ? ":" : "."); pos = 1; for (ca = cnfa->states[st]; ca->co != COLORLESS; ca++) { if (ca->co < cnfa->ncolors) { - fprintf(f, "\t[%ld]->%d", (long) ca->co, ca->to); + fprintf(f, "\t[%d]->%" TCL_Z_MODIFIER "u", ca->co, ca->to); } else { - fprintf(f, "\t:%ld:->%d", (long) (ca->co - cnfa->ncolors), ca->to); + fprintf(f, "\t:%d:->%" TCL_Z_MODIFIER "u", ca->co - cnfa->ncolors, ca->to); } if (pos == 5) { fprintf(f, "\n"); diff --git a/generic/regcomp.c b/generic/regcomp.c index 103c0bf..9ecc8c6 100644 --- a/generic/regcomp.c +++ b/generic/regcomp.c @@ -156,7 +156,7 @@ static void fixconstraintloops(struct nfa *, FILE *); static int findconstraintloop(struct nfa *, struct state *); static void breakconstraintloop(struct nfa *, struct state *); static void clonesuccessorstates(struct nfa *, struct state *, struct state *, - struct state *, struct arc *, char *, char *, int); + struct state *, struct arc *, char *, char *, size_t); static void cleanup(struct nfa *); static void markreachable(struct nfa *, struct state *, struct state *, struct state *); static void markcanreach(struct nfa *, struct state *, struct state *, struct state *); @@ -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 *); @@ -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); } @@ -2047,7 +2047,7 @@ dump( { #ifdef REG_DEBUG struct guts *g; - int i; + size_t i; if (re->re_magic != REMAGIC) { fprintf(f, "bad magic number (0x%x not 0x%x)\n", @@ -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 %" TCL_Z_MODIFIER "u\n", re->re_nsub, re->re_info, g->ntree); dumpcolors(&g->cmap, f); @@ -2073,7 +2073,7 @@ dump( dumpcnfa(&g->search, f); } for (i = 1; i < g->nlacons; i++) { - fprintf(f, "\nla%d (%s):\n", i, + fprintf(f, "\nla%" TCL_Z_MODIFIER "u (%s):\n", i, (g->lacons[i].subno) ? "positive" : "negative"); dumpcnfa(&g->lacons[i].cnfa, f); } @@ -2145,7 +2145,7 @@ stdump( fprintf(f, "}"); } if (nfapresent) { - fprintf(f, " %ld-%ld", (long)t->begin->no, (long)t->end->no); + fprintf(f, " %" TCL_Z_MODIFIER "u-%" TCL_Z_MODIFIER "u", t->begin->no, t->end->no); } if (t->left != NULL) { fprintf(f, " L:%s", stid(t->left, idbuf, sizeof(idbuf))); diff --git a/generic/rege_dfa.c b/generic/rege_dfa.c index eddfea2..5d49aa5 100644 --- a/generic/rege_dfa.c +++ b/generic/rege_dfa.c @@ -47,7 +47,7 @@ longest( color co; struct sset *css, *ss; chr *post; - int i; + size_t i; struct colormap *cm = d->cm; /* @@ -292,7 +292,7 @@ lastCold( { struct sset *ss; chr *nopr = d->lastnopr; - int i; + size_t i; if (nopr == NULL) { nopr = v->start; @@ -319,7 +319,7 @@ newDFA( { struct dfa *d; size_t nss = cnfa->nstates * 2; - int wordsper = (cnfa->nstates + UBITS - 1) / UBITS; + size_t wordsper = (cnfa->nstates + UBITS - 1) / UBITS; struct smalldfa *smallwas = sml; assert(cnfa != NULL && cnfa->nstates != 0); @@ -442,7 +442,7 @@ initialize( chr *const start) { struct sset *ss; - int i; + size_t i; /* * Is previous one still there? @@ -492,7 +492,8 @@ miss( unsigned h; struct carc *ca; struct sset *p; - int i, isPost, noProgress, gotState, doLAConstraints, sawLAConstraints; + size_t i; + int isPost, noProgress, gotState, doLAConstraints, sawLAConstraints; /* * For convenience, we can be called even if it might not be a miss. @@ -526,7 +527,7 @@ miss( if (!(cnfa->stflags[ca->to] & CNFA_NOPROGRESS)) { noProgress = 0; } - FDEBUG(("%d -> %d\n", i, ca->to)); + FDEBUG(("%" TCL_Z_MODIFIER "u -> %" TCL_Z_MODIFIER "u\n", i, ca->to)); } } } @@ -556,7 +557,7 @@ miss( if (!(cnfa->stflags[ca->to] & CNFA_NOPROGRESS)) { noProgress = 0; } - FDEBUG(("%d :> %d\n", i, ca->to)); + FDEBUG(("%" TCL_Z_MODIFIER "u :> %" TCL_Z_MODIFIER"u\n", i, ca->to)); } } } @@ -615,7 +616,7 @@ checkLAConstraint( chr *const cp, const pcolor co) /* "color" of the lookahead constraint */ { - int n; + size_t n; struct subre *sub; struct dfa *d; struct smalldfa sd; @@ -623,7 +624,7 @@ checkLAConstraint( n = co - pcnfa->ncolors; assert(n < v->g->nlacons && v->g->lacons != NULL); - FDEBUG(("=== testing lacon %d\n", n)); + FDEBUG(("=== testing lacon %" TCL_Z_MODIFIER "u\n", n)); sub = &v->g->lacons[n]; d = newDFA(v, &sub->cnfa, &v->g->cmap, &sd); if (d == NULL) { @@ -632,7 +633,7 @@ checkLAConstraint( } end = longest(v, d, cp, v->stop, NULL); freeDFA(d); - FDEBUG(("=== lacon %d match %d\n", n, (end != NULL))); + FDEBUG(("=== lacon %" TCL_Z_MODIFIER "u match %d\n", n, (end != NULL))); return (sub->subno) ? (end != NULL) : (end == NULL); } @@ -738,21 +739,21 @@ pickNextSS( */ if (d->nssused < d->nssets) { - i = d->nssused; + size_t j = d->nssused; d->nssused++; - ss = &d->ssets[i]; - FDEBUG(("new c%d\n", i)); + ss = &d->ssets[j]; + FDEBUG(("new c%" TCL_Z_MODIFIER "u\n", j)); /* * Set up innards. */ - ss->states = &d->statesarea[i * d->wordsper]; + ss->states = &d->statesarea[j * d->wordsper]; ss->flags = 0; ss->ins.ss = NULL; ss->ins.co = WHITE; /* give it some value */ - ss->outs = &d->outsarea[i * d->ncolors]; - ss->inchain = &d->incarea[i * d->ncolors]; + ss->outs = &d->outsarea[j * d->ncolors]; + ss->inchain = &d->incarea[j * d->ncolors]; for (i = 0; i < d->ncolors; i++) { ss->outs[i] = NULL; ss->inchain[i].ss = NULL; @@ -764,7 +765,7 @@ pickNextSS( * Look for oldest, or old enough anyway. */ - if (cp - start > d->nssets*2/3) { /* oldest 33% are expendable */ + if ((size_t)(cp - start) > d->nssets*2/3) { /* oldest 33% are expendable */ ancient = cp - d->nssets*2/3; } else { ancient = start; @@ -773,7 +774,7 @@ pickNextSS( if ((ss->lastseen == NULL || ss->lastseen < ancient) && !(ss->flags&LOCKED)) { d->search = ss + 1; - FDEBUG(("replacing c%d\n", (int) (ss - d->ssets))); + FDEBUG(("replacing c%" TCL_Z_MODIFIER "u\n", (size_t)(ss - d->ssets))); return ss; } } @@ -781,7 +782,7 @@ pickNextSS( if ((ss->lastseen == NULL || ss->lastseen < ancient) && !(ss->flags&LOCKED)) { d->search = ss + 1; - FDEBUG(("replacing c%d\n", (int) (ss - d->ssets))); + FDEBUG(("replacing c%" TCL_Z_MODIFIER "u\n", (size_t)(ss - d->ssets))); return ss; } } diff --git a/generic/regexec.c b/generic/regexec.c index fdbdef0..f9d25ce 100644 --- a/generic/regexec.c +++ b/generic/regexec.c @@ -57,11 +57,12 @@ struct sset { /* state set */ }; struct dfa { - int nssets; /* size of cache */ - int nssused; /* how many entries occupied yet */ - int nstates; /* number of states */ + size_t nssets; /* size of cache */ + size_t nssused; /* how many entries occupied yet */ + size_t nstates; /* number of states */ + size_t wordsper; /* length of state-set bitvectors */ int ncolors; /* length of outarc and inchain vectors */ - int wordsper; /* length of state-set bitvectors */ + int cptsmalloced; /* were the areas individually malloced? */ struct sset *ssets; /* state-set cache */ unsigned *statesarea; /* bitvector storage */ unsigned *work; /* pointer to work area within statesarea */ @@ -72,7 +73,6 @@ struct dfa { chr *lastpost; /* location of last cache-flushed success */ chr *lastnopr; /* location of last cache-flushed NOPROGRESS */ struct sset *search; /* replacement-search-pointer memory */ - int cptsmalloced; /* were the areas individually malloced? */ char *mallocarea; /* self, or malloced area, or NULL */ }; @@ -545,8 +545,8 @@ zapallsubs( size_t i; for (i = n-1; i > 0; i--) { - p[i].rm_so = -1; - p[i].rm_eo = -1; + p[i].rm_so = FREESTATE; + p[i].rm_eo = FREESTATE; } } @@ -560,11 +560,11 @@ zaptreesubs( struct subre *const t) { if (t->op == '(') { - int n = t->subno; + size_t n = t->subno; assert(n > 0); - if ((size_t) n < v->nmatch) { - v->pmatch[n].rm_so = -1; - v->pmatch[n].rm_eo = -1; + if (n < v->nmatch) { + v->pmatch[n].rm_so = FREESTATE; + v->pmatch[n].rm_eo = FREESTATE; } } @@ -882,7 +882,7 @@ cbrdissect( MDEBUG(("cbackref n%d %d{%d-%d}\n", t->id, n, min, max)); /* get the backreferenced string */ - if (v->pmatch[n].rm_so == TCL_INDEX_NONE) { + if (v->pmatch[n].rm_so == FREESTATE) { return REG_NOMATCH; } brstring = v->start + v->pmatch[n].rm_so; diff --git a/generic/regguts.h b/generic/regguts.h index de5d18e..b9af7ac 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 */ }; @@ -242,19 +242,19 @@ struct arcbatch { /* for bulk allocation of arcs */ }; struct state { - int no; -#define FREESTATE (-1) + size_t no; +#define FREESTATE ((size_t)-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 { @@ -262,7 +262,7 @@ struct nfa { struct state *init; /* initial state */ struct state *final; /* final state */ struct state *post; /* post-final state */ - int nstates; /* for numbering states */ + size_t nstates; /* for numbering states */ struct state *states; /* state-chain header */ struct state *slast; /* tail of the chain */ struct state *free; /* free list */ @@ -290,16 +290,16 @@ struct nfa { struct carc { color co; /* COLORLESS is list terminator */ - int to; /* next-state number */ + size_t to; /* next-state number */ }; struct cnfa { - int nstates; /* number of states */ + size_t nstates; /* number of states */ int ncolors; /* number of colors */ int flags; #define HASLACONS 01 /* uses lookahead constraints */ - int pre; /* setup state number */ - int post; /* teardown state number */ + size_t pre; /* setup state number */ + size_t post; /* teardown state number */ color bos[2]; /* colors, if any, assigned to BOS and BOL */ color eos[2]; /* colors, if any, assigned to EOS and EOL */ char *stflags; /* vector of per-state flags bytes */ @@ -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 */ }; /* -- cgit v0.12 From 211f4f652248b5d40573bb51fbfe7ed687e5eded Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 2 Jun 2022 15:16:46 +0000 Subject: Missing "const" with -DREG_DEBUG=1 --- generic/regc_color.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/generic/regc_color.c b/generic/regc_color.c index 92e0aad..dc9f5b4 100644 --- a/generic/regc_color.c +++ b/generic/regc_color.c @@ -759,7 +759,7 @@ dumpcolors( struct colordesc *end; color co; chr c; - char *has; + const char *has; fprintf(f, "max %ld\n", (long) cm->max); if (NBYTS > 1) { -- cgit v0.12 From 345e120ec855d9f7d33f9715a2eecbceac2fafd2 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 3 Jun 2022 14:46:33 +0000 Subject: Undo part of previous commit: doesn't work as expected on Windows --- generic/tclCmdAH.c | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/generic/tclCmdAH.c b/generic/tclCmdAH.c index d2662b9..3bb9d6c 100644 --- a/generic/tclCmdAH.c +++ b/generic/tclCmdAH.c @@ -2334,17 +2334,17 @@ StoreStatData( * cast might fail when there isn't a real arithmetic 'long long' type... */ - STORE_ARY("dev", Tcl_NewWideIntObj(statPtr->st_dev)); + STORE_ARY("dev", Tcl_NewWideIntObj((long)statPtr->st_dev)); STORE_ARY("ino", Tcl_NewWideIntObj(statPtr->st_ino)); - STORE_ARY("nlink", Tcl_NewWideIntObj(statPtr->st_nlink)); - STORE_ARY("uid", Tcl_NewWideIntObj(statPtr->st_uid)); - STORE_ARY("gid", Tcl_NewWideIntObj(statPtr->st_gid)); + STORE_ARY("nlink", Tcl_NewWideIntObj((long)statPtr->st_nlink)); + STORE_ARY("uid", Tcl_NewWideIntObj((long)statPtr->st_uid)); + STORE_ARY("gid", Tcl_NewWideIntObj((long)statPtr->st_gid)); STORE_ARY("size", Tcl_NewWideIntObj(statPtr->st_size)); #ifdef HAVE_STRUCT_STAT_ST_BLOCKS STORE_ARY("blocks", Tcl_NewWideIntObj(statPtr->st_blocks)); #endif #ifdef HAVE_STRUCT_STAT_ST_BLKSIZE - STORE_ARY("blksize", Tcl_NewWideIntObj(statPtr->st_blksize)); + STORE_ARY("blksize", Tcl_NewWideIntObj((long)statPtr->st_blksize)); #endif STORE_ARY("atime", Tcl_NewWideIntObj(Tcl_GetAccessTimeFromStat(statPtr))); STORE_ARY("mtime", Tcl_NewWideIntObj(Tcl_GetModificationTimeFromStat(statPtr))); -- cgit v0.12 From a9a2d671a0cbd58a5b99815c650d92c3c652a602 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 7 Jun 2022 15:19:38 +0000 Subject: int -> size_t in (internal) Tcl_ResolveCompiledVarProc --- generic/tclInt.h | 2 +- generic/tclOOMethod.c | 2 +- generic/tclTest.c | 2 +- 3 files changed, 3 insertions(+), 3 deletions(-) diff --git a/generic/tclInt.h b/generic/tclInt.h index a36d0a1..b1bb0e6 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -171,7 +171,7 @@ typedef struct Tcl_ResolvedVarInfo { } Tcl_ResolvedVarInfo; typedef int (Tcl_ResolveCompiledVarProc)(Tcl_Interp *interp, - const char *name, int length, Tcl_Namespace *context, + const char *name, size_t length, Tcl_Namespace *context, Tcl_ResolvedVarInfo **rPtr); typedef int (Tcl_ResolveVarProc)(Tcl_Interp *interp, const char *name, diff --git a/generic/tclOOMethod.c b/generic/tclOOMethod.c index 300b8c7..43e991a 100644 --- a/generic/tclOOMethod.c +++ b/generic/tclOOMethod.c @@ -1102,7 +1102,7 @@ static int ProcedureMethodCompiledVarResolver( TCL_UNUSED(Tcl_Interp *), const char *varName, - int length, + size_t length, TCL_UNUSED(Tcl_Namespace *), Tcl_ResolvedVarInfo **rPtrPtr) { diff --git a/generic/tclTest.c b/generic/tclTest.c index dc1c0a9..6033fbf 100644 --- a/generic/tclTest.c +++ b/generic/tclTest.c @@ -8021,7 +8021,7 @@ static int InterpCompiledVarResolver( TCL_UNUSED(Tcl_Interp *), const char *name, - TCL_UNUSED(int) /*length*/, + TCL_UNUSED(size_t) /*length*/, TCL_UNUSED(Tcl_Namespace *), Tcl_ResolvedVarInfo **rPtr) { -- cgit v0.12 From 5a3a1ddfbc3970b48fd2855ca6b1265972eea1d1 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 8 Jun 2022 10:35:00 +0000 Subject: Undo unintended (internal) variable rename --- generic/tclAssembly.c | 12 ++++++------ generic/tclCompile.c | 2 +- generic/tclCompile.h | 2 +- generic/tclDisassemble.c | 6 +++--- 4 files changed, 11 insertions(+), 11 deletions(-) diff --git a/generic/tclAssembly.c b/generic/tclAssembly.c index 609958b..91abd9f 100644 --- a/generic/tclAssembly.c +++ b/generic/tclAssembly.c @@ -1940,7 +1940,7 @@ MoveExceptionRangesToBasicBlock( envPtr->exceptArrayPtr + savedExceptArrayNext, exceptionCount * sizeof(ExceptionRange)); for (i = 0; i < exceptionCount; ++i) { - curr_bb->foreignExceptions[i].nestingLevel1 -= envPtr->exceptDepth; + curr_bb->foreignExceptions[i].nestingLevel -= envPtr->exceptDepth; } envPtr->exceptArrayNext = savedExceptArrayNext; } @@ -4125,9 +4125,9 @@ StackFreshCatches( catchIndices[catchDepth] = TclCreateExceptRange(CATCH_EXCEPTION_RANGE, envPtr); range = envPtr->exceptArrayPtr + catchIndices[catchDepth]; - range->nestingLevel1 = envPtr->exceptDepth + catchDepth; + range->nestingLevel = envPtr->exceptDepth + catchDepth; envPtr->maxExceptDepth= - TclMax(range->nestingLevel1 + 1, envPtr->maxExceptDepth); + TclMax(range->nestingLevel + 1, envPtr->maxExceptDepth); range->codeOffset = bbPtr->startOffset; entryPtr = Tcl_FindHashEntry(&assemEnvPtr->labelHash, @@ -4187,11 +4187,11 @@ RestoreEmbeddedExceptionRanges( for (i = 0; i < bbPtr->foreignExceptionCount; ++i) { range = bbPtr->foreignExceptions + i; rangeIndex = TclCreateExceptRange(range->type, envPtr); - range->nestingLevel1 += envPtr->exceptDepth + bbPtr->catchDepth; + range->nestingLevel += envPtr->exceptDepth + bbPtr->catchDepth; memcpy(envPtr->exceptArrayPtr + rangeIndex, range, sizeof(ExceptionRange)); - if ((int)range->nestingLevel1 >= (int)envPtr->maxExceptDepth) { - envPtr->maxExceptDepth = range->nestingLevel1 + 1; + if ((int)range->nestingLevel >= (int)envPtr->maxExceptDepth) { + envPtr->maxExceptDepth = range->nestingLevel + 1; } } diff --git a/generic/tclCompile.c b/generic/tclCompile.c index 2209445..b0bf37c 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -3410,7 +3410,7 @@ TclCreateExceptRange( rangePtr = &envPtr->exceptArrayPtr[index]; rangePtr->type = type; - rangePtr->nestingLevel1 = envPtr->exceptDepth; + rangePtr->nestingLevel = envPtr->exceptDepth; rangePtr->codeOffset = TCL_INDEX_NONE; rangePtr->numCodeBytes = TCL_INDEX_NONE; rangePtr->breakOffset = TCL_INDEX_NONE; diff --git a/generic/tclCompile.h b/generic/tclCompile.h index 16d84bf..1b967cc 100644 --- a/generic/tclCompile.h +++ b/generic/tclCompile.h @@ -89,7 +89,7 @@ typedef enum { typedef struct { ExceptionRangeType type; /* The kind of ExceptionRange. */ - size_t nestingLevel1; /* Static depth of the exception range. Used + size_t nestingLevel; /* Static depth of the exception range. Used * to find the most deeply-nested range * surrounding a PC at runtime. */ size_t codeOffset; /* Offset of the first instruction byte of the diff --git a/generic/tclDisassemble.c b/generic/tclDisassemble.c index 572ac94..6fdc488 100644 --- a/generic/tclDisassemble.c +++ b/generic/tclDisassemble.c @@ -359,7 +359,7 @@ DisassembleByteCodeObj( Tcl_AppendPrintfToObj(bufferObj, " %d: level %" TCL_Z_MODIFIER "u, %s, pc %" TCL_Z_MODIFIER "u-%" TCL_Z_MODIFIER "u, ", - i, rangePtr->nestingLevel1, + i, rangePtr->nestingLevel, (rangePtr->type==LOOP_EXCEPTION_RANGE ? "loop" : "catch"), rangePtr->codeOffset, (rangePtr->codeOffset + rangePtr->numCodeBytes - 1)); @@ -1145,14 +1145,14 @@ DisassembleByteCodeAsDicts( case LOOP_EXCEPTION_RANGE: Tcl_ListObjAppendElement(NULL, exn, Tcl_ObjPrintf( "type %s level %" TCL_Z_MODIFIER "u from %" TCL_Z_MODIFIER "u to %" TCL_Z_MODIFIER "u break %" TCL_Z_MODIFIER "u continue %" TCL_Z_MODIFIER "u", - "loop", rangePtr->nestingLevel1, rangePtr->codeOffset, + "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 %" TCL_Z_MODIFIER "u from %" TCL_Z_MODIFIER "u to %" TCL_Z_MODIFIER "u catch %" TCL_Z_MODIFIER "u", - "catch", rangePtr->nestingLevel1, rangePtr->codeOffset, + "catch", rangePtr->nestingLevel, rangePtr->codeOffset, rangePtr->codeOffset + rangePtr->numCodeBytes - 1, rangePtr->catchOffset)); break; -- cgit v0.12 From fbca23e5cc86151579530b5a2b3cdf5e2b48b12e Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 9 Jun 2022 07:03:08 +0000 Subject: More (internal) int -> size_t, allowing values > 2^31 --- generic/tclAssembly.c | 10 +++++----- generic/tclBasic.c | 14 +++++++------- generic/tclCmdMZ.c | 2 +- generic/tclCompCmdsSZ.c | 33 +++++++++++++++++---------------- generic/tclCompile.c | 10 +++++----- generic/tclCompile.h | 4 ++-- generic/tclIOCmd.c | 16 ++++++++-------- generic/tclInt.h | 12 ++++++------ generic/tclOODefineCmds.c | 36 ++++++++++++++++++------------------ generic/tclParse.c | 18 +++++++++--------- generic/tclRegexp.c | 2 +- generic/tclTestObj.c | 2 +- 12 files changed, 80 insertions(+), 79 deletions(-) diff --git a/generic/tclAssembly.c b/generic/tclAssembly.c index 91abd9f..b7bfd2d 100644 --- a/generic/tclAssembly.c +++ b/generic/tclAssembly.c @@ -222,7 +222,7 @@ typedef struct AssemblyEnv { Tcl_HashTable labelHash; /* Hash table whose keys are labels and whose * values are 'label' objects storing the code * offsets of the labels. */ - int cmdLine; /* Current line number within the assembly + size_t cmdLine; /* Current line number within the assembly * code */ int* clNext; /* Invisible continuation line for * [info frame] */ @@ -1074,7 +1074,7 @@ TclAssembleCode( * Process the line of code. */ - if ((int)parsePtr->numWords > 0) { + if (parsePtr->numWords > 0) { size_t instLen = parsePtr->commandSize; /* Length in bytes of the current command */ @@ -3317,7 +3317,7 @@ CheckStack( { CompileEnv* envPtr = assemEnvPtr->envPtr; /* Compilation environment */ - int maxDepth; /* Maximum stack depth overall */ + size_t maxDepth; /* Maximum stack depth overall */ /* * Checking the head block will check all the other blocks recursively. @@ -3334,7 +3334,7 @@ CheckStack( */ maxDepth = assemEnvPtr->maxDepth + envPtr->currStackDepth; - if (maxDepth > (int)envPtr->maxStackDepth) { + if (maxDepth > envPtr->maxStackDepth) { envPtr->maxStackDepth = maxDepth; } @@ -4190,7 +4190,7 @@ RestoreEmbeddedExceptionRanges( range->nestingLevel += envPtr->exceptDepth + bbPtr->catchDepth; memcpy(envPtr->exceptArrayPtr + rangeIndex, range, sizeof(ExceptionRange)); - if ((int)range->nestingLevel >= (int)envPtr->maxExceptDepth) { + if (range->nestingLevel + 1 >= envPtr->maxExceptDepth + 1) { envPtr->maxExceptDepth = range->nestingLevel + 1; } } diff --git a/generic/tclBasic.c b/generic/tclBasic.c index 1e369a9..422445c 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -1782,7 +1782,7 @@ DeleteInterpProc( Tcl_HashSearch search; Tcl_HashTable *hTablePtr; ResolverScheme *resPtr, *nextResPtr; - int i; + size_t i; /* * Punt if there is an error in the Tcl_Release/Tcl_Preserve matchup, @@ -2012,7 +2012,7 @@ DeleteInterpProc( if (eclPtr->type == TCL_LOCATION_SOURCE) { Tcl_DecrRefCount(eclPtr->path); } - for (i=0; i< (int)eclPtr->nuloc; i++) { + for (i=0; inuloc; i++) { Tcl_Free(eclPtr->loc[i].line); } @@ -4994,7 +4994,7 @@ TclEvalEx( int flags, /* Collection of OR-ed bits that control the * evaluation of the script. Only * TCL_EVAL_GLOBAL is currently supported. */ - int line, /* The line the script starts on. */ + size_t line, /* The line the script starts on. */ int *clNextOuter, /* Information about an outer context for */ const char *outerScript) /* continuation line data. This is set only in * TclSubstTokens(), to properly handle @@ -5152,7 +5152,7 @@ TclEvalEx( parsePtr->commandStart - outerScript); gotParse = 1; - if ((int)parsePtr->numWords > 0) { + if (parsePtr->numWords > 0) { /* * TIP #280. Track lines within the words of the current * command. We use a separate pointer into the table of @@ -5160,7 +5160,7 @@ TclEvalEx( * per-command parsing. */ - int wordLine = line; + size_t wordLine = line; const char *wordStart = parsePtr->commandStart; int *wordCLNext = clNext; unsigned int objectsNeeded = 0; @@ -5459,7 +5459,7 @@ TclEvalEx( void TclAdvanceLines( - int *line, + size_t *line, const char *start, const char *end) { @@ -5494,7 +5494,7 @@ TclAdvanceLines( void TclAdvanceContinuations( - int *line, + size_t *line, int **clNextPtrPtr, int loc) { diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c index 7b8e92a..41cf3f9 100644 --- a/generic/tclCmdMZ.c +++ b/generic/tclCmdMZ.c @@ -5289,7 +5289,7 @@ TclListLines( Tcl_Obj *listObj, /* Pointer to obj holding a string with list * structure. Assumed to be valid. Assumed to * contain n elements. */ - int line, /* Line the list as a whole starts on. */ + size_t line, /* Line the list as a whole starts on. */ int n, /* #elements in lines */ int *lines, /* Array of line numbers, to fill. */ Tcl_Obj *const *elems) /* The list elems as Tcl_Obj*, in need of diff --git a/generic/tclCompCmdsSZ.c b/generic/tclCompCmdsSZ.c index 7c9b26f..cd1ca22 100644 --- a/generic/tclCompCmdsSZ.c +++ b/generic/tclCompCmdsSZ.c @@ -1519,11 +1519,12 @@ TclSubstCompile( const char *bytes, size_t numBytes, int flags, - int line, + size_t line, CompileEnv *envPtr) { Tcl_Token *endTokenPtr, *tokenPtr; - int breakOffset = 0, count = 0, bline = line; + int breakOffset = 0, count = 0; + size_t bline = line; Tcl_Parse parse; Tcl_InterpState state = NULL; @@ -1945,7 +1946,7 @@ TclCompileSwitchCmd( if (numWords == 1) { const char *bytes; size_t maxLen, numBytes; - int bline; /* TIP #280: line of the pattern/action list, + size_t bline; /* TIP #280: line of the pattern/action list, * and start of list for when tracking the * location. This list comes immediately after * the value we switch on. */ @@ -4072,14 +4073,14 @@ CompileAssociativeBinaryOpCmd( { DefineLineInformation; /* TIP #280 */ Tcl_Token *tokenPtr = parsePtr->tokenPtr; - int words; + size_t words; /* TODO: Consider support for compiling expanded args. */ - for (words=1 ; words<(int)parsePtr->numWords ; words++) { + for (words=1 ; wordsnumWords ; words++) { tokenPtr = TokenAfter(tokenPtr); CompileWord(envPtr, tokenPtr, interp, words); } - if ((int)parsePtr->numWords <= 2) { + if (parsePtr->numWords <= 2) { PushLiteral(envPtr, identity, -1); words++; } @@ -4175,7 +4176,7 @@ CompileComparisonOpCmd( return TCL_ERROR; } else { int tmpIndex = AnonymousLocal(envPtr); - int words; + size_t words; tokenPtr = TokenAfter(parsePtr->tokenPtr); CompileWord(envPtr, tokenPtr, interp, 1); @@ -4183,11 +4184,11 @@ CompileComparisonOpCmd( CompileWord(envPtr, tokenPtr, interp, 2); STORE(tmpIndex); TclEmitOpcode(instruction, envPtr); - for (words=3 ; words<(int)parsePtr->numWords ;) { + for (words=3 ; wordsnumWords ;) { LOAD(tmpIndex); tokenPtr = TokenAfter(tokenPtr); CompileWord(envPtr, tokenPtr, interp, words); - if (++words < (int)parsePtr->numWords) { + if (++words < parsePtr->numWords) { STORE(tmpIndex); } TclEmitOpcode(instruction, envPtr); @@ -4311,18 +4312,18 @@ TclCompilePowOpCmd( { DefineLineInformation; /* TIP #280 */ Tcl_Token *tokenPtr = parsePtr->tokenPtr; - int words; + size_t words; /* * This one has its own implementation because the ** operator is the only * one with right associativity. */ - for (words=1 ; words<(int)parsePtr->numWords ; words++) { + for (words=1 ; wordsnumWords ; words++) { tokenPtr = TokenAfter(tokenPtr); CompileWord(envPtr, tokenPtr, interp, words); } - if ((int)parsePtr->numWords <= 2) { + if (parsePtr->numWords <= 2) { PUSH("1"); words++; } @@ -4512,7 +4513,7 @@ TclCompileMinusOpCmd( { DefineLineInformation; /* TIP #280 */ Tcl_Token *tokenPtr = parsePtr->tokenPtr; - int words; + size_t words; /* TODO: Consider support for compiling expanded args. */ if (parsePtr->numWords == 1) { @@ -4522,7 +4523,7 @@ TclCompileMinusOpCmd( return TCL_ERROR; } - for (words=1 ; words<(int)parsePtr->numWords ; words++) { + for (words=1 ; wordsnumWords ; words++) { tokenPtr = TokenAfter(tokenPtr); CompileWord(envPtr, tokenPtr, interp, words); } @@ -4557,7 +4558,7 @@ TclCompileDivOpCmd( { DefineLineInformation; /* TIP #280 */ Tcl_Token *tokenPtr = parsePtr->tokenPtr; - int words; + size_t words; /* TODO: Consider support for compiling expanded args. */ if (parsePtr->numWords == 1) { @@ -4570,7 +4571,7 @@ TclCompileDivOpCmd( if (parsePtr->numWords == 2) { PUSH("1.0"); } - for (words=1 ; words<(int)parsePtr->numWords ; words++) { + for (words=1 ; wordsnumWords ; words++) { tokenPtr = TokenAfter(tokenPtr); CompileWord(envPtr, tokenPtr, interp, words); } diff --git a/generic/tclCompile.c b/generic/tclCompile.c index b0bf37c..77181ed 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -694,7 +694,7 @@ static void StartExpanding(CompileEnv *envPtr); */ static void EnterCmdWordData(ExtCmdLoc *eclPtr, size_t srcOffset, Tcl_Token *tokenPtr, const char *cmd, - size_t numWords, int line, int *clNext, int **lines, + size_t numWords, size_t line, int *clNext, int **lines, CompileEnv *envPtr); static void ReleaseCmdWordData(ExtCmdLoc *eclPtr); @@ -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; @@ -3287,15 +3287,15 @@ EnterCmdWordData( Tcl_Token *tokenPtr, const char *cmd, size_t numWords, - int line, + size_t line, int *clNext, int **wlines, CompileEnv *envPtr) { ECL *ePtr; const char *last; - size_t wordIdx; - int wordLine, *wwlines, *wordNext; + size_t wordIdx, wordLine; + int *wwlines, *wordNext; if (eclPtr->nuloc >= eclPtr->nloc) { /* diff --git a/generic/tclCompile.h b/generic/tclCompile.h index 1b967cc..f9e6b17 100644 --- a/generic/tclCompile.h +++ b/generic/tclCompile.h @@ -379,7 +379,7 @@ typedef struct CompileEnv { /* TIP #280 */ ExtCmdLoc *extCmdMapPtr; /* Extended command location information for * 'info frame'. */ - int line; /* First line of the script, based on the + size_t line; /* First line of the script, based on the * invoking context, then the line of the * command currently compiled. */ int atCmdStart; /* Flag to say whether an INST_START_CMD @@ -468,7 +468,7 @@ typedef struct ByteCode { size_t numCmdLocBytes; /* Number of bytes needed for encoded command * location information. */ size_t maxExceptDepth; /* Maximum nesting level of ExceptionRanges; - * -1 if no ranges were compiled. */ + * TCL_INDEX_NONE if no ranges were compiled. */ size_t maxStackDepth; /* Maximum number of stack elements needed to * execute the code. */ unsigned char *codeStart; /* Points to the first byte of the code. This diff --git a/generic/tclIOCmd.c b/generic/tclIOCmd.c index 4859178..d479813 100644 --- a/generic/tclIOCmd.c +++ b/generic/tclIOCmd.c @@ -280,7 +280,7 @@ Tcl_GetsObjCmd( Tcl_Obj *const objv[]) /* Argument objects. */ { Tcl_Channel chan; /* The channel to read from. */ - int lineLen; /* Length of line just read. */ + size_t lineLen; /* Length of line just read. */ int mode; /* Mode in which channel is opened. */ Tcl_Obj *linePtr, *chanObjPtr; int code = TCL_OK; @@ -303,7 +303,7 @@ Tcl_GetsObjCmd( TclChannelPreserve(chan); TclNewObj(linePtr); lineLen = Tcl_GetsObj(chan, linePtr); - if (lineLen < 0) { + if (lineLen == TCL_IO_FAILURE) { if (!Tcl_Eof(chan) && !Tcl_InputBlocked(chan)) { Tcl_DecrRefCount(linePtr); @@ -322,7 +322,7 @@ Tcl_GetsObjCmd( code = TCL_ERROR; goto done; } - lineLen = -1; + lineLen = TCL_IO_FAILURE; } if (objc == 3) { if (Tcl_ObjSetVar2(interp, objv[2], NULL, linePtr, @@ -330,7 +330,7 @@ Tcl_GetsObjCmd( code = TCL_ERROR; goto done; } - Tcl_SetObjResult(interp, Tcl_NewWideIntObj(lineLen)); + Tcl_SetObjResult(interp, Tcl_NewWideIntObj((Tcl_WideInt)((Tcl_WideUInt)(lineLen + 1U)) - 1)); } else { Tcl_SetObjResult(interp, linePtr); } @@ -365,8 +365,8 @@ Tcl_ReadObjCmd( { Tcl_Channel chan; /* The channel to read from. */ int newline, i; /* Discard newline at end? */ - int toRead; /* How many bytes to read? */ - int charactersRead; /* How many characters were read? */ + Tcl_WideInt toRead; /* How many bytes to read? */ + size_t charactersRead; /* How many characters were read? */ int mode; /* Mode in which channel is opened. */ Tcl_Obj *resultPtr, *chanObjPtr; @@ -416,7 +416,7 @@ Tcl_ReadObjCmd( toRead = -1; if (i < objc) { - if ((TclGetIntFromObj(interp, objv[i], &toRead) != TCL_OK) + if ((TclGetWideIntFromObj(NULL, objv[i], &toRead) != TCL_OK) || (toRead < 0)) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "expected non-negative integer but got \"%s\"", @@ -430,7 +430,7 @@ Tcl_ReadObjCmd( Tcl_IncrRefCount(resultPtr); TclChannelPreserve(chan); charactersRead = Tcl_ReadChars(chan, resultPtr, toRead, 0); - if (charactersRead < 0) { + if (charactersRead == TCL_IO_FAILURE) { /* * TIP #219. * Capture error messages put by the driver into the bypass area and diff --git a/generic/tclInt.h b/generic/tclInt.h index 6dac3ca..9caef63 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -2828,9 +2828,9 @@ MODULE_SCOPE void TclAppendBytesToByteArray(Tcl_Obj *objPtr, const unsigned char *bytes, size_t len); MODULE_SCOPE int TclNREvalCmd(Tcl_Interp *interp, Tcl_Obj *objPtr, int flags); -MODULE_SCOPE void TclAdvanceContinuations(int *line, int **next, +MODULE_SCOPE void TclAdvanceContinuations(size_t *line, int **next, int loc); -MODULE_SCOPE void TclAdvanceLines(int *line, const char *start, +MODULE_SCOPE void TclAdvanceLines(size_t *line, const char *start, const char *end); MODULE_SCOPE void TclArgumentEnter(Tcl_Interp *interp, Tcl_Obj *objv[], int objc, CmdFrame *cf); @@ -2886,7 +2886,7 @@ MODULE_SCOPE int TclFindDictElement(Tcl_Interp *interp, size_t *sizePtr, int *literalPtr); /* TIP #280 - Modified token based evaluation, with line information. */ MODULE_SCOPE int TclEvalEx(Tcl_Interp *interp, const char *script, - size_t numBytes, int flags, int line, + size_t numBytes, int flags, size_t line, int *clNextOuter, const char *outerScript); MODULE_SCOPE Tcl_ObjCmdProc TclFileAttrsCmd; MODULE_SCOPE Tcl_ObjCmdProc TclFileCopyCmd; @@ -3012,7 +3012,7 @@ MODULE_SCOPE Tcl_Obj * TclLindexList(Tcl_Interp *interp, MODULE_SCOPE Tcl_Obj * TclLindexFlat(Tcl_Interp *interp, Tcl_Obj *listPtr, size_t indexCount, Tcl_Obj *const indexArray[]); /* TIP #280 */ -MODULE_SCOPE void TclListLines(Tcl_Obj *listObj, int line, int n, +MODULE_SCOPE void TclListLines(Tcl_Obj *listObj, size_t line, int n, int *lines, Tcl_Obj *const *elems); MODULE_SCOPE Tcl_Obj * TclListObjCopy(Tcl_Interp *interp, Tcl_Obj *listPtr); MODULE_SCOPE Tcl_Obj * TclListObjRange(Tcl_Obj *listPtr, size_t fromIdx, @@ -3161,7 +3161,7 @@ MODULE_SCOPE int TclStringMatch(const char *str, size_t strLen, MODULE_SCOPE int TclStringMatchObj(Tcl_Obj *stringObj, Tcl_Obj *patternObj, int flags); MODULE_SCOPE void TclSubstCompile(Tcl_Interp *interp, const char *bytes, - size_t numBytes, int flags, int line, + size_t numBytes, int flags, size_t line, struct CompileEnv *envPtr); MODULE_SCOPE int TclSubstOptions(Tcl_Interp *interp, size_t numOpts, Tcl_Obj *const opts[], int *flagPtr); @@ -3169,7 +3169,7 @@ 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, - size_t count, int *tokensLeftPtr, int line, + size_t count, int *tokensLeftPtr, size_t 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/tclOODefineCmds.c b/generic/tclOODefineCmds.c index cb66206..42c9796 100644 --- a/generic/tclOODefineCmds.c +++ b/generic/tclOODefineCmds.c @@ -2326,7 +2326,7 @@ ClassFilterGet( Tcl_Obj *resultObj, *filterObj; size_t i; - if ((int)Tcl_ObjectContextSkippedArgs(context) != objc) { + if (Tcl_ObjectContextSkippedArgs(context) != (size_t)objc) { Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv, NULL); return TCL_ERROR; @@ -2360,7 +2360,7 @@ ClassFilterSet( size_t filterc; Tcl_Obj **filterv; - if ((int)Tcl_ObjectContextSkippedArgs(context) + 1 != objc) { + if (Tcl_ObjectContextSkippedArgs(context) + 1 != (size_t)objc) { Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv, "filterList"); return TCL_ERROR; @@ -2407,7 +2407,7 @@ ClassMixinGet( Class *mixinPtr; size_t i; - if ((int)Tcl_ObjectContextSkippedArgs(context) != objc) { + if (Tcl_ObjectContextSkippedArgs(context) != (size_t)objc) { Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv, NULL); return TCL_ERROR; @@ -2444,7 +2444,7 @@ ClassMixinSet( Tcl_Obj **mixinv; Class **mixins; - if ((int)Tcl_ObjectContextSkippedArgs(context) + 1 != objc) { + if (Tcl_ObjectContextSkippedArgs(context) + 1 != (size_t)objc) { Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv, "mixinList"); return TCL_ERROR; @@ -2513,7 +2513,7 @@ ClassSuperGet( Class *superPtr; size_t i; - if ((int)Tcl_ObjectContextSkippedArgs(context) != objc) { + if (Tcl_ObjectContextSkippedArgs(context) != (size_t)objc) { Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv, NULL); return TCL_ERROR; @@ -2550,7 +2550,7 @@ ClassSuperSet( Tcl_Obj **superv; Class **superclasses, *superPtr; - if ((int)Tcl_ObjectContextSkippedArgs(context) + 1 != objc) { + if (Tcl_ObjectContextSkippedArgs(context) + 1 != (size_t)objc) { Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv, "superclassList"); return TCL_ERROR; @@ -2680,7 +2680,7 @@ ClassVarsGet( Tcl_Obj *resultObj; size_t i; - if ((int)Tcl_ObjectContextSkippedArgs(context) != objc) { + if (Tcl_ObjectContextSkippedArgs(context) != (size_t)objc) { Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv, NULL); return TCL_ERROR; @@ -2721,11 +2721,11 @@ ClassVarsSet( Tcl_Obj *const *objv) { Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp); - int i; + size_t i; size_t varc; Tcl_Obj **varv; - if ((int)Tcl_ObjectContextSkippedArgs(context) + 1 != objc) { + if (Tcl_ObjectContextSkippedArgs(context) + 1 != (size_t)objc) { Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv, "filterList"); return TCL_ERROR; @@ -2744,7 +2744,7 @@ ClassVarsSet( return TCL_ERROR; } - for (i = 0; i < (int)varc; i++) { + for (i = 0; i < varc; i++) { const char *varName = TclGetString(varv[i]); if (strstr(varName, "::") != NULL) { @@ -2795,7 +2795,7 @@ ObjFilterGet( Tcl_Obj *resultObj, *filterObj; size_t i; - if ((int)Tcl_ObjectContextSkippedArgs(context) != objc) { + if (Tcl_ObjectContextSkippedArgs(context) != (size_t)objc) { Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv, NULL); return TCL_ERROR; @@ -2823,7 +2823,7 @@ ObjFilterSet( size_t filterc; Tcl_Obj **filterv; - if ((int)Tcl_ObjectContextSkippedArgs(context) + 1 != objc) { + if (Tcl_ObjectContextSkippedArgs(context) + 1 != (size_t)objc) { Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv, "filterList"); return TCL_ERROR; @@ -2864,7 +2864,7 @@ ObjMixinGet( Class *mixinPtr; size_t i; - if ((int)Tcl_ObjectContextSkippedArgs(context) != objc) { + if (Tcl_ObjectContextSkippedArgs(context) != (size_t)objc) { Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv, NULL); return TCL_ERROR; @@ -2892,12 +2892,12 @@ ObjMixinSet( Tcl_Obj *const *objv) { Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp); - int i; + size_t i; size_t mixinc; Tcl_Obj **mixinv; Class **mixins; - if ((int)Tcl_ObjectContextSkippedArgs(context) + 1 != objc) { + if (Tcl_ObjectContextSkippedArgs(context) + 1 != (size_t)objc) { Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv, "mixinList"); return TCL_ERROR; @@ -2912,7 +2912,7 @@ ObjMixinSet( mixins = (Class **)TclStackAlloc(interp, sizeof(Class *) * mixinc); - for (i = 0; i < (int)mixinc; i++) { + for (i = 0; i < mixinc; i++) { mixins[i] = GetClassInOuterContext(interp, mixinv[i], "may only mix in classes"); if (mixins[i] == NULL) { @@ -2949,7 +2949,7 @@ ObjVarsGet( Tcl_Obj *resultObj; size_t i; - if ((int)Tcl_ObjectContextSkippedArgs(context) != objc) { + if (Tcl_ObjectContextSkippedArgs(context) != (size_t)objc) { Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv, NULL); return TCL_ERROR; @@ -2987,7 +2987,7 @@ ObjVarsSet( size_t varc, i; Tcl_Obj **varv; - if ((int)Tcl_ObjectContextSkippedArgs(context) + 1 != objc) { + if (Tcl_ObjectContextSkippedArgs(context) + 1 != (size_t)objc) { Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv, "variableList"); return TCL_ERROR; diff --git a/generic/tclParse.c b/generic/tclParse.c index dc5ecac..bca1b0b 100644 --- a/generic/tclParse.c +++ b/generic/tclParse.c @@ -1707,7 +1707,7 @@ Tcl_ParseBraces( parsePtr->numTokens++; } TclGrowParseTokenArray(parsePtr, 2); - tokenPtr = &parsePtr->tokenPtr[(int)parsePtr->numTokens]; + tokenPtr = &parsePtr->tokenPtr[parsePtr->numTokens]; tokenPtr->type = TCL_TOKEN_BS; tokenPtr->start = src; tokenPtr->size = length; @@ -1978,7 +1978,7 @@ TclSubstParse( */ Tcl_Token *varTokenPtr = - parsePtr->tokenPtr + (int)parsePtr->numTokens - 2; + parsePtr->tokenPtr + 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[(int)parsePtr->numTokens]); + tokenPtr = &(parsePtr->tokenPtr[parsePtr->numTokens]); tokenPtr->start = parsePtr->term; tokenPtr->numComponents = 0; tokenPtr->type = TCL_TOKEN_COMMAND; @@ -2092,12 +2092,12 @@ TclSubstTokens( * errors. */ Tcl_Token *tokenPtr, /* Pointer to first in an array of tokens to * evaluate and concatenate. */ - size_t count1, /* Number of tokens to consider at tokenPtr. + size_t count, /* 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 * left to be substituted will be written */ - int line, /* The line the script starts on. */ + size_t line, /* The line the script starts on. */ int *clNextOuter, /* Information about an outer context for */ const char *outerScript) /* continuation line data. This is set by * EvalEx() to properly handle [...]-nested @@ -2119,11 +2119,11 @@ TclSubstTokens( Tcl_Obj *result; int code = TCL_OK; #define NUM_STATIC_POS 20 - int isLiteral, maxNumCL, numCL, i, adjust; + int isLiteral; + size_t i, maxNumCL, numCL, adjust; 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 @@ -2225,7 +2225,7 @@ TclSubstTokens( * Test cases: info-30.{6,8,9} */ - int theline; + size_t theline; TclAdvanceContinuations(&line, &clNextOuter, tokenPtr->start - outerScript); @@ -2450,7 +2450,7 @@ int Tcl_CommandComplete( const char *script) /* Script to check. */ { - return CommandComplete(script, (int) strlen(script)); + return CommandComplete(script, strlen(script)); } /* diff --git a/generic/tclRegexp.c b/generic/tclRegexp.c index afe96d9..5fe5412 100644 --- a/generic/tclRegexp.c +++ b/generic/tclRegexp.c @@ -155,7 +155,7 @@ Tcl_RegExpCompile( const char *pattern) /* String for which to produce compiled * regular expression. */ { - return (Tcl_RegExp) CompileRegexp(interp, pattern, (int) strlen(pattern), + return (Tcl_RegExp) CompileRegexp(interp, pattern, strlen(pattern), REG_ADVANCED); } diff --git a/generic/tclTestObj.c b/generic/tclTestObj.c index a85a002..68be8c7 100644 --- a/generic/tclTestObj.c +++ b/generic/tclTestObj.c @@ -1258,7 +1258,7 @@ TeststringobjCmd( Tcl_ConvertToType(NULL, varPtr[varIndex], Tcl_GetObjType("string")); strPtr = (String *)varPtr[varIndex]->internalRep.twoPtrValue.ptr1; - length = (int) strPtr->allocated; + length = strPtr->allocated; } else { length = -1; } -- cgit v0.12 From a383c56d6c81e21d403e98d4370ee370fe1882b0 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 9 Jun 2022 12:39:29 +0000 Subject: Doc tweak --- doc/CrtObjCmd.3 | 4 ++-- generic/tclBasic.c | 2 +- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/doc/CrtObjCmd.3 b/doc/CrtObjCmd.3 index 57834da..0490bd7 100644 --- a/doc/CrtObjCmd.3 +++ b/doc/CrtObjCmd.3 @@ -180,8 +180,8 @@ typedef void \fBTcl_CmdDeleteProc\fR( The \fIclientData\fR argument will be the same as the \fIclientData\fR argument passed to \fBTcl_CreateObjCommand\fR. .PP -\fBTcl_CreateObjCommand2\fR does the same as \fBTcl_CreateObjCommand2\fR, -except its \fIproc2\fR argument is of type \fBTcl_ObjCmdProc2\fR(. +\fBTcl_CreateObjCommand2\fR does the same as \fBTcl_CreateObjCommand\fR, +except its \fIproc2\fR argument is of type \fBTcl_ObjCmdProc2\fR. .PP .CS typedef int \fBTcl_ObjCmdProc2\fR( diff --git a/generic/tclBasic.c b/generic/tclBasic.c index a1a7db7..8aa8e44 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -3440,7 +3440,7 @@ static int cmdWrapper2Proc(void *clientData, { Command *cmdPtr = (Command *)clientData; if (objc > INT_MAX) { - Tcl_WrongNumArgs(interp, 1, objv, "?args?"); + Tcl_WrongNumArgs(interp, 1, objv, "?arg ...?"); return TCL_ERROR; } return cmdPtr->objProc(cmdPtr->objClientData, interp, objc, objv); -- cgit v0.12 From 8c311313a11ad2b7caa8a3626b03fb16da985df6 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 9 Jun 2022 13:45:10 +0000 Subject: Internal bug in Tcl_GetIndexFromObjStruct re-definition (works, as long as sizeof(struct) == sizeof(int)) --- generic/tclIndexObj.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/generic/tclIndexObj.c b/generic/tclIndexObj.c index 40aabce..78dd47e 100644 --- a/generic/tclIndexObj.c +++ b/generic/tclIndexObj.c @@ -364,7 +364,7 @@ Tcl_GetIndexFromObjStruct( } /* #define again, needed below */ #define Tcl_GetIndexFromObjStruct(interp, objPtr, tablePtr, offset, msg, flags, indexPtr) \ - ((Tcl_GetIndexFromObjStruct)((interp), (objPtr), (tablePtr), (offset), (msg), (flags)|(int)(sizeof(*(indexPtr))<<8), (indexPtr))) + ((Tcl_GetIndexFromObjStruct)((interp), (objPtr), (tablePtr), (offset), (msg), (flags)|(int)(sizeof(*(indexPtr))<<1), (indexPtr))) /* *---------------------------------------------------------------------- -- cgit v0.12 From 84be29734969e1c4a15df99cc315e4d192b3d9be Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 10 Jun 2022 20:21:45 +0000 Subject: Tcl_GetEncodingSearchPath() is available since Tcl 8.5 --- unix/dltest/pkgb.c | 14 +------------- 1 file changed, 1 insertion(+), 13 deletions(-) diff --git a/unix/dltest/pkgb.c b/unix/dltest/pkgb.c index d28036f..2d525bc 100644 --- a/unix/dltest/pkgb.c +++ b/unix/dltest/pkgb.c @@ -98,19 +98,7 @@ Pkgb_DemoObjCmd( int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { -#if (TCL_MAJOR_VERSION > 8) || (TCL_MINOR_VERSION > 4) - Tcl_Obj *first; - (void)dummy; - (void)objc; - (void)objv; - - if (Tcl_ListObjIndex(NULL, Tcl_GetEncodingSearchPath(), 0, &first) - == TCL_OK) { - Tcl_SetObjResult(interp, first); - } -#else - Tcl_SetObjResult(interp, Tcl_NewStringObj(Tcl_GetDefaultEncodingDir(), -1)); -#endif + Tcl_SetObjResult(interp, Tcl_NewStringObj(Tcl_GetEncodingSearchPath(), -1)); return TCL_OK; } -- cgit v0.12 From 0ae103848b50e1fab1089e7c04bed68fac81152f Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Sun, 12 Jun 2022 15:45:41 +0000 Subject: Use pkgb_demo to test function Tcl_UtfNcmp() --- unix/dltest/pkgb.c | 13 ++++++++++++- 1 file changed, 12 insertions(+), 1 deletion(-) diff --git a/unix/dltest/pkgb.c b/unix/dltest/pkgb.c index 2d525bc..a758a06 100644 --- a/unix/dltest/pkgb.c +++ b/unix/dltest/pkgb.c @@ -98,7 +98,18 @@ Pkgb_DemoObjCmd( int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - Tcl_SetObjResult(interp, Tcl_NewStringObj(Tcl_GetEncodingSearchPath(), -1)); + Tcl_WideInt numChars; + int result; + + if (objc != 4) { + Tcl_WrongNumArgs(interp, 1, objv, "arg1 arg2 num"); + return TCL_ERROR; + } + if (Tcl_GetWideIntFromObj(interp, objv[3], &numChars) != TCL_OK) { + return TCL_ERROR; + } + result = Tcl_UtfNcmp(Tcl_GetString(objv[1]), Tcl_GetString(objv[2]), numChars); + Tcl_SetObjResult(interp, Tcl_NewIntObj(result)); return TCL_OK; } -- cgit v0.12 From 76449960091fb163fa1ad8df359b39233467114d Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Sun, 12 Jun 2022 15:52:20 +0000 Subject: Eliminate compiler warnings --- unix/dltest/pkgb.c | 1 + unix/dltest/pkgooa.c | 6 ++++++ 2 files changed, 7 insertions(+) diff --git a/unix/dltest/pkgb.c b/unix/dltest/pkgb.c index a758a06..c933daa 100644 --- a/unix/dltest/pkgb.c +++ b/unix/dltest/pkgb.c @@ -100,6 +100,7 @@ Pkgb_DemoObjCmd( { Tcl_WideInt numChars; int result; + (void)dummy; if (objc != 4) { Tcl_WrongNumArgs(interp, 1, objv, "arg1 arg2 num"); diff --git a/unix/dltest/pkgooa.c b/unix/dltest/pkgooa.c index 5aa48a5..3d198e6 100644 --- a/unix/dltest/pkgooa.c +++ b/unix/dltest/pkgooa.c @@ -88,6 +88,12 @@ static TclOOStubs stubsCopy = { #ifdef Tcl_MethodIsPrivate ,NULL #endif +#ifdef Tcl_GetClassOfObject + ,NULL +#endif +#ifdef Tcl_GetObjectClassName + ,NULL +#endif }; DLLEXPORT int -- cgit v0.12 From 0df492e7f78679fa7e18db0182679630c776a512 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Sun, 12 Jun 2022 16:29:11 +0000 Subject: Keep lines in tcl.decs not too long --- generic/tcl.decls | 40 +++++++++++++++++++++------------------- 1 file changed, 21 insertions(+), 19 deletions(-) diff --git a/generic/tcl.decls b/generic/tcl.decls index 4bc93e2..264bf99 100644 --- a/generic/tcl.decls +++ b/generic/tcl.decls @@ -108,8 +108,8 @@ declare 22 {deprecated {No longer in use, changed to macro}} { Tcl_Obj *Tcl_DbNewBooleanObj(int intValue, const char *file, int line) } declare 23 { - Tcl_Obj *Tcl_DbNewByteArrayObj(const unsigned char *bytes, int numBytes, - const char *file, int line) + Tcl_Obj *Tcl_DbNewByteArrayObj(const unsigned char *bytes, + int numBytes, const char *file, int line) } declare 24 { Tcl_Obj *Tcl_DbNewDoubleObj(double doubleValue, const char *file, @@ -598,8 +598,8 @@ declare 166 { # generic interface, so we include it here for compatibility reasons. declare 167 unix { - int Tcl_GetOpenFile(Tcl_Interp *interp, const char *chanID, int forWriting, - int checkUsage, ClientData *filePtr) + int Tcl_GetOpenFile(Tcl_Interp *interp, const char *chanID, + int forWriting, int checkUsage, ClientData *filePtr) } # Obsolete. Should now use Tcl_FSGetPathType which is objectified # and therefore usually faster. @@ -1121,8 +1121,8 @@ declare 312 { int Tcl_NumUtfChars(const char *src, int length) } declare 313 { - int Tcl_ReadChars(Tcl_Channel channel, Tcl_Obj *objPtr, int charsToRead, - int appendFlag) + int Tcl_ReadChars(Tcl_Channel channel, Tcl_Obj *objPtr, + int charsToRead, int appendFlag) } declare 314 { void Tcl_RestoreResult(Tcl_Interp *interp, Tcl_SavedResult *statePtr) @@ -1275,16 +1275,17 @@ declare 359 { const char *command, int length) } declare 360 { - int Tcl_ParseBraces(Tcl_Interp *interp, const char *start, int numBytes, - Tcl_Parse *parsePtr, int append, const char **termPtr) + int Tcl_ParseBraces(Tcl_Interp *interp, const char *start, + int numBytes, Tcl_Parse *parsePtr, int append, + const char **termPtr) } declare 361 { - int Tcl_ParseCommand(Tcl_Interp *interp, const char *start, int numBytes, - int nested, Tcl_Parse *parsePtr) + int Tcl_ParseCommand(Tcl_Interp *interp, const char *start, + int numBytes, int nested, Tcl_Parse *parsePtr) } declare 362 { - int Tcl_ParseExpr(Tcl_Interp *interp, const char *start, int numBytes, - Tcl_Parse *parsePtr) + int Tcl_ParseExpr(Tcl_Interp *interp, const char *start, + int numBytes, Tcl_Parse *parsePtr) } declare 363 { int Tcl_ParseQuotedString(Tcl_Interp *interp, const char *start, @@ -1292,8 +1293,8 @@ declare 363 { const char **termPtr) } declare 364 { - int Tcl_ParseVarName(Tcl_Interp *interp, const char *start, int numBytes, - Tcl_Parse *parsePtr, int append) + int Tcl_ParseVarName(Tcl_Interp *interp, const char *start, + int numBytes, Tcl_Parse *parsePtr, int append) } # These 4 functions are obsolete, use Tcl_FSGetCwd, Tcl_FSChdir, # Tcl_FSAccess and Tcl_FSStat @@ -2089,8 +2090,8 @@ declare 574 { void Tcl_AppendObjToErrorInfo(Tcl_Interp *interp, Tcl_Obj *objPtr) } declare 575 { - void Tcl_AppendLimitedToObj(Tcl_Obj *objPtr, const char *bytes, int length, - int limit, const char *ellipsis) + void Tcl_AppendLimitedToObj(Tcl_Obj *objPtr, const char *bytes, + int length, int limit, const char *ellipsis) } declare 576 { Tcl_Obj *Tcl_Format(Tcl_Interp *interp, const char *format, int objc, @@ -2135,8 +2136,8 @@ declare 584 { int Tcl_NREvalObj(Tcl_Interp *interp, Tcl_Obj *objPtr, int flags) } declare 585 { - int Tcl_NREvalObjv(Tcl_Interp *interp, int objc, Tcl_Obj *const objv[], - int flags) + int Tcl_NREvalObjv(Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[], int flags) } declare 586 { int Tcl_NRCmdSwap(Tcl_Interp *interp, Tcl_Command cmd, int objc, @@ -2269,7 +2270,8 @@ declare 618 { int Tcl_ZlibStreamPut(Tcl_ZlibStream zshandle, Tcl_Obj *data, int flush) } declare 619 { - int Tcl_ZlibStreamGet(Tcl_ZlibStream zshandle, Tcl_Obj *data, int count) + int Tcl_ZlibStreamGet(Tcl_ZlibStream zshandle, Tcl_Obj *data, + int count) } declare 620 { int Tcl_ZlibStreamClose(Tcl_ZlibStream zshandle) -- cgit v0.12 From df5d89543ede18ab7c37d6dbd92992013053017c Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Sun, 12 Jun 2022 18:30:30 +0000 Subject: Fix "gcc 4.8.5 is unhappy with macros that explicitly test (&foo) as booleans". Testing for NULL-pointer here doesn't have enough benefit to keep it here --- generic/tclDecls.h | 16 ++++++++-------- 1 file changed, 8 insertions(+), 8 deletions(-) diff --git a/generic/tclDecls.h b/generic/tclDecls.h index 7194c7b..677b1dd 100644 --- a/generic/tclDecls.h +++ b/generic/tclDecls.h @@ -3941,19 +3941,19 @@ extern const TclStubs *tclStubsPtr; #undef Tcl_GetBytesFromObj #if defined(USE_TCL_STUBS) #define Tcl_GetStringFromObj(objPtr, sizePtr) \ - (((sizePtr) != NULL) && (sizeof(*(sizePtr)) == sizeof(int) && sizeof(int) != sizeof(size_t)) ? \ + ((sizeof(*(sizePtr)) == sizeof(int) && sizeof(int) != sizeof(size_t)) ? \ tclStubsPtr->tclGetStringFromObj(objPtr, (int *)(void *)(sizePtr)) : \ tclStubsPtr->tcl_GetStringFromObj(objPtr, (size_t *)(void *)(sizePtr))) #define Tcl_GetBytesFromObj(interp, objPtr, sizePtr) \ - (((sizePtr) != NULL) && (sizeof(*(sizePtr)) == sizeof(int) && sizeof(int) != sizeof(size_t)) ? \ + ((sizeof(*(sizePtr)) == sizeof(int) && sizeof(int) != sizeof(size_t)) ? \ tclStubsPtr->tclGetBytesFromObj(interp, objPtr, (int *)(void *)(sizePtr)) : \ tclStubsPtr->tcl_GetBytesFromObj(interp, objPtr, (size_t *)(void *)(sizePtr))) #define Tcl_GetByteArrayFromObj(objPtr, sizePtr) \ - (((sizePtr) != NULL) && (sizeof(*(sizePtr)) == sizeof(int) && sizeof(int) != sizeof(size_t)) ? \ + ((sizeof(*(sizePtr)) == sizeof(int) && sizeof(int) != sizeof(size_t)) ? \ tclStubsPtr->tclGetBytesFromObj(NULL, objPtr, (int *)(void *)(sizePtr)) : \ tclStubsPtr->tcl_GetBytesFromObj(NULL, objPtr, (size_t *)(void *)(sizePtr))) #define Tcl_GetUnicodeFromObj(objPtr, sizePtr) \ - (((sizePtr) != NULL) && (sizeof(*(sizePtr)) == sizeof(int) && sizeof(int) != sizeof(size_t)) ? \ + ((sizeof(*(sizePtr)) == sizeof(int) && sizeof(int) != sizeof(size_t)) ? \ tclStubsPtr->tclGetUnicodeFromObj(objPtr, (int *)(void *)(sizePtr)) : \ tclStubsPtr->tcl_GetUnicodeFromObj(objPtr, (size_t *)(void *)(sizePtr))) #define Tcl_GetIndexFromObjStruct(interp, objPtr, tablePtr, offset, msg, flags, indexPtr) \ @@ -3961,19 +3961,19 @@ extern const TclStubs *tclStubsPtr; (flags)|(int)(sizeof(*(indexPtr))<<1), (indexPtr))) #else #define Tcl_GetStringFromObj(objPtr, sizePtr) \ - (((sizePtr) != NULL) && (sizeof(*(sizePtr)) == sizeof(int) && sizeof(int) != sizeof(size_t)) ? \ + ((sizeof(*(sizePtr)) == sizeof(int) && sizeof(int) != sizeof(size_t)) ? \ (TclGetStringFromObj)(objPtr, (int *)(void *)(sizePtr)) : \ (Tcl_GetStringFromObj)(objPtr, (size_t *)(void *)(sizePtr))) #define Tcl_GetBytesFromObj(interp, objPtr, sizePtr) \ - (((sizePtr) != NULL) && (sizeof(*(sizePtr)) == sizeof(int) && sizeof(int) != sizeof(size_t)) ? \ + ((sizeof(*(sizePtr)) == sizeof(int) && sizeof(int) != sizeof(size_t)) ? \ (TclGetBytesFromObj)(interp, objPtr, (int *)(void *)(sizePtr)) : \ (Tcl_GetBytesFromObj)(interp, objPtr, (size_t *)(void *)(sizePtr))) #define Tcl_GetByteArrayFromObj(objPtr, sizePtr) \ - (((sizePtr) != NULL) && (sizeof(*(sizePtr)) == sizeof(int) && sizeof(int) != sizeof(size_t)) ? \ + ((sizeof(*(sizePtr)) == sizeof(int) && sizeof(int) != sizeof(size_t)) ? \ (TclGetBytesFromObj)(NULL, objPtr, (int *)(void *)(sizePtr)) : \ (Tcl_GetBytesFromObj)(NULL, objPtr, (size_t *)(void *)(sizePtr))) #define Tcl_GetUnicodeFromObj(objPtr, sizePtr) \ - (((sizePtr) != NULL) && (sizeof(*(sizePtr)) == sizeof(int) && sizeof(int) != sizeof(size_t)) ? \ + ((sizeof(*(sizePtr)) == sizeof(int) && sizeof(int) != sizeof(size_t)) ? \ (TclGetUnicodeFromObj)(objPtr, (int *)(void *)(sizePtr)) : \ Tcl_GetUnicodeFromObj(objPtr, (size_t *)(void *)(sizePtr))) #define Tcl_GetIndexFromObjStruct(interp, objPtr, tablePtr, offset, msg, flags, indexPtr) \ -- cgit v0.12 From 6f45f03949a077b65f23db5838949691db095c60 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 13 Jun 2022 11:33:04 +0000 Subject: Some -1 -> TCL_INDEX_NONE. Update fossil's ignore-glob --- .fossil-settings/ignore-glob | 4 ++ generic/tclBasic.c | 163 ++++++++++++++++++++++--------------------- generic/tclCompile.c | 87 +++++++++++------------ 3 files changed, 130 insertions(+), 124 deletions(-) diff --git a/.fossil-settings/ignore-glob b/.fossil-settings/ignore-glob index 651d616..d14bd9c 100644 --- a/.fossil-settings/ignore-glob +++ b/.fossil-settings/ignore-glob @@ -54,9 +54,11 @@ unix/dltest/*.o unix/dltest/*.sl unix/dltest/*.so unix/tcl.pc +unix/tclUuid.h unix/tclIndex unix/Tcl-Info.plist unix/Tclsh-Info.plist +unix/*.zip unix/pkgs/* win/Debug* win/Release* @@ -64,5 +66,7 @@ win/*.manifest win/pkgs/* win/coffbase.txt win/tcl.hpj +win/tclUuid.h win/nmakehlp.out win/nmhlp-out.txt +win/*.zip \ No newline at end of file diff --git a/generic/tclBasic.c b/generic/tclBasic.c index f87e1e1..a78a768 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -86,7 +86,7 @@ typedef struct OldMathFuncData { Tcl_MathProc *proc; /* Handler function */ int numArgs; /* Number of args expected */ Tcl_ValueType *argTypes; /* Types of the args */ - ClientData clientData; /* Client data for the handler function */ + void *clientData; /* Client data for the handler function */ } OldMathFuncData; /* @@ -105,8 +105,8 @@ typedef struct { * cancellation. */ char *result; /* The script cancellation result or NULL for * a default result. */ - int length; /* Length of the above error message. */ - ClientData clientData; /* Not used. */ + int length; /* Length of the above error message. */ + void *clientData; /* Not used. */ int flags; /* Additional flags */ } CancelInfo; static Tcl_HashTable cancelTable; @@ -149,12 +149,12 @@ static Tcl_ObjCmdProc BadEnsembleSubcommand; static char * CallCommandTraces(Interp *iPtr, Command *cmdPtr, const char *oldName, const char *newName, int flags); -static int CancelEvalProc(ClientData clientData, +static int CancelEvalProc(void *clientData, Tcl_Interp *interp, int code); static int CheckDoubleResult(Tcl_Interp *interp, double dResult); -static void DeleteCoroutine(ClientData clientData); +static void DeleteCoroutine(void *clientData); static void DeleteInterpProc(Tcl_Interp *interp); -static void DeleteOpCmdClientData(ClientData clientData); +static void DeleteOpCmdClientData(void *clientData); #ifdef USE_DTRACE static Tcl_ObjCmdProc DTraceObjCmd; static Tcl_NRPostProc DTraceCmdReturn; @@ -192,7 +192,7 @@ static Tcl_NRPostProc NRCommand; #if !defined(TCL_NO_DEPRECATED) static Tcl_ObjCmdProc OldMathFuncProc; -static void OldMathFuncDeleteProc(ClientData clientData); +static void OldMathFuncDeleteProc(void *clientData); #endif /* !defined(TCL_NO_DEPRECATED) */ static void ProcessUnexpectedResult(Tcl_Interp *interp, int returnCode); @@ -1314,7 +1314,7 @@ Tcl_CreateInterp(void) static void DeleteOpCmdClientData( - ClientData clientData) + void *clientData) { TclOpCmdClientData *occdPtr = (TclOpCmdClientData *)clientData; @@ -1479,7 +1479,7 @@ TclHideUnsafeCommands( static int BadEnsembleSubcommand( - ClientData clientData, + void *clientData, Tcl_Interp *interp, TCL_UNUSED(int) /*objc*/, TCL_UNUSED(Tcl_Obj *const *) /* objv */) @@ -1519,7 +1519,7 @@ Tcl_CallWhenDeleted( Tcl_Interp *interp, /* Interpreter to watch. */ Tcl_InterpDeleteProc *proc, /* Function to call when interpreter is about * to be deleted. */ - ClientData clientData) /* One-word value to pass to proc. */ + void *clientData) /* One-word value to pass to proc. */ { Interp *iPtr = (Interp *) interp; static Tcl_ThreadDataKey assocDataCounterKey; @@ -1567,7 +1567,7 @@ Tcl_DontCallWhenDeleted( Tcl_Interp *interp, /* Interpreter to watch. */ Tcl_InterpDeleteProc *proc, /* Function to call when interpreter is about * to be deleted. */ - ClientData clientData) /* One-word value to pass to proc. */ + void *clientData) /* One-word value to pass to proc. */ { Interp *iPtr = (Interp *) interp; Tcl_HashTable *hTablePtr; @@ -1615,7 +1615,7 @@ Tcl_SetAssocData( const char *name, /* Name for association. */ Tcl_InterpDeleteProc *proc, /* Proc to call when interpreter is about to * be deleted. */ - ClientData clientData) /* One-word value to pass to proc. */ + void *clientData) /* One-word value to pass to proc. */ { Interp *iPtr = (Interp *) interp; AssocData *dPtr; @@ -1697,7 +1697,7 @@ Tcl_DeleteAssocData( *---------------------------------------------------------------------- */ -ClientData +void * Tcl_GetAssocData( Tcl_Interp *interp, /* Interpreter associated with. */ const char *name, /* Name of association. */ @@ -2070,7 +2070,7 @@ DeleteInterpProc( if (eclPtr->type == TCL_LOCATION_SOURCE) { Tcl_DecrRefCount(eclPtr->path); } - for (i=0; i< eclPtr->nuloc; i++) { + for (i=0; inuloc; i++) { ckfree(eclPtr->loc[i].line); } @@ -2501,7 +2501,7 @@ Tcl_CreateCommand( * specified namespace; otherwise it is put in * the global namespace. */ Tcl_CmdProc *proc, /* Function to associate with cmdName. */ - ClientData clientData, /* Arbitrary value passed to string proc. */ + void *clientData, /* Arbitrary value passed to string proc. */ Tcl_CmdDeleteProc *deleteProc) /* If not NULL, gives a function to call when * this command is deleted. */ @@ -2699,7 +2699,7 @@ Tcl_CreateObjCommand( * the global namespace. */ Tcl_ObjCmdProc *proc, /* Object-based function to associate with * name. */ - ClientData clientData, /* Arbitrary value to pass to object + void *clientData, /* Arbitrary value to pass to object * function. */ Tcl_CmdDeleteProc *deleteProc /* If not NULL, gives a function to call when @@ -2749,7 +2749,7 @@ TclCreateObjCommandInNs( Tcl_Namespace *namesp, /* The namespace to create the command in */ Tcl_ObjCmdProc *proc, /* Object-based function to associate with * name. */ - ClientData clientData, /* Arbitrary value to pass to object + void *clientData, /* Arbitrary value to pass to object * function. */ Tcl_CmdDeleteProc *deleteProc) /* If not NULL, gives a function to call when @@ -2935,7 +2935,7 @@ TclCreateObjCommandInNs( int TclInvokeStringCommand( - ClientData clientData, /* Points to command's Command structure. */ + void *clientData, /* Points to command's Command structure. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ @@ -2983,7 +2983,7 @@ TclInvokeStringCommand( int TclInvokeObjectCommand( - ClientData clientData, /* Points to command's Command structure. */ + void *clientData, /* Points to command's Command structure. */ Tcl_Interp *interp, /* Current interpreter. */ int argc, /* Number of arguments. */ const char **argv) /* Argument strings. */ @@ -3872,7 +3872,7 @@ CallCommandTraces( static int CancelEvalProc( - ClientData clientData, /* Interp to cancel the script in progress. */ + void *clientData, /* Interp to cancel the script in progress. */ TCL_UNUSED(Tcl_Interp *), int code) /* Current return code from command. */ { @@ -3992,7 +3992,7 @@ Tcl_CreateMathFunc( * argument. */ Tcl_MathProc *proc, /* C function that implements the math * function. */ - ClientData clientData) /* Additional value to pass to the + void *clientData) /* Additional value to pass to the * function. */ { Tcl_DString bigName; @@ -4033,7 +4033,7 @@ Tcl_CreateMathFunc( static int OldMathFuncProc( - ClientData clientData, /* Pointer to OldMathFuncData describing the + void *clientData, /* Pointer to OldMathFuncData describing the * function being called */ Tcl_Interp *interp, /* Tcl interpreter */ int objc, /* Actual parameter count */ @@ -4180,7 +4180,7 @@ OldMathFuncProc( static void OldMathFuncDeleteProc( - ClientData clientData) + void *clientData) { OldMathFuncData *dataPtr = (OldMathFuncData *)clientData; @@ -4219,7 +4219,7 @@ Tcl_GetMathFuncInfo( int *numArgsPtr, Tcl_ValueType **argTypesPtr, Tcl_MathProc **procPtr, - ClientData *clientDataPtr) + void **clientDataPtr) { Tcl_Obj *cmdNameObj; Command *cmdPtr; @@ -4382,7 +4382,7 @@ TclInterpReady( * probably because of an infinite loop somewhere. */ - if (((iPtr->numLevels) <= iPtr->maxNestingDepth)) { + if ((iPtr->numLevels <= iPtr->maxNestingDepth)) { return TCL_OK; } @@ -4561,7 +4561,7 @@ Tcl_CancelEval( * script. */ Tcl_Obj *resultObjPtr, /* The script cancellation error message or * NULL for a default error message. */ - ClientData clientData, /* Passed to CancelEvalProc. */ + void *clientData, /* Passed to CancelEvalProc. */ int flags) /* Collection of OR-ed bits that control * the cancellation of the script. Only * TCL_CANCEL_UNWIND is currently @@ -4720,7 +4720,7 @@ TclNREvalObjv( static int EvalObjvCore( - ClientData data[], + void *data[], Tcl_Interp *interp, TCL_UNUSED(int) /*result*/) { @@ -4880,12 +4880,12 @@ EvalObjvCore( static int Dispatch( - ClientData data[], + void *data[], Tcl_Interp *interp, TCL_UNUSED(int) /*result*/) { Tcl_ObjCmdProc *objProc = (Tcl_ObjCmdProc *)data[0]; - ClientData clientData = data[1]; + void *clientData = data[1]; int objc = PTR2INT(data[2]); Tcl_Obj **objv = (Tcl_Obj **)data[3]; Interp *iPtr = (Interp *) interp; @@ -4968,7 +4968,7 @@ TclNRRunCallbacks( static int NRCommand( - ClientData data[], + void *data[], Tcl_Interp *interp, int result) { @@ -5041,7 +5041,7 @@ TEOV_PushExceptionHandlers( */ TclNRAddCallback(interp, TEOV_Error, INT2PTR(objc), - (ClientData) objv, NULL, NULL); + objv, NULL, NULL); } if (iPtr->numLevels == 1) { @@ -5072,7 +5072,7 @@ TEOV_SwitchVarFrame( static int TEOV_RestoreVarFrame( - ClientData data[], + void *data[], Tcl_Interp *interp, int result) { @@ -5082,7 +5082,7 @@ TEOV_RestoreVarFrame( static int TEOV_Exception( - ClientData data[], + void *data[], Tcl_Interp *interp, int result) { @@ -5111,7 +5111,7 @@ TEOV_Exception( static int TEOV_Error( - ClientData data[], + void *data[], Tcl_Interp *interp, int result) { @@ -5237,7 +5237,7 @@ TEOV_NotFound( static int TEOV_NotFoundCallback( - ClientData data[], + void *data[], Tcl_Interp *interp, int result) { @@ -5317,7 +5317,7 @@ TEOV_RunEnterTraces( static int TEOV_RunLeaveTraces( - ClientData data[], + void *data[], Tcl_Interp *interp, int result) { @@ -5539,7 +5539,8 @@ TclEvalEx( Tcl_Obj **objv, **objvSpace; int *expand, *lines, *lineSpace; Tcl_Token *tokenPtr; - int commandLength, bytesLeft, expandRequested, code = TCL_OK; + int bytesLeft, expandRequested, code = TCL_OK; + int commandLength; CallFrame *savedVarFramePtr;/* Saves old copy of iPtr->varFramePtr in case * TCL_EVAL_GLOBAL was set. */ int allowExceptions = (iPtr->evalFlags & TCL_ALLOW_EXCEPTIONS); @@ -5716,7 +5717,7 @@ TclEvalEx( wordStart = tokenPtr->start; lines[objectsUsed] = TclWordKnownAtCompileTime(tokenPtr, NULL) - ? wordLine : -1; + ? wordLine : TCL_INDEX_NONE; if (eeFramePtr->type == TCL_LOCATION_SOURCE) { iPtr->evalFlags |= TCL_EVAL_FILE; @@ -6708,7 +6709,7 @@ TclNREvalObjEx( static int TEOEx_ByteCodeCallback( - ClientData data[], + void *data[], Tcl_Interp *interp, int result) { @@ -6754,7 +6755,7 @@ TEOEx_ByteCodeCallback( static int TEOEx_ListCallback( - ClientData data[], + void *data[], Tcl_Interp *interp, int result) { @@ -6961,7 +6962,7 @@ Tcl_ExprLongObj( Tcl_Obj *resultPtr; int result, type; double d; - ClientData internalPtr; + void *internalPtr; result = Tcl_ExprObj(interp, objPtr, &resultPtr); if (result != TCL_OK) { @@ -7007,7 +7008,7 @@ Tcl_ExprDoubleObj( { Tcl_Obj *resultPtr; int result, type; - ClientData internalPtr; + void *internalPtr; result = Tcl_ExprObj(interp, objPtr, &resultPtr); if (result != TCL_OK) { @@ -7188,7 +7189,7 @@ TclNRInvoke( static int NRPostInvoke( - TCL_UNUSED(ClientData *), + TCL_UNUSED(void **), Tcl_Interp *interp, int result) { @@ -7390,7 +7391,7 @@ Tcl_AddObjErrorInfo( } /* - *--------------------------------------------------------------------------- + *---------------------------------------------------------------------- * * Tcl_VarEvalVA -- * @@ -7399,12 +7400,12 @@ Tcl_AddObjErrorInfo( * * Results: * A standard Tcl return result. An error message or other result may be - * left in the interp's result. + * left in the interp. * * Side effects: * Depends on what was done by the command. * - *--------------------------------------------------------------------------- + *---------------------------------------------------------------------- */ int @@ -7712,7 +7713,7 @@ ExprIsqrtFunc( int objc, /* Actual parameter count. */ Tcl_Obj *const *objv) /* Actual parameter list. */ { - ClientData ptr; + void *ptr; int type; double d; Tcl_WideInt w; @@ -7865,7 +7866,7 @@ ExprSqrtFunc( static int ExprUnaryFunc( - ClientData clientData, /* Contains the address of a function that + void *clientData, /* Contains the address of a function that * takes one double argument and returns a * double result. */ Tcl_Interp *interp, /* The interpreter in which to execute the @@ -7929,7 +7930,7 @@ CheckDoubleResult( static int ExprBinaryFunc( - ClientData clientData, /* Contains the address of a function that + void *clientData, /* Contains the address of a function that * takes two double arguments and returns a * double result. */ Tcl_Interp *interp, /* The interpreter in which to execute the @@ -7987,7 +7988,7 @@ ExprAbsFunc( int objc, /* Actual parameter count. */ Tcl_Obj *const *objv) /* Parameter vector. */ { - ClientData ptr; + void *ptr; int type; mp_int big; @@ -8145,7 +8146,7 @@ ExprIntFunc( { double d; int type; - ClientData ptr; + void *ptr; if (objc != 2) { MathFuncWrongNumArgs(interp, 2, objc, objv); @@ -8224,7 +8225,7 @@ ExprMaxMinFunc( Tcl_Obj *res; double d; int type, i; - ClientData ptr; + void *ptr; if (objc < 2) { MathFuncWrongNumArgs(interp, 2, objc, objv); @@ -8376,7 +8377,7 @@ ExprRoundFunc( Tcl_Obj *const *objv) /* Parameter vector. */ { double d; - ClientData ptr; + void *ptr; int type; if (objc != 2) { @@ -8644,7 +8645,7 @@ ExprIsFiniteFunc( Tcl_Obj *const *objv) /* Actual parameter list */ { double d; - ClientData ptr; + void *ptr; int type, result = 0; if (objc != 2) { @@ -8675,7 +8676,7 @@ ExprIsInfinityFunc( Tcl_Obj *const *objv) /* Actual parameter list */ { double d; - ClientData ptr; + void *ptr; int type, result = 0; if (objc != 2) { @@ -8705,7 +8706,7 @@ ExprIsNaNFunc( Tcl_Obj *const *objv) /* Actual parameter list */ { double d; - ClientData ptr; + void *ptr; int type, result = 1; if (objc != 2) { @@ -8735,7 +8736,7 @@ ExprIsNormalFunc( Tcl_Obj *const *objv) /* Actual parameter list */ { double d; - ClientData ptr; + void *ptr; int type, result = 0; if (objc != 2) { @@ -8765,7 +8766,7 @@ ExprIsSubnormalFunc( Tcl_Obj *const *objv) /* Actual parameter list */ { double d; - ClientData ptr; + void *ptr; int type, result = 0; if (objc != 2) { @@ -8795,7 +8796,7 @@ ExprIsUnorderedFunc( Tcl_Obj *const *objv) /* Actual parameter list */ { double d; - ClientData ptr; + void *ptr; int type, result = 0; if (objc != 3) { @@ -8837,7 +8838,7 @@ FloatClassifyObjCmd( { double d; Tcl_Obj *objPtr; - ClientData ptr; + void *ptr; int type; if (objc != 2) { @@ -9041,7 +9042,7 @@ TclDTraceInfo( static int DTraceCmdReturn( - ClientData data[], + void *data[], Tcl_Interp *interp, int result) { @@ -9086,7 +9087,7 @@ int Tcl_NRCallObjProc( Tcl_Interp *interp, Tcl_ObjCmdProc *objProc, - ClientData clientData, + void *clientData, int objc, Tcl_Obj *const objv[]) { @@ -9138,7 +9139,7 @@ Tcl_NRCreateCommand( * calls. */ Tcl_ObjCmdProc *nreProc, /* Object-based function to associate with * name, provides NR implementation */ - ClientData clientData, /* Arbitrary value to pass to object + void *clientData, /* Arbitrary value to pass to object * function. */ Tcl_CmdDeleteProc *deleteProc) /* If not NULL, gives a function to call when @@ -9159,7 +9160,7 @@ TclNRCreateCommandInNs( Tcl_Namespace *nsPtr, Tcl_ObjCmdProc *proc, Tcl_ObjCmdProc *nreProc, - ClientData clientData, + void *clientData, Tcl_CmdDeleteProc *deleteProc) { Command *cmdPtr = (Command *) @@ -9387,7 +9388,7 @@ TclNRTailcallObjCmd( int TclNRTailcallEval( - ClientData data[], + void *data[], Tcl_Interp *interp, int result) { @@ -9426,7 +9427,7 @@ TclNRTailcallEval( int TclNRReleaseValues( - ClientData data[], + void *data[], TCL_UNUSED(Tcl_Interp *), int result) { @@ -9447,10 +9448,10 @@ void Tcl_NRAddCallback( Tcl_Interp *interp, Tcl_NRPostProc *postProcPtr, - ClientData data0, - ClientData data1, - ClientData data2, - ClientData data3) + void *data0, + void *data1, + void *data2, + void *data3) { if (!(postProcPtr)) { Tcl_Panic("Adding a callback without an objProc?!"); @@ -9484,7 +9485,7 @@ Tcl_NRAddCallback( int TclNRYieldObjCmd( - ClientData clientData, + void *clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) @@ -9568,7 +9569,7 @@ TclNRYieldToObjCmd( static int RewindCoroutineCallback( - ClientData data[], + void *data[], Tcl_Interp *interp, TCL_UNUSED(int) /*result*/) { @@ -9595,7 +9596,7 @@ RewindCoroutine( static void DeleteCoroutine( - ClientData clientData) + void *clientData) { CoroutineData *corPtr = (CoroutineData *)clientData; Tcl_Interp *interp = corPtr->eePtr->interp; @@ -9608,7 +9609,7 @@ DeleteCoroutine( static int NRCoroutineCallerCallback( - ClientData data[], + void *data[], Tcl_Interp *interp, int result) { @@ -9654,7 +9655,7 @@ NRCoroutineCallerCallback( static int NRCoroutineExitCallback( - ClientData data[], + void *data[], Tcl_Interp *interp, int result) { @@ -9719,7 +9720,7 @@ NRCoroutineExitCallback( int TclNRCoroutineActivateCallback( - ClientData data[], + void *data[], Tcl_Interp *interp, TCL_UNUSED(int) /*result*/) { @@ -9813,7 +9814,7 @@ TclNRCoroutineActivateCallback( static int TclNREvalList( - ClientData data[], + void *data[], Tcl_Interp *interp, TCL_UNUSED(int) /*result*/) { @@ -10071,7 +10072,7 @@ TclNRCoroProbeObjCmd( static int InjectHandler( - ClientData data[], + void *data[], Tcl_Interp *interp, TCL_UNUSED(int) /*result*/) { @@ -10117,7 +10118,7 @@ InjectHandler( static int InjectHandlerPostCall( - ClientData data[], + void *data[], Tcl_Interp *interp, int result) { @@ -10211,7 +10212,7 @@ NRInjectObjCmd( int TclNRInterpCoroutine( - ClientData clientData, + void *clientData, Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ @@ -10242,7 +10243,7 @@ TclNRInterpCoroutine( } break; default: - if (corPtr->nargs != objc-1) { + if (corPtr->nargs + 1 != objc) { Tcl_SetObjResult(interp, Tcl_NewStringObj("wrong coro nargs; how did we get here? " "not implemented!", -1)); diff --git a/generic/tclCompile.c b/generic/tclCompile.c index f7479f0..80d8a09 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -780,12 +780,12 @@ TclSetByteCodeFromAny( * compiled. Must not be NULL. */ Tcl_Obj *objPtr, /* The object to make a ByteCode object. */ CompileHookProc *hookProc, /* Procedure to invoke after compilation. */ - ClientData clientData) /* Hook procedure private data. */ + void *clientData) /* Hook procedure private data. */ { Interp *iPtr = (Interp *) interp; CompileEnv compEnv; /* Compilation environment structure allocated * in frame. */ - size_t length; + int length; int result = TCL_OK; const char *stringPtr; Proc *procPtr = iPtr->compiledProcPtr; @@ -801,8 +801,7 @@ TclSetByteCodeFromAny( } #endif - stringPtr = TclGetString(objPtr); - length = objPtr->length; + stringPtr = TclGetStringFromObj(objPtr, &length); /* * TIP #280: Pick up the CmdFrame in which the BC compiler was invoked, and @@ -1055,7 +1054,7 @@ CleanupByteCode( statsPtr = &iPtr->stats; statsPtr->numByteCodesFreed++; - statsPtr->currentSrcBytes -= (double) codePtr->numSrcBytes; + statsPtr->currentSrcBytes -= (double)codePtr->numSrcBytes; statsPtr->currentByteCodeBytes -= (double) codePtr->structureSize; statsPtr->currentInstBytes -= (double) codePtr->numCodeBytes; @@ -1149,7 +1148,7 @@ CleanupByteCode( } } - if (codePtr->localCachePtr && (--codePtr->localCachePtr->refCount == 0)) { + if (codePtr->localCachePtr && (codePtr->localCachePtr->refCount-- <= 1)) { TclFreeLocalCache(interp, codePtr->localCachePtr); } @@ -1819,10 +1818,10 @@ CompileCmdLiteral( Tcl_Obj *cmdObj, CompileEnv *envPtr) { - int numBytes; const char *bytes; Command *cmdPtr; int cmdLitIdx, extraLiteralFlags = LITERAL_CMD_NAME; + int numBytes; cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, cmdObj); if ((cmdPtr != NULL) && (cmdPtr->flags & CMD_VIA_RESOLVER)) { @@ -1847,7 +1846,8 @@ TclCompileInvocation( CompileEnv *envPtr) { DefineLineInformation; - int wordIdx = 0, depth = TclGetStackDepth(envPtr); + int wordIdx = 0; + int depth = TclGetStackDepth(envPtr); if (cmdObj) { CompileCmdLiteral(interp, cmdObj, envPtr); @@ -2332,8 +2332,8 @@ TclCompileVarSubst( CompileEnv *envPtr) { const char *p, *name = tokenPtr[1].start; - int nameBytes = tokenPtr[1].size; - int i, localVar, localVarName = 1; + int i, localVar, nameBytes = tokenPtr[1].size; + int localVarName = 1; /* * Determine how the variable name should be handled: if it contains any @@ -2360,7 +2360,7 @@ TclCompileVarSubst( * of local variables in a procedure frame. */ - localVar = -1; + localVar = TCL_INDEX_NONE; if (localVarName != -1) { localVar = TclFindCompiledLocal(name, nameBytes, localVarName, envPtr); } @@ -2407,7 +2407,8 @@ TclCompileTokens( Tcl_DString textBuffer; /* Holds concatenated chars from adjacent * TCL_TOKEN_TEXT, TCL_TOKEN_BS tokens. */ char buffer[4] = ""; - int i, numObjsToConcat, length, adjust; + int i, numObjsToConcat, adjust; + int length; unsigned char *entryCodeNext = envPtr->codeNext; #define NUM_STATIC_POS 20 int isLiteral, maxNumCL, numCL; @@ -3003,7 +3004,7 @@ TclFindCompiledLocal( CompileEnv *envPtr) /* Points to the current compile environment*/ { CompiledLocal *localPtr; - int localVar = -1; + int localVar = TCL_INDEX_NONE; int i; Proc *procPtr; @@ -3026,20 +3027,19 @@ TclFindCompiledLocal( int len; if (!cachePtr || !name) { - return -1; + return TCL_INDEX_NONE; } varNamePtr = &cachePtr->varName0; for (i=0; i < cachePtr->numVars; varNamePtr++, i++) { if (*varNamePtr) { - localName = TclGetString(*varNamePtr); - len = (*varNamePtr)->length; + localName = TclGetStringFromObj(*varNamePtr, &len); if ((len == nameBytes) && !strncmp(name, localName, len)) { return i; } } } - return -1; + return TCL_INDEX_NONE; } if (name != NULL) { @@ -3131,8 +3131,8 @@ TclExpandCodeArray( envPtr->codeStart = (unsigned char *)ckrealloc(envPtr->codeStart, newBytes); } else { /* - * envPtr->exceptArrayPtr isn't a Tcl_Alloc'd pointer, so - * perform the equivalent of Tcl_Realloc directly. + * envPtr->exceptArrayPtr isn't a Tcl_Alloc'd pointer, so + * perform the equivalent of Tcl_Realloc directly. */ unsigned char *newPtr = (unsigned char *)ckalloc(newBytes); @@ -3220,8 +3220,8 @@ EnterCmdStartData( cmdLocPtr = &envPtr->cmdMapPtr[cmdIndex]; cmdLocPtr->codeOffset = codeOffset; cmdLocPtr->srcOffset = srcOffset; - cmdLocPtr->numSrcBytes = -1; - cmdLocPtr->numCodeBytes = -1; + cmdLocPtr->numSrcBytes = TCL_INDEX_NONE; + cmdLocPtr->numCodeBytes = TCL_INDEX_NONE; } /* @@ -3307,7 +3307,8 @@ EnterCmdWordData( { ECL *ePtr; const char *last; - int wordIdx, wordLine, *wwlines, *wordNext; + int wordIdx, wordLine; + int *wwlines, *wordNext; if (eclPtr->nuloc >= eclPtr->nloc) { /* @@ -3342,7 +3343,7 @@ EnterCmdWordData( /* See Ticket 4b61afd660 */ wwlines[wordIdx] = ((wordIdx == 0) || TclWordKnownAtCompileTime(tokenPtr, NULL)) - ? wordLine : -1; + ? wordLine : TCL_INDEX_NONE; ePtr->line[wordIdx] = wordLine; ePtr->next[wordIdx] = wordNext; last = tokenPtr->start; @@ -3392,7 +3393,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); @@ -3423,16 +3424,16 @@ 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; auxPtr->expandTarget = envPtr->expandCount; - auxPtr->expandTargetDepth = -1; + auxPtr->expandTargetDepth = TCL_INDEX_NONE; auxPtr->numBreakTargets = 0; auxPtr->breakTargets = NULL; auxPtr->allocBreakTargets = 0; @@ -3462,14 +3463,14 @@ 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->numCodeBytes == TCL_INDEX_NONE || CurrentOffset(envPtr) < rangePtr->codeOffset+rangePtr->numCodeBytes) && (returnCode != TCL_CONTINUE || envPtr->exceptAuxArrayPtr[i].supportsContinue)) { @@ -3566,7 +3567,7 @@ TclCleanupStackForBreakContinue( CompileEnv *envPtr, ExceptionAux *auxPtr) { - int savedStackDepth = envPtr->currStackDepth; + size_t savedStackDepth = envPtr->currStackDepth; int toPop = envPtr->expandCount - auxPtr->expandTarget; if (toPop > 0) { @@ -3620,7 +3621,7 @@ StartExpanding( if (rangePtr->codeOffset > CurrentOffset(envPtr)) { continue; } - if (rangePtr->numCodeBytes != -1) { + if (rangePtr->numCodeBytes != TCL_INDEX_NONE) { continue; } @@ -3680,7 +3681,7 @@ TclFinalizeLoopExceptionRange( } for (i=0 ; inumContinueTargets ; i++) { site = envPtr->codeStart + auxPtr->continueTargets[i]; - if (rangePtr->continueOffset == -1) { + if (rangePtr->continueOffset == TCL_INDEX_NONE) { int j; /* @@ -3735,7 +3736,7 @@ TclFinalizeLoopExceptionRange( int TclCreateAuxData( - ClientData clientData, /* The compilation auxiliary data to store in + void *clientData, /* The compilation auxiliary data to store in * the new aux data record. */ const AuxDataType *typePtr, /* Pointer to the type to attach to this * AuxData */ @@ -3755,7 +3756,7 @@ TclCreateAuxData( */ size_t currBytes = envPtr->auxDataArrayNext * sizeof(AuxData); - int newElems = 2*envPtr->auxDataArrayEnd; + size_t newElems = 2*envPtr->auxDataArrayEnd; size_t newBytes = newElems * sizeof(AuxData); if (envPtr->mallocedAuxDataArray) { @@ -3844,7 +3845,7 @@ TclExpandJumpFixupArray( */ size_t currBytes = fixupArrayPtr->next * sizeof(JumpFixup); - int newElems = 2*(fixupArrayPtr->end + 1); + size_t newElems = 2*(fixupArrayPtr->end + 1); size_t newBytes = newElems * sizeof(JumpFixup); if (fixupArrayPtr->mallocedArray) { @@ -3989,7 +3990,7 @@ TclFixupForwardJump( { unsigned char *jumpPc, *p; int firstCmd, lastCmd, firstRange, lastRange, k; - unsigned numBytes; + size_t numBytes; if (jumpDist <= distThreshold) { jumpPc = envPtr->codeStart + jumpFixupPtr->codeOffset; @@ -4058,7 +4059,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; @@ -4175,7 +4176,7 @@ TclEmitInvoke( if (rangePtr == NULL || rangePtr->type != LOOP_EXCEPTION_RANGE) { auxContinuePtr = NULL; } else if (auxContinuePtr->stackDepth == envPtr->currStackDepth-wordCount - && auxContinuePtr->expandTarget == envPtr->expandCount-expandCount) { + && (auxContinuePtr->expandTarget+expandCount == envPtr->expandCount)) { auxContinuePtr = NULL; } else { continueRange = auxContinuePtr - envPtr->exceptAuxArrayPtr; @@ -4185,8 +4186,8 @@ TclEmitInvoke( if (rangePtr == NULL || rangePtr->type != LOOP_EXCEPTION_RANGE) { auxBreakPtr = NULL; } else if (auxContinuePtr == NULL - && auxBreakPtr->stackDepth == envPtr->currStackDepth-wordCount - && auxBreakPtr->expandTarget == envPtr->expandCount-expandCount) { + && auxBreakPtr->stackDepth+wordCount == envPtr->currStackDepth + && auxBreakPtr->expandTarget+expandCount == envPtr->expandCount) { auxBreakPtr = NULL; } else { breakRange = auxBreakPtr - envPtr->exceptAuxArrayPtr; -- cgit v0.12 From 310451d63efb820df4ad0aa96ca1944b594d1c32 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 13 Jun 2022 11:34:09 +0000 Subject: Backport unix/dltest/*.c changes from 9.0 --- unix/dltest/pkga.c | 4 ++-- unix/dltest/pkgb.c | 6 +++--- unix/dltest/pkgc.c | 4 ++-- unix/dltest/pkgd.c | 4 ++-- unix/dltest/pkgooa.c | 2 +- unix/dltest/pkgua.c | 6 +++--- 6 files changed, 13 insertions(+), 13 deletions(-) diff --git a/unix/dltest/pkga.c b/unix/dltest/pkga.c index 37782ea..579c323 100644 --- a/unix/dltest/pkga.c +++ b/unix/dltest/pkga.c @@ -33,7 +33,7 @@ static int Pkga_EqObjCmd( - ClientData dummy, /* Not used. */ + void *dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ @@ -78,7 +78,7 @@ Pkga_EqObjCmd( static int Pkga_QuoteObjCmd( - ClientData dummy, /* Not used. */ + void *dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument strings. */ diff --git a/unix/dltest/pkgb.c b/unix/dltest/pkgb.c index c933daa..e9645a4 100644 --- a/unix/dltest/pkgb.c +++ b/unix/dltest/pkgb.c @@ -37,7 +37,7 @@ static int Pkgb_SubObjCmd( - ClientData dummy, /* Not used. */ + void *dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ @@ -79,7 +79,7 @@ Pkgb_SubObjCmd( static int Pkgb_UnsafeObjCmd( - ClientData dummy, /* Not used. */ + void *dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ @@ -93,7 +93,7 @@ Pkgb_UnsafeObjCmd( static int Pkgb_DemoObjCmd( - ClientData dummy, /* Not used. */ + void *dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ diff --git a/unix/dltest/pkgc.c b/unix/dltest/pkgc.c index cd92cf7..8e9c829 100644 --- a/unix/dltest/pkgc.c +++ b/unix/dltest/pkgc.c @@ -33,7 +33,7 @@ static int Pkgc_SubObjCmd( - ClientData dummy, /* Not used. */ + void *dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ @@ -72,7 +72,7 @@ Pkgc_SubObjCmd( static int Pkgc_UnsafeObjCmd( - ClientData dummy, /* Not used. */ + void *dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ diff --git a/unix/dltest/pkgd.c b/unix/dltest/pkgd.c index 0c98ec4..1b97d4c 100644 --- a/unix/dltest/pkgd.c +++ b/unix/dltest/pkgd.c @@ -33,7 +33,7 @@ static int Pkgd_SubObjCmd( - ClientData dummy, /* Not used. */ + void *dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ @@ -72,7 +72,7 @@ Pkgd_SubObjCmd( static int Pkgd_UnsafeObjCmd( - ClientData dummy, /* Not used. */ + void *dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ diff --git a/unix/dltest/pkgooa.c b/unix/dltest/pkgooa.c index 3d198e6..369d894 100644 --- a/unix/dltest/pkgooa.c +++ b/unix/dltest/pkgooa.c @@ -33,7 +33,7 @@ static int Pkgooa_StubsOKObjCmd( - ClientData dummy, /* Not used. */ + void *dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ diff --git a/unix/dltest/pkgua.c b/unix/dltest/pkgua.c index 6d64352..16684a8 100644 --- a/unix/dltest/pkgua.c +++ b/unix/dltest/pkgua.c @@ -31,7 +31,7 @@ static Tcl_ThreadDataKey dataKey; #define MAX_REGISTERED_COMMANDS 2 static void -CommandDeleted(ClientData clientData) +CommandDeleted(void *clientData) { Tcl_Command *cmdToken = (Tcl_Command *)clientData; *cmdToken = NULL; @@ -120,7 +120,7 @@ PkguaDeleteTokens( static int PkguaEqObjCmd( - ClientData dummy, /* Not used. */ + void *dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ @@ -165,7 +165,7 @@ PkguaEqObjCmd( static int PkguaQuoteObjCmd( - ClientData dummy, /* Not used. */ + void *dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument strings. */ -- cgit v0.12 From bf1528403276733a85426e74357783d937c7faed Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 13 Jun 2022 12:01:47 +0000 Subject: Some int argc -> size_t argc --- unix/tclUnixPipe.c | 6 +++--- win/tclWinPipe.c | 10 +++++----- 2 files changed, 8 insertions(+), 8 deletions(-) diff --git a/unix/tclUnixPipe.c b/unix/tclUnixPipe.c index 27e8182..16e56b2 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. */ - size_t argc1, /* 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,8 +410,8 @@ TclpCreateProcess( char errSpace[200 + TCL_INTEGER_SPACE]; Tcl_DString *dsArray; char **newArgv; - int pid, i; - int argc = argc1; + int pid; + size_t i; errPipeIn = NULL; errPipeOut = NULL; diff --git a/win/tclWinPipe.c b/win/tclWinPipe.c index b4f9ff0..5d928f3 100644 --- a/win/tclWinPipe.c +++ b/win/tclWinPipe.c @@ -171,7 +171,7 @@ typedef struct { static int ApplicationType(Tcl_Interp *interp, const char *fileName, char *fullName); -static void BuildCommandLine(const char *executable, int argc, +static void BuildCommandLine(const char *executable, size_t argc, const char **argv, Tcl_DString *linePtr); static BOOL HasConsole(void); static int PipeBlockModeProc(ClientData instanceData, int mode); @@ -911,7 +911,7 @@ TclpCreateProcess( * occurred when creating the child process. * Error messages from the child process * itself are sent to errorFile. */ - size_t argc1, /* 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 @@ -943,7 +943,6 @@ TclpCreateProcess( HANDLE hProcess, h, inputHandle, outputHandle, errorHandle; char execPath[MAX_PATH * 3]; WinFile *filePtr; - int argc = argc1; PipeInit(); @@ -1537,13 +1536,14 @@ static void BuildCommandLine( const char *executable, /* Full path of executable (including * extension). Replacement for argv[0]. */ - int argc, /* Number of arguments. */ + size_t argc, /* Number of arguments. */ const char **argv, /* Argument strings in UTF. */ Tcl_DString *linePtr) /* Initialized Tcl_DString that receives the * command line (WCHAR). */ { const char *arg, *start, *special, *bspos; - int quote = 0, i; + int quote = 0; + size_t i; Tcl_DString ds; static const char specMetaChars[] = "&|^<>!()%"; /* Characters to enclose in quotes if unpaired -- cgit v0.12 From 420a7fc15d7b123ff696251d0a67b148edbb4c0a Mon Sep 17 00:00:00 2001 From: apnadkarni Date: Mon, 13 Jun 2022 16:15:15 +0000 Subject: Start towards Tcl9 support --- generic/tclInt.h | 58 +++++-- generic/tclListObj.c | 424 ++++++++++++++++++++++++++++----------------------- 2 files changed, 280 insertions(+), 202 deletions(-) diff --git a/generic/tclInt.h b/generic/tclInt.h index 2ac7644..96e5b58 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -2423,6 +2423,29 @@ typedef enum TclEolTranslation { #define TCL_INVOKE_NO_TRACEBACK (1<<2) /* + * TclListSizeT is the type for holding list element counts. It's defined + * simplify sharing source between Tcl8 and Tcl9. + */ +#if TCL_MAJOR_VERSION > 8 + +typedef ptrdiff_t ListSizeT; /* TODO - may need to fix to match Tcl9's API */ + +/* + * SSIZE_MAX, NOT SIZE_MAX as negative differences need to be expressed + * between values of the ListSizeT type so limit the range to signed + */ +#define ListSizeT_MAX PTRDIFF_MAX + +#else + +typedef int ListSizeT; +#define ListSizeT_MAX INT_MAX + +#endif + +/* + * ListStore -- + * * A Tcl list's internal representation is defined through three structures. * * A ListStore struct is a structure that includes a variable size array that @@ -2446,32 +2469,41 @@ typedef enum TclEolTranslation { * */ typedef struct ListStore { - int refCount; - int firstUsed; /* Index of first slot in use within the slots[] array */ - int numUsed; /* Number of slots in use (starting at index firstUsed) */ - int numAllocated; /* Total number of slots[] array slots. */ - int flags; /* LISTSTORE_* flags */ - Tcl_Obj *slots[1]; /* Variable size array. The struct is grown as needed */ + ListSizeT firstUsed; /* Index of first slot in use within slots[] */ + ListSizeT numUsed; /* Number of slots in use (starting firstUsed) */ + ListSizeT numAllocated; /* Total number of slots[] array slots. */ + int refCount; /* Number of references to this instance */ + int flags; /* LISTSTORE_* flags */ + Tcl_Obj *slots[1]; /* Variable size array. Grown as needed */ } ListStore; #define LISTSTORE_CANONICAL 0x1 /* All Tcl_Obj's referencing this store have their string representation derived from the list representation */ -/* TODO - should the limit not be based on INT_MAX and not UINT_MAX? */ -#define LIST_MAX \ - (1 + (int)(((size_t)UINT_MAX - sizeof(ListStore))/sizeof(Tcl_Obj *))) +/* Max number of elements that can be contained in a list */ +#define LIST_MAX \ + (1 \ + + (ListSizeT)(((size_t)ListSizeT_MAX - sizeof(ListStore)) \ + / sizeof(Tcl_Obj *))) +/* Memory size needed for a ListStore to hold numSlots_ elements */ #define LIST_SIZE(numSlots_) \ (unsigned)(sizeof(ListStore) + (((numSlots_) - 1) * sizeof(Tcl_Obj *))) -/* See comments above */ +/* + * ListSpan -- + * See comments above for ListStore + */ typedef struct ListSpan { + ListSizeT spanStart; /* Starting index of the span */ + ListSizeT spanLength; /* Number of elements in the span */ int refCount; /* Count of references to this span record */ - int spanStart; /* Starting index within parentList where the span */ - int spanLength; /* Number of elements in the span */ } ListSpan; -/* See comments above */ +/* + * ListRep -- + * See comments above for ListStore + */ typedef struct ListRep { ListStore *storePtr;/* element array shared amongst different lists */ ListSpan *spanPtr; /* If not NULL, the span holds the range of slots diff --git a/generic/tclListObj.c b/generic/tclListObj.c index b0f12d8..0fc78e9 100644 --- a/generic/tclListObj.c +++ b/generic/tclListObj.c @@ -9,47 +9,76 @@ * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ -/* TODO - disable/configure asserts */ - -/* TODO - control these macros at build time */ -//#undef NDEBUG -//#define ENABLE_LIST_INVARIANT_CHECKS - -#ifndef NDEBUG -#define ENABLE_LIST_ASSERTS -#endif - #include "tclInt.h" #include -/* TODO - memmove is very fast. Measure at what size we should use that +/* TODO - memmove is fast. Measure at what size we should prefer memmove (for unshared objects only) in lieu of range operations */ /* * Macros for validation and bug checking. */ -/* TODO - control these macros at build time */ + +/* + * Control whether asserts are enabled. Always enable in debug builds. In non-debug + * builds, can be set with cdebug="-DENABLE_LIST_ASSERTS" on the nmake command line. + */ #ifdef ENABLE_LIST_ASSERTS -#define LIST_ASSERT(cond_) assert(cond_) /* TODO */ +# ifdef NDEBUG +# undef NDEBUG /* Activate assert() macro */ +# endif +#else +# ifndef NDEBUG +# define ENABLE_LIST_ASSERTS /* Always activate list asserts in debug mode */ +# endif +#endif + +#ifdef ENABLE_LIST_ASSERTS + +#define LIST_ASSERT(cond_) assert(cond_) /* TODO - is there a Tcl-specific one? */ +/* + * LIST_INDEX_ASSERT is to catch errors with negative indices and counts + * being passed AFTER validation. On Tcl9 length types are unsigned hence + * the checks against LIST_MAX. On Tcl8 length types are signed hence the + * also checks against 0. + */ +#define LIST_INDEX_ASSERT(idxarg_) \ + do { \ + ListSizeT idx_ = (idxarg_); /* To guard against ++ etc. */ \ + LIST_ASSERT(idx_ >= 0 && idx_ < LIST_MAX); \ + } while (0) +/* Ditto for counts except upper limit is different */ +#define LIST_COUNT_ASSERT(countarg_) \ + do { \ + ListSizeT count_ = (countarg_); /* To guard against ++ etc. */ \ + LIST_ASSERT(count_ >= 0 && count_ <= LIST_MAX); \ + } while (0) + #else + #define LIST_ASSERT(cond_) ((void) 0) +#define LIST_INDEX_ASSERT(idx_) ((void) 0) +#define LIST_COUNT_ASSERT(count_) ((void) 0) + #endif +/* Checks for when caller should have already converted to internal list type */ #define LIST_ASSERT_TYPE(listObj_) \ LIST_ASSERT((listObj_)->typePtr == &tclListType); -#ifdef ENABLE_LIST_INVARIANT_CHECKS + +/* + * If ENABLE_LIST_INVARIANTS is enabled (-DENABLE_LIST_INVARIANTS from the + * command line), the entire list internal representation is checked for + * inconsistencies. This has a non-trivial cost so has to be separately + * enabled and not part of assertions checking. + */ +#ifdef ENABLE_LIST_INVARIANTS #define LISTREP_CHECK(listRepPtr_) ListRepValidate(listRepPtr_) #else #define LISTREP_CHECK(listRepPtr_) (void) 0 #endif -#if defined(TCL_MEM_DEBUG) && !defined(LIST_MEM_DEBUG) -# define LIST_MEM_DEBUG -#endif - -#undef LIST_MEM_DEBUG /* List memory debug not implemented yet */ - /* * Flags used for controlling behavior of allocation of list * internal representations. @@ -60,14 +89,17 @@ * * The LISTREP_SPACE_FAVOR_NONE, LISTREP_SPACE_FAVOR_FRONT, * LISTREP_SPACE_FAVOR_BACK, LISTREP_SPACE_ONLY_BACK flags are used to - * control additional space when allocating. If none of these is present, - * the exact space requested is allocated, nothing more. Otherwise, If only - * LISTREP_FAVOR_FRONT is present, extra space is allocated with more - * towards the front. Conversely, if LISTREP_FAVOR_BACK is present extra - * space is allocated with more to the back. If both flags are present (or - * LISTREP_SPACE_FAVOR_NONE), the extra space is equally apportioned. - * Finally if LISTREP_SPACE_ONLY_BACK is present, ALL extra space is at the - * back. + * control additional space when allocating. + * - If none of these flags is present, the exact space requested is + * allocated, nothing more. + * - Otherwise, if only LISTREP_FAVOR_FRONT is present, extra space is + * allocated with more towards the front. + * - Conversely, if only LISTREP_FAVOR_BACK is present extra space is allocated + * with more to the back. + * - If both flags are present (LISTREP_SPACE_FAVOR_NONE), the extra space + * is equally apportioned. + * - Finally if LISTREP_SPACE_ONLY_BACK is present, ALL extra space is at + * the back. */ #define LISTREP_PANIC_ON_FAIL 0x00000001 #define LISTREP_SPACE_FAVOR_FRONT 0x00000002 @@ -82,19 +114,25 @@ /* * Prototypes for non-inline static functions defined later in this file: */ -static int MemoryAllocationError(Tcl_Interp *, int size); +static int MemoryAllocationError(Tcl_Interp *, size_t size); static int ListLimitExceededError(Tcl_Interp *); -static ListStore *ListStoreNew(int objc, Tcl_Obj *const objv[], int flags); -static int ListRepInit(int objc, Tcl_Obj *const objv[], int flags, ListRep *); -static int ListRepInitAttempt(Tcl_Interp *, int objc, Tcl_Obj *const objv[], - ListRep *); +static ListStore * +ListStoreNew(ListSizeT objc, Tcl_Obj *const objv[], int flags); +static int +ListRepInit(ListSizeT objc, Tcl_Obj *const objv[], int flags, ListRep *); +static int ListRepInitAttempt(Tcl_Interp *, + ListSizeT objc, + Tcl_Obj *const objv[], + ListRep *); static void ListRepClone(ListRep *fromRepPtr, ListRep *toRepPtr, int flags); static void ListRepUnsharedFreeUnreferenced(const ListRep *repPtr); static int TclListObjGetRep(Tcl_Interp *, Tcl_Obj *listPtr, ListRep *repPtr); -static void ListRepRange(ListRep *srcRepPtr, int rangeStart, int rangeEnd, - int preserveSrcRep, ListRep *rangeRepPtr); - -static ListStore *ListStoreReallocate(ListStore *storePtr, int numSlots); +static void ListRepRange(ListRep *srcRepPtr, + ListSizeT rangeStart, + ListSizeT rangeEnd, + int preserveSrcRep, + ListRep *rangeRepPtr); +static ListStore *ListStoreReallocate(ListStore *storePtr, ListSizeT numSlots); #ifdef ENABLE_LIST_ASSERTS /* Else gcc complains about unused static */ static void ListRepValidate(const ListRep *repPtr); #endif @@ -180,11 +218,6 @@ const Tcl_ObjType tclListType = { ListObjStompRep(objPtr_, repPtr_); \ } while (0) -/* TODO - currently not used anywhere. Originally used in realloc code */ -#ifndef TCL_MIN_ELEMENT_GROWTH -#define TCL_MIN_ELEMENT_GROWTH (TCL_MIN_GROWTH/sizeof(Tcl_Obj *)) -#endif - /* *------------------------------------------------------------------------ * @@ -203,8 +236,8 @@ const Tcl_ObjType tclListType = { */ static inline ListSpan * ListSpanNew( - int firstSlot, /* Starting slot index of the span */ - int numSlots) /* Number of slots covered by the span */ + ListSizeT firstSlot, /* Starting slot index of the span */ + ListSizeT numSlots) /* Number of slots covered by the span */ { ListSpan *spanPtr = (ListSpan *) ckalloc(sizeof(*spanPtr)); spanPtr->refCount = 0; @@ -286,9 +319,9 @@ ListSpanDecrRefs(ListSpan *spanPtr) static inline int ListSpanMerited( - int length, /* Length of the proposed span */ - int usedStorageLength, /* Number of slots currently in used */ - int allocatedStorageLength) /* Size of the currently allocated storage */ + ListSizeT length, /* Length of the proposed span */ + ListSizeT usedStorageLength, /* Number of slots currently in used */ + ListSizeT allocatedStorageLength) /* Length of the currently allocation */ { /* TODO @@ -329,8 +362,8 @@ ListSpanMerited( * *------------------------------------------------------------------------ */ -static inline int -ListStoreUpSize(int numSlotsRequested) { +static inline ListSizeT +ListStoreUpSize(ListSizeT numSlotsRequested) { /* TODO -how much extra? May be double only for smaller requests? */ return numSlotsRequested < (LIST_MAX / 2) ? 2 * numSlotsRequested : LIST_MAX; @@ -380,13 +413,13 @@ ListRepFreeUnreferenced(const ListRep *repPtr) */ static inline void ObjArrayIncrRefs( - Tcl_Obj * const *objv, /* Pointer to the array */ - int startIdx, /* Starting index of subarray within objv */ - int count) /* Number of elements in the subarray */ + Tcl_Obj * const *objv, /* Pointer to the array */ + ListSizeT startIdx, /* Starting index of subarray within objv */ + ListSizeT count) /* Number of elements in the subarray */ { Tcl_Obj * const *end; - LIST_ASSERT(startIdx >= 0); - LIST_ASSERT(count >= 0); + LIST_INDEX_ASSERT(startIdx); + LIST_COUNT_ASSERT(count); objv += startIdx; end = objv + count; while (objv < end) { @@ -413,12 +446,12 @@ ObjArrayIncrRefs( static inline void ObjArrayDecrRefs( Tcl_Obj * const *objv, /* Pointer to the array */ - int startIdx, /* Starting index of subarray within objv */ - int count) /* Number of elements in the subarray */ + ListSizeT startIdx, /* Starting index of subarray within objv */ + ListSizeT count) /* Number of elements in the subarray */ { Tcl_Obj * const *end; - LIST_ASSERT(startIdx >= 0); - LIST_ASSERT(count >= 0); + LIST_INDEX_ASSERT(startIdx); + LIST_COUNT_ASSERT(count); objv += startIdx; end = objv + count; while (objv < end) { @@ -445,11 +478,11 @@ ObjArrayDecrRefs( static inline void ObjArrayCopy( Tcl_Obj **to, /* Destination */ - int count, /* Number of pointers to copy */ + ListSizeT count, /* Number of pointers to copy */ Tcl_Obj *const from[]) /* Source array of Tcl_Obj* */ { Tcl_Obj **end; - LIST_ASSERT(count >= 0); + LIST_COUNT_ASSERT(count); end = to + count; /* TODO - would memmove followed by separate IncrRef loop be faster? */ while (to < end) { @@ -476,13 +509,15 @@ ObjArrayCopy( static int MemoryAllocationError( Tcl_Interp *interp, /* Interpreter for error message. May be NULL */ - int size) /* Size of attempted allocation that failed */ + size_t size) /* Size of attempted allocation that failed */ { if (interp != NULL) { Tcl_SetObjResult( interp, - Tcl_ObjPrintf("list construction failed: unable to alloc %u bytes", - size)); + Tcl_ObjPrintf( + "list construction failed: unable to alloc %" TCL_LL_MODIFIER + "u bytes", + (Tcl_WideInt)size)); Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL); } return TCL_ERROR; @@ -509,7 +544,7 @@ ListLimitExceededError(Tcl_Interp *interp) if (interp != NULL) { Tcl_SetObjResult( interp, - Tcl_ObjPrintf("max length of a Tcl list (%d elements) exceeded", + Tcl_ObjPrintf("max length of a Tcl list (%" TCL_LL_MODIFIER "u) elements) exceeded", LIST_MAX)); Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL); } @@ -536,7 +571,7 @@ ListLimitExceededError(Tcl_Interp *interp) *------------------------------------------------------------------------ */ static inline void -ListRepUnsharedShiftDown(ListRep *repPtr, int shiftCount) +ListRepUnsharedShiftDown(ListRep *repPtr, ListSizeT shiftCount) { ListStore *storePtr; @@ -544,6 +579,8 @@ ListRepUnsharedShiftDown(ListRep *repPtr, int shiftCount) LIST_ASSERT(!ListRepIsShared(repPtr)); storePtr = repPtr->storePtr; + + LIST_COUNT_ASSERT(shiftCount); LIST_ASSERT(storePtr->firstUsed >= shiftCount); memmove(&storePtr->slots[storePtr->firstUsed - shiftCount], @@ -588,12 +625,14 @@ ListRepUnsharedShiftDown(ListRep *repPtr, int shiftCount) * *------------------------------------------------------------------------ */ -static inline void ListRepUnsharedShiftUp(ListRep *repPtr, int shiftCount) +static inline void +ListRepUnsharedShiftUp(ListRep *repPtr, ListSizeT shiftCount) { ListStore *storePtr; LISTREP_CHECK(repPtr); LIST_ASSERT(!ListRepIsShared(repPtr)); + LIST_COUNT_ASSERT(shiftCount); storePtr = repPtr->storePtr; LIST_ASSERT((storePtr->firstUsed + storePtr->numUsed + shiftCount) @@ -650,7 +689,8 @@ ListRepValidate(const ListRep *repPtr) LIST_ASSERT(storePtr->firstUsed <= (storePtr->numAllocated - storePtr->numUsed)); -#ifdef LIST_MEM_DEBUG +#if 0 && defined(LIST_MEM_DEBUG) + /* Corresponding zeroing out not implemented yet */ for (i = 0; i < storePtr->firstUsed; ++i) { LIST_ASSERT(storePtr->slots[i] == NULL); } @@ -693,8 +733,8 @@ ListRepValidate(const ListRep *repPtr) * * Results: * On success, a pointer to the allocated ListStore is returned. - * On failure, panics if LISTREP_PANIC_ON_FAIL is set in flags; otherwise - * returns NULL. + * On allocation failure, panics if LISTREP_PANIC_ON_FAIL is set in + * flags; otherwise returns NULL. * * Side effects: * The ref counts of the elements in objv are incremented on success @@ -704,26 +744,20 @@ ListRepValidate(const ListRep *repPtr) */ static ListStore * ListStoreNew( - int objc, + ListSizeT objc, Tcl_Obj *const objv[], int flags) { ListStore *storePtr; - int capacity; - - if (objc <= 0) { - Tcl_Panic("ListStoreNew: expects positive element count"); - } + ListSizeT capacity; /* * 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. + * larger than our memory allocator allows. */ - if ((size_t)objc > LIST_MAX) { + if (objc > LIST_MAX) { if (flags & LISTREP_PANIC_ON_FAIL) { - Tcl_Panic("max length of a Tcl list (%d elements) exceeded", + Tcl_Panic("max length of a Tcl list (%" TCL_LL_MODIFIER "u elements) exceeded", LIST_MAX); } return NULL; @@ -754,7 +788,7 @@ ListStoreNew( storePtr->firstUsed = 0; } else { - int extra = capacity - objc; + ListSizeT extra = capacity - objc; int spaceFlags = flags & LISTREP_SPACE_FLAGS; if (spaceFlags == LISTREP_SPACE_ONLY_BACK) { storePtr->firstUsed = 0; @@ -804,9 +838,9 @@ ListStoreNew( *------------------------------------------------------------------------ */ ListStore * -ListStoreReallocate (ListStore *storePtr, int numSlots) +ListStoreReallocate (ListStore *storePtr, ListSizeT numSlots) { - int newCapacity; + ListSizeT newCapacity; ListStore *newStorePtr; newCapacity = ListStoreUpSize(numSlots); @@ -857,7 +891,7 @@ ListStoreReallocate (ListStore *storePtr, int numSlots) */ static int ListRepInit( - int objc, + ListSizeT objc, Tcl_Obj *const objv[], int flags, ListRep *repPtr @@ -865,6 +899,14 @@ ListRepInit( { ListStore *storePtr; + /* + * The whole list implementation has an implicit assumption that lenths + * and indices used a signed integer type. Tcl9 API's currently use + * unsigned types. This assert is to remind that need to review code + * when adapting for Tcl9. + */ + LIST_ASSERT(((ListSizeT)-1) < 0); + storePtr = ListStoreNew(objc, objv, flags); if (storePtr) { repPtr->storePtr = storePtr; @@ -914,7 +956,7 @@ ListRepInit( static int ListRepInitAttempt( Tcl_Interp *interp, - int objc, + ListSizeT objc, Tcl_Obj *const objv[], ListRep *repPtr) { @@ -954,7 +996,7 @@ static void ListRepClone(ListRep *fromRepPtr, ListRep *toRepPtr, int flags) { Tcl_Obj **fromObjs; - int numFrom; + ListSizeT numFrom; ListRepElements(fromRepPtr, numFrom, fromObjs); ListRepInit(numFrom, fromObjs, flags | LISTREP_PANIC_ON_FAIL, toRepPtr); @@ -983,7 +1025,7 @@ ListRepClone(ListRep *fromRepPtr, ListRep *toRepPtr, int flags) static void ListRepUnsharedFreeUnreferenced(const ListRep *repPtr) { - int count; + ListSizeT count; ListStore *storePtr; ListSpan *spanPtr; @@ -999,20 +1041,22 @@ static void ListRepUnsharedFreeUnreferenced(const ListRep *repPtr) /* Collect garbage at front */ count = spanPtr->spanStart - storePtr->firstUsed; - LIST_ASSERT(count >= 0); + LIST_COUNT_ASSERT(count); if (count > 0) { ObjArrayDecrRefs(storePtr->slots, storePtr->firstUsed, count); storePtr->firstUsed = spanPtr->spanStart; + LIST_ASSERT(storePtr->numUsed >= count); storePtr->numUsed -= count; } /* Collect garbage at back */ count = (storePtr->firstUsed + storePtr->numUsed) - (spanPtr->spanStart + spanPtr->spanLength); - LIST_ASSERT(count >= 0); + LIST_COUNT_ASSERT(count); if (count > 0) { ObjArrayDecrRefs( storePtr->slots, spanPtr->spanStart + spanPtr->spanLength, count); + LIST_ASSERT(storePtr->numUsed >= count); storePtr->numUsed -= count; } @@ -1052,7 +1096,7 @@ static void ListRepUnsharedFreeUnreferenced(const ListRep *repPtr) Tcl_Obj * Tcl_NewListObj( - int objc, /* Count of objects referenced by objv. */ + ListSizeT 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); @@ -1062,7 +1106,7 @@ Tcl_NewListObj( Tcl_Obj * Tcl_NewListObj( - int objc, /* Count of objects referenced by objv. */ + ListSizeT objc, /* Count of objects referenced by objv. */ Tcl_Obj *const objv[]) /* An array of pointers to Tcl objects. */ { ListRep listRep; @@ -1114,7 +1158,7 @@ Tcl_NewListObj( Tcl_Obj * Tcl_DbNewListObj( - int objc, /* Count of objects referenced by objv. */ + ListSizeT 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. */ @@ -1140,7 +1184,7 @@ Tcl_DbNewListObj( Tcl_Obj * Tcl_DbNewListObj( - int objc, /* Count of objects referenced by objv. */ + ListSizeT 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*/) @@ -1170,15 +1214,15 @@ Tcl_DbNewListObj( */ Tcl_Obj * TclNewListObj2( - int objc1, /* Count of objects referenced by objv1. */ + ListSizeT objc1, /* Count of objects referenced by objv1. */ Tcl_Obj *const objv1[], /* First array of pointers to Tcl objects. */ - int objc2, /* Count of objects referenced by objv2. */ + ListSizeT objc2, /* Count of objects referenced by objv2. */ Tcl_Obj *const objv2[] /* Second array of pointers to Tcl objects. */ ) { Tcl_Obj *listObj; ListStore *storePtr; - int objc = objc1 + objc2; + ListSizeT objc = objc1 + objc2; listObj = Tcl_NewListObj(objc, NULL); if (objc == 0) { @@ -1274,7 +1318,7 @@ TclListObjGetRep( void Tcl_SetListObj( Tcl_Obj *objPtr, /* Object whose internal rep to init. */ - int objc, /* Count of objects referenced by objv. */ + ListSizeT objc, /* Count of objects referenced by objv. */ Tcl_Obj *const objv[]) /* An array of pointers to Tcl objects. */ { if (Tcl_IsShared(objPtr)) { @@ -1354,8 +1398,6 @@ TclListObjCopy( * None. * * Side effects: - * TODO WARNING:- this is not a very clean interface and easy to get wrong. - * Better change it to pass in the source ListObj * The ListStore and ListSpan referenced by in the returned ListRep * may or may not be the same as those passed in. For example, the * ListStore may differ because the range is small enough that a new @@ -1364,22 +1406,24 @@ TclListObjCopy( * values are not incremented. Generally, ListObjReplaceRepAndInvalidate may be * used to store the new ListRep back into an object or a ListRepIncRefs * followed by ListRepDecrRefs to free in case of errors. + * TODO WARNING:- this is not a very clean interface and easy for caller + * to get wrong. Better change it to pass in the source ListObj * *------------------------------------------------------------------------ */ static void ListRepRange( ListRep *srcRepPtr, /* Contains source of the range */ - int rangeStart, /* Index of first element to include */ - int rangeEnd, /* Index of last element to include */ + ListSizeT rangeStart, /* Index of first element to include */ + ListSizeT rangeEnd, /* Index of last element to include */ int preserveSrcRep, /* If true, srcRepPtr contents must not be modified (generally because a shared Tcl_Obj references it) */ ListRep *rangeRepPtr) /* Output. Must NOT be == srcRepPtr */ { Tcl_Obj **srcElems; - int numSrcElems = ListRepLength(srcRepPtr); - int rangeLen; + ListSizeT numSrcElems = ListRepLength(srcRepPtr); + ListSizeT rangeLen; int doSpan; LISTREP_CHECK(srcRepPtr); @@ -1414,8 +1458,6 @@ ListRepRange( * * The choice depends on heuristics related to speed and memory. * TODO - heuristics below need to be measured and tuned. - * TODO - could rearrange below to deal with memory failure but not worth - * Might as well panic as rest of Tcl does * * Note: Even if nothing below cause any changes, we still want the * string-canonizing effect of [lrange 0 end] so the Tcl_Obj should not @@ -1427,7 +1469,7 @@ ListRepRange( if (doSpan) { /* Option 1 - because span would be most efficient */ - int spanStart = ListRepStart(srcRepPtr) + rangeStart; + ListSizeT spanStart = ListRepStart(srcRepPtr) + rangeStart; if (!preserveSrcRep && srcRepPtr->spanPtr && srcRepPtr->spanPtr->refCount <= 1) { /* If span is not shared reuse it */ @@ -1467,7 +1509,7 @@ ListRepRange( * or maybe no need to move all the way to the front? * TODO - if range is small relative to allocation, allocate new? */ - int numAfterRangeEnd; + ListSizeT numAfterRangeEnd; /* Asserts follow from call to ListRepFreeUnreferenced earlier */ LIST_ASSERT(!preserveSrcRep); @@ -1530,8 +1572,8 @@ ListRepRange( Tcl_Obj * TclListObjRange( Tcl_Obj *listObj, /* List object to take a range from. */ - int rangeStart, /* Index of first element to include. */ - int rangeEnd) /* Index of last element to include. */ + ListSizeT rangeStart, /* Index of first element to include. */ + ListSizeT rangeEnd) /* Index of last element to include. */ { ListRep listRep; ListRep resultRep; @@ -1587,7 +1629,7 @@ Tcl_ListObjGetElements( Tcl_Interp *interp, /* Used to report errors if not NULL. */ Tcl_Obj *objPtr, /* List object for which an element array is * to be returned. */ - int *objcPtr, /* Where to store the count of objects + ListSizeT *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. */ @@ -1629,7 +1671,7 @@ Tcl_ListObjAppendList( Tcl_Obj *toObj, /* List object to append elements to. */ Tcl_Obj *fromObj) /* List obj with elements to append. */ { - int objc; + ListSizeT objc; Tcl_Obj **objv; if (Tcl_IsShared(toObj)) { @@ -1673,13 +1715,13 @@ Tcl_ListObjAppendList( int TclListObjAppendElements ( Tcl_Interp *interp, /* Used to report errors if not NULL. */ Tcl_Obj *toObj, /* List object to append */ - int elemCount, /* Number of elements in elemObjs[] */ + ListSizeT elemCount, /* Number of elements in elemObjs[] */ Tcl_Obj * const elemObjv[]) /* Objects to append to toObj's list. */ { ListRep listRep; Tcl_Obj **toObjv; - int toLen; - int finalLen; + ListSizeT toLen; + ListSizeT finalLen; if (Tcl_IsShared(toObj)) { Tcl_Panic("%s called with shared object", "TclListObjAppendElements"); @@ -1704,7 +1746,7 @@ Tcl_ListObjAppendList( * reference counts on the elements which is a substantial cost * if the list is not small. */ - int numTailFree; + ListSizeT numTailFree; ListRepFreeUnreferenced(&listRep); /* Collect garbage before checking room */ @@ -1734,7 +1776,7 @@ Tcl_ListObjAppendList( >= elemCount); /* Total free */ if (numTailFree < elemCount) { /* Not enough room at back. Move some to front */ - int shiftCount = elemCount - numTailFree; + ListSizeT shiftCount = elemCount - numTailFree; /* Divide remaining space between front and back */ shiftCount += (listRep.storePtr->numAllocated - finalLen) / 2; LIST_ASSERT(shiftCount <= listRep.storePtr->firstUsed); @@ -1859,11 +1901,11 @@ int Tcl_ListObjIndex( Tcl_Interp *interp, /* Used to report errors if not NULL. */ Tcl_Obj *listObj, /* List object to index into. */ - int index, /* Index of element to return. */ + ListSizeT index, /* Index of element to return. */ Tcl_Obj **objPtrPtr) /* The resulting Tcl_Obj* is stored here. */ { Tcl_Obj **elemObjs; - int numElems; + ListSizeT numElems; /* * TODO @@ -1912,7 +1954,7 @@ int Tcl_ListObjLength( Tcl_Interp *interp, /* Used to report errors if not NULL. */ Tcl_Obj *listObj, /* List object whose #elements to return. */ - int *intPtr) /* The resulting int is stored here. */ + ListSizeT *lenPtr) /* The resulting int is stored here. */ { ListRep listRep; @@ -1926,7 +1968,7 @@ Tcl_ListObjLength( if (TclListObjGetRep(interp, listObj, &listRep) != TCL_OK) { return TCL_ERROR; } - *intPtr = ListRepLength(&listRep); + *lenPtr = ListRepLength(&listRep); return TCL_OK; } @@ -1971,23 +2013,21 @@ int Tcl_ListObjReplace( Tcl_Interp *interp, /* Used for error reporting if not NULL. */ Tcl_Obj *listObj, /* List object whose elements to replace. */ - int first, /* Index of first element to replace. */ - int numToDelete, /* Number of elements to replace. */ - int numToInsert, /* Number of objects to insert. */ + ListSizeT first, /* Index of first element to replace. */ + ListSizeT numToDelete, /* Number of elements to replace. */ + ListSizeT numToInsert, /* Number of objects to insert. */ Tcl_Obj *const insertObjs[])/* Tcl objects to insert */ { ListRep listRep; - int origListLen; - int lenChange; - int leadSegmentLen; - int tailSegmentLen; - int numFreeSlots; - int leadShift; - int tailShift; + ListSizeT origListLen; + ListSizeT lenChange; + ListSizeT leadSegmentLen; + ListSizeT tailSegmentLen; + ListSizeT numFreeSlots; + ListSizeT leadShift; + ListSizeT tailShift; Tcl_Obj **listObjs; - /* TODO - refactor this monstrosity into subfunctions */ - if (Tcl_IsShared(listObj)) { Tcl_Panic("%s called with shared object", "Tcl_ListObjReplace"); } @@ -1995,6 +2035,8 @@ Tcl_ListObjReplace( if (TclListObjGetRep(interp, listObj, &listRep) != TCL_OK) return TCL_ERROR; /* Cannot be converted to a list */ + /* TODO - will need modification if Tcl9 sticks to unsigned indices */ + /* Make limits sane */ origListLen = ListRepLength(&listRep); if (first < 0) { @@ -2006,12 +2048,12 @@ Tcl_ListObjReplace( if (numToDelete < 0) { numToDelete = 0; } - else if (first > INT_MAX - numToDelete /* Handle integer overflow */ + else if (first > ListSizeT_MAX - numToDelete /* Handle integer overflow */ || origListLen < first + numToDelete) { numToDelete = origListLen - first; } - if (numToInsert > LIST_MAX - (origListLen - numToDelete)) { + if (numToInsert > ListSizeT_MAX - (origListLen - numToDelete)) { return ListLimitExceededError(interp); } @@ -2083,7 +2125,7 @@ Tcl_ListObjReplace( ListRepStart(&listRep) == listRep.storePtr->firstUsed && /* (ii) */ numToInsert <= listRep.storePtr->firstUsed /* (iii) */ ) { - int newLen; + ListSizeT newLen; LIST_ASSERT(numToInsert); /* Else would have returned above */ listRep.storePtr->firstUsed -= numToInsert; ObjArrayCopy(&listRep.storePtr->slots[listRep.storePtr->firstUsed], @@ -2253,9 +2295,9 @@ Tcl_ListObjReplace( * or need to shift both. In the former case, favor shifting the * smaller segment. */ - int leadSpace = ListRepNumFreeHead(&listRep); - int tailSpace = ListRepNumFreeTail(&listRep); - int finalFreeSpace = leadSpace + tailSpace - lenChange; + ListSizeT leadSpace = ListRepNumFreeHead(&listRep); + ListSizeT tailSpace = ListRepNumFreeTail(&listRep); + ListSizeT finalFreeSpace = leadSpace + tailSpace - lenChange; LIST_ASSERT((leadSpace + tailSpace) >= lenChange); if (leadSpace >= lenChange @@ -2271,9 +2313,9 @@ Tcl_ListObjReplace( * insertions. */ if (finalFreeSpace > 1 && (tailSpace == 0 || tailSegmentLen == 0)) { - int postShiftLeadSpace = leadSpace - lenChange; + ListSizeT postShiftLeadSpace = leadSpace - lenChange; if (postShiftLeadSpace > (finalFreeSpace/2)) { - int extraShift = postShiftLeadSpace - (finalFreeSpace / 2); + ListSizeT extraShift = postShiftLeadSpace - (finalFreeSpace / 2); leadShift -= extraShift; tailShift = -extraShift; /* Move tail to the front as well */ } @@ -2288,9 +2330,9 @@ Tcl_ListObjReplace( * See comments above. This is analogous. */ if (finalFreeSpace > 1 && (leadSpace == 0 || leadSegmentLen == 0)) { - int postShiftTailSpace = tailSpace - lenChange; + ListSizeT postShiftTailSpace = tailSpace - lenChange; if (postShiftTailSpace > (finalFreeSpace/2)) { - int extraShift = postShiftTailSpace - (finalFreeSpace / 2); + ListSizeT extraShift = postShiftTailSpace - (finalFreeSpace / 2); tailShift += extraShift; leadShift = extraShift; /* Move head to the back as well */ } @@ -2334,7 +2376,7 @@ Tcl_ListObjReplace( if (leadShift > 0) { /* Will happen when we have to make room at bottom */ if (tailShift != 0 && tailSegmentLen != 0) { - int tailStart = leadSegmentLen + numToDelete; + ListSizeT tailStart = leadSegmentLen + numToDelete; memmove(&listObjs[tailStart + tailShift], &listObjs[tailStart], tailSegmentLen * sizeof(Tcl_Obj *)); @@ -2351,7 +2393,7 @@ Tcl_ListObjReplace( leadSegmentLen * sizeof(Tcl_Obj *)); } if (tailShift != 0 && tailSegmentLen != 0) { - int tailStart = leadSegmentLen + numToDelete; + ListSizeT tailStart = leadSegmentLen + numToDelete; memmove(&listObjs[tailStart + tailShift], &listObjs[tailStart], tailSegmentLen * sizeof(Tcl_Obj *)); @@ -2421,10 +2463,10 @@ TclLindexList( Tcl_Obj *listObj, /* List being unpacked. */ Tcl_Obj *argObj) /* Index or index list. */ { - int index; /* Index into the list. */ + ListSizeT index; /* Index into the list. */ Tcl_Obj *indexListCopy; Tcl_Obj **indexObjs; - int numIndexObjs; + ListSizeT numIndexObjs; /* * Determine whether argPtr designates a list or a single index. We have @@ -2433,7 +2475,8 @@ TclLindexList( * see TIP#22 and TIP#33 for the details. */ if (!TclHasInternalRep(argObj, &tclListType) - && TclGetIntForIndexM(NULL, argObj, INT_MAX - 1, &index) == TCL_OK) { + && TclGetIntForIndexM(NULL, argObj, ListSizeT_MAX - 1, &index) + == TCL_OK) { /* * argPtr designates a single index. */ @@ -2498,16 +2541,16 @@ Tcl_Obj * TclLindexFlat( Tcl_Interp *interp, /* Tcl interpreter. */ Tcl_Obj *listObj, /* Tcl object representing the list. */ - int indexCount, /* Count of indices. */ + ListSizeT indexCount, /* Count of indices. */ Tcl_Obj *const indexArray[])/* Array of pointers to Tcl objects that * represent the indices in the list. */ { - int i; + ListSizeT i; Tcl_IncrRefCount(listObj); for (i=0 ; i 0) { + Tcl_Obj *objPtr; - /* TODO - this loop seems to have nothing to do in the error case - so may be skip right away if result != TCL_OK? */ - while (numPendingInvalidates > 0) { - Tcl_Obj *objPtr; + --numPendingInvalidates; + objPtr = pendingInvalidatesPtr[numPendingInvalidates]; - --numPendingInvalidates; - objPtr = pendingInvalidatesPtr[numPendingInvalidates]; - - if (result == TCL_OK) { - /* - * We're going to store valueObj, so spoil string reps of all - * containing lists. - * TODO - historically, the storing of the internal rep was done - * because the ptr2 field of the internal rep was used to chain - * objects whose string rep needed to be invalidated. Now this - * is no longer the case, so replacing of the internal rep - * should not be needed. The TclInvalidateStringRep should suffice. - */ - ListRep objInternalRep; - TclListObjGetRep(NULL, objPtr, &objInternalRep); - ListObjReplaceRepAndInvalidate(objPtr, &objInternalRep); - } else { - /* TODO - do we need to do anything here */ + if (result == TCL_OK) { + /* + * We're going to store valueObj, so spoil string reps of all + * containing lists. + * TODO - historically, the storing of the internal rep was done + * because the ptr2 field of the internal rep was used to chain + * objects whose string rep needed to be invalidated. Now this + * is no longer the case, so replacing of the internal rep + * should not be needed. The TclInvalidateStringRep should + * suffice. Formulate a test case before changing. + */ + ListRep objInternalRep; + TclListObjGetRep(NULL, objPtr, &objInternalRep); + ListObjReplaceRepAndInvalidate(objPtr, &objInternalRep); + } } } @@ -2934,13 +2976,13 @@ TclListObjSetElement( * if not NULL. */ Tcl_Obj *listObj, /* List object in which element should be * stored. */ - int index, /* Index of element to store. */ + ListSizeT index, /* Index of element to store. */ Tcl_Obj *valueObj) /* Tcl object to store in the designated list * element. */ { ListRep listRep; Tcl_Obj **elemPtrs; /* Pointers to elements of the list. */ - int elemCount; /* Number of elements in the list. */ + ListSizeT elemCount; /* Number of elements in the list. */ /* Ensure that the listObj parameter designates an unshared list. */ @@ -3091,7 +3133,8 @@ SetListFromAny( if (!TclHasStringRep(objPtr) && TclHasInternalRep(objPtr, &tclDictType)) { Tcl_Obj *keyPtr, *valuePtr; Tcl_DictSearch search; - int done, size; + int done; + ListSizeT size; /* * Create the new list representation. Note that we do not need to do @@ -3128,7 +3171,7 @@ SetListFromAny( Tcl_DictObjNext(&search, &keyPtr, &valuePtr, &done); } } else { - int estCount, length; + ListSizeT estCount, length; const char *limit, *nextElem = TclGetStringFromObj(objPtr, &length); /* @@ -3155,7 +3198,8 @@ SetListFromAny( while (nextElem < limit) { const char *elemStart; char *check; - int elemSize, literal; + ListSizeT elemSize; + int literal; if (TCL_OK != TclFindElement(interp, nextElem, limit - nextElem, &elemStart, &nextElem, &elemSize, &literal)) { @@ -3239,7 +3283,7 @@ UpdateStringOfList( { # define LOCAL_SIZE 64 char localFlags[LOCAL_SIZE], *flagPtr = NULL; - int numElems, i, length, bytesNeeded = 0; + ListSizeT numElems, i, length, bytesNeeded = 0; const char *elem, *start; char *dst; Tcl_Obj **elemPtrs; @@ -3288,9 +3332,11 @@ UpdateStringOfList( elem = TclGetStringFromObj(elemPtrs[i], &length); bytesNeeded += TclScanElement(elem, length, flagPtr+i); if (bytesNeeded < 0) { + /* TODO - what is the max #define for Tcl9? */ Tcl_Panic("max size for a Tcl value (%d bytes) exceeded", INT_MAX); } } + /* TODO - what is the max #define for Tcl9? */ if (bytesNeeded > INT_MAX - numElems + 1) { Tcl_Panic("max size for a Tcl value (%d bytes) exceeded", INT_MAX); } -- cgit v0.12 From a4c2d0ce66a5dd65133deb0519f71fa5aaade99d Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 13 Jun 2022 20:33:56 +0000 Subject: Add two new testcases for Tcl_ListObjReplace() --- tests/listObj.test | 10 ++++++++++ 1 file changed, 10 insertions(+) diff --git a/tests/listObj.test b/tests/listObj.test index ce6c978..d60f13f 100644 --- a/tests/listObj.test +++ b/tests/listObj.test @@ -195,6 +195,16 @@ test listobj-10.1 {Bug [2971669]} {*}{ } -result {{a b c d e} {} {a b c d e f}} } +test listobj-10.2 {Tcl_ListObjReplace with negative start value} testobj { + testlistobj set 1 a b c d e + testlistobj replace 1 -1 2 f + testlistobj get 1 +} {f c d e} +test listobj-10.3 {Tcl_ListObjReplace with negative count value} testobj { + testlistobj set 1 a b c d e + testlistobj replace 1 1 -1 f + testlistobj get 1 +} {a f b c d e} test listobj-11.1 {Bug 3598580: Tcl_ListObjReplace refcount management} testobj { testobj bug3598580 -- cgit v0.12 From dc3f8c16635601a97aa29fed7a1173010008a659 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 14 Jun 2022 06:18:27 +0000 Subject: Two more Tcl_ListObjReplace test-cases --- tests/listObj.test | 10 ++++++++++ 1 file changed, 10 insertions(+) diff --git a/tests/listObj.test b/tests/listObj.test index 0b64635..93395cf 100644 --- a/tests/listObj.test +++ b/tests/listObj.test @@ -205,6 +205,16 @@ test listobj-10.3 {Tcl_ListObjReplace with negative count value} testobj { testlistobj replace 1 1 -1 f testlistobj get 1 } {a f b c d e} +test listobj-10.4 {Tcl_ListObjReplace with UINT_MAX-1 count value} testobj { + testlistobj set 1 a b c d e + testlistobj replace 1 1 0xFFFFFFFE f + testlistobj get 1 +} {a f} +test listobj-10.5 {Tcl_ListObjReplace with SIZE_MAX-1 count value} testobj { + testlistobj set 1 a b c d e + testlistobj replace 1 1 -2 f + testlistobj get 1 +} {a f} test listobj-11.1 {Bug 3598580: Tcl_ListObjReplace refcount management} testobj { testobj bug3598580 -- cgit v0.12 From 436e6b5e69fc7aa7c86c30ae0eb2c19d0560fd79 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 14 Jun 2022 06:44:56 +0000 Subject: Fix Proposal for [55bf73b52b]: http reuses connections after 101 Switching Protocols. To be discussed --- library/http/http.tcl | 149 +++++++++++++++++++++++++++++--------------------- 1 file changed, 88 insertions(+), 61 deletions(-) diff --git a/library/http/http.tcl b/library/http/http.tcl index ae0a538..df44940 100644 --- a/library/http/http.tcl +++ b/library/http/http.tcl @@ -257,26 +257,11 @@ proc http::Finish {token {errormsg ""} {skipCB 0}} { } # Is this an upgrade request/response? - set upgradeResponse 0 - if { [info exists state(upgradeRequest)] - && [info exists state(http)] - && $state(upgradeRequest) - && ([ncode $token] eq {101}) - } { - # An upgrade must be requested by the client. - # If 101 response, test server response headers for an upgrade. - set connectionHd {} - set upgradeHd {} - if {[dict exists $state(meta) connection]} { - set connectionHd [string tolower [dict get $state(meta) connection]] - } - if {[dict exists $state(meta) upgrade]} { - set upgradeHd [string tolower [dict get $state(meta) upgrade]] - } - if {($connectionHd eq {upgrade}) && ($upgradeHd ne {})} { - set upgradeResponse 1 - } - } + set upgradeResponse \ + [expr { [info exists state(upgradeRequest)] && $state(upgradeRequest) + && [info exists state(http)] && [ncode $token] eq {101} + && [info exists state(connection)] && "upgrade" in $state(connection) + && [info exists state(upgrade)] && "" ne $state(upgrade)}] if { ($state(status) eq "timeout") || ($state(status) eq "error") @@ -298,7 +283,7 @@ proc http::Finish {token {errormsg ""} {skipCB 0}} { catch {fileevent $state(sock) writable {}} } elseif { ([info exists state(-keepalive)] && !$state(-keepalive)) - || ([info exists state(connection)] && ($state(connection) eq "close")) + || ([info exists state(connection)] && ("close" in $state(connection))) } { set closeQueue 1 set connId $state(socketinfo) @@ -306,7 +291,7 @@ proc http::Finish {token {errormsg ""} {skipCB 0}} { CloseSocket $state(sock) $token } elseif { ([info exists state(-keepalive)] && $state(-keepalive)) - && ([info exists state(connection)] && ($state(connection) ne "close")) + && ([info exists state(connection)] && ("close" in $state(connection))) } { KeepSocket $token } @@ -337,7 +322,7 @@ proc http::Finish {token {errormsg ""} {skipCB 0}} { # queued task if possible. Otherwise leave it idle and ready for its next # use. # -# If $socketClosing(*), then ($state(connection) eq "close") and therefore +# If $socketClosing(*), then ("close" in $state(connection)) and therefore # this command will not be called by Finish. # # Arguments: @@ -486,7 +471,7 @@ proc http::KeepSocket {token} { (!$state(-pipeline)) && [info exists socketWrQueue($connId)] && [llength $socketWrQueue($connId)] - && ($state(connection) ne "close") + && ("close" ni $state(connection)) } { # If not pipelined, (socketRdState eq Rready) tells us that we are # ready for the next write - there is no need to check @@ -772,7 +757,7 @@ proc http::geturl {url args} { -strict boolean -timeout integer -validate boolean - -headers dict + -headers list } set state(charset) $defaultCharset set options { @@ -786,8 +771,8 @@ proc http::geturl {url args} { foreach {flag value} $args { if {[regexp -- $pat $flag]} { # Validate numbers - if {($flag eq "-headers") ? [catch {dict size $value}] : - ([info exists type($flag)] && ![string is $type($flag) -strict $value]) + if { ([info exists type($flag)] && ![string is $type($flag) -strict $value]) + || ($flag eq "-headers" && [llength $value] % 2 != 0) } { unset $token return -code error \ @@ -989,12 +974,14 @@ proc http::geturl {url args} { # c11a51c482] set state(accept-types) $http(-accept) - set state(upgradeRequest) [expr { - [dict exists $state(-headers) Upgrade] - && [dict exists $state(-headers) Connection] - && ([dict get $state(-headers) Connection] eq {Upgrade}) - && ([dict get $state(-headers) Upgrade] ne {}) - }] + # Check whether this is an Upgrade request. + set connectionValues [SplitCommaSeparatedFieldValue \ + [GetFieldValue $state(-headers) Connection]] + set connectionValues [string tolower $connectionValues] + set upgradeValues [SplitCommaSeparatedFieldValue \ + [GetFieldValue $state(-headers) Upgrade]] + set state(upgradeRequest) [expr { "upgrade" in $connectionValues + && [llength $upgradeValue] >= 1}] if {$isQuery || $isQueryChannel} { # It's a POST. @@ -1411,11 +1398,11 @@ proc http::Connected {token proto phost srvurl} { if {[catch { set state(method) $how puts $sock "$how $srvurl HTTP/$state(-protocol)" - if {[dict exists $state(-headers) Host]} { + set hostValue [GetFieldValue $state(-headers) Host] + if {$hostValue ne {}} { # Allow Host spoofing. [Bug 928154] - set hostHdr [dict get $state(-headers) Host] - regexp {^[^:]+} $hostHdr state(host) - puts $sock "Host: $hostHdr" + regexp {^[^:]+} $hostValue state(host) + puts $sock "Host: $hostValue" } elseif {$port == $defport} { # Don't add port in this case, to handle broken servers. [Bug # #504508] @@ -1447,7 +1434,7 @@ proc http::Connected {token proto phost srvurl} { # Proxy-Connection header field in any requests" set accept_encoding_seen 0 set content_type_seen 0 - dict for {key value} $state(-headers) { + foreach {key value} $state(-headers) { set value [string map [list \n "" \r ""] $value] set key [string map {" " -} [string trim $key]] if {[string equal -nocase $key "host"]} { @@ -2644,7 +2631,7 @@ proc http::Event {sock token} { if { ([info exists state(connection)]) && ([info exists socketMapping($state(socketinfo))]) - && ($state(connection) eq "keep-alive") + && ("keep-alive" in $state(connection)) && ($state(-keepalive)) && (!$state(reusing)) && ($state(-pipeline)) @@ -2666,7 +2653,7 @@ proc http::Event {sock token} { if { ([info exists state(connection)]) && ([info exists socketMapping($state(socketinfo))]) - && ($state(connection) eq "close") + && ("close" in $state(connection)) && ($state(-keepalive)) } { # The server warns that it will close the socket after this @@ -2737,7 +2724,7 @@ proc http::Event {sock token} { # (totalsize == 0). if { (!( [info exists state(connection)] - && ($state(connection) eq "close") + && ("close" in $state(connection)) ) ) && (![info exists state(transfer)]) @@ -2803,32 +2790,26 @@ proc http::Event {sock token} { } proxy-connection - connection { - set tmpHeader [string trim [string tolower $value]] # RFC 7230 Section 6.1 states that a comma-separated - # list is an acceptable value. According to + # list is an acceptable value. + foreach el [SplitCommaSeparatedFieldValue $value] { + lappend state(connection) [string tolower $el] + } + + # According to # https://developer.mozilla.org/en-US/docs/Web/HTTP/Headers/Connection # any comma-separated list implies keep-alive, but I # don't see this in the RFC so we'll play safe and # scan any list for "close". - if {$tmpHeader in {close keep-alive}} { - # The common cases, continue. - } elseif {[string first , $tmpHeader] < 0} { - # Not a comma-separated list, not "close", - # therefore "keep-alive". - set tmpHeader keep-alive - } else { - set tmpResult keep-alive - set tmpCsl [split $tmpHeader ,] - # Optional whitespace either side of separator. - foreach el $tmpCsl { - if {[string trim $el] eq {close}} { - set tmpResult close - break - } - } - set tmpHeader $tmpResult + # FIXME: support combining duplicate header field's values. + if { "close" ni $state(connection) + && "keep-alive" ni $state(connection) + } { + lappend state(connection) "keep-alive" } - set state(connection) $tmpHeader + } + upgrade { + set state(upgrade) [string trim $value] } } lappend state(meta) $key [string trim $value] @@ -3561,6 +3542,52 @@ proc http::ReceiveChunked {chan command} { } } +# http::SplitCommaSeparatedFieldValue -- +# Return the individual values of a comma-separated field value. +# +# Arguments: +# fieldValue Comma-separated header field value. +# +# Results: +# List of values. +proc http::SplitCommaSeparatedFieldValue {fieldValue} { + set r {} + foreach el [split $fieldValue ,] { + lappend r [string trim $el] + } + return $r +} + + +# http::GetFieldValue -- +# Return the value of a header field. +# +# Arguments: +# headers Headers key-value list +# fieldName Name of header field whose value to return. +# +# Results: +# The value of the fieldName header field +# +# Field names are matched case-insensitively (RFC 7230 Section 3.2). +# +# If the field is present multiple times, it is assumed that the field is +# defined as a comma-separated list and the values are combined (by separating +# them with commas, see RFC 7230 Section 3.2.2) and returned at once. +proc http::GetFieldValue {headers fieldName} { + set r {} + foreach {field value} $headers { + if {[string equal -nocase $fieldName $field]} { + if {$r eq {}} { + set r $value + } else { + append r ", $value" + } + } + } + return $r +} + proc http::make-transformation-chunked {chan command} { coroutine [namespace current]::dechunk$chan ::http::ReceiveChunked $chan $command chan event $chan readable [namespace current]::dechunk$chan -- cgit v0.12 From 1e066132912570f41ce61a59220f84af01415d88 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 14 Jun 2022 10:27:00 +0000 Subject: Update ignore-glob --- .fossil-settings/ignore-glob | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/.fossil-settings/ignore-glob b/.fossil-settings/ignore-glob index 651d616..d14bd9c 100644 --- a/.fossil-settings/ignore-glob +++ b/.fossil-settings/ignore-glob @@ -54,9 +54,11 @@ unix/dltest/*.o unix/dltest/*.sl unix/dltest/*.so unix/tcl.pc +unix/tclUuid.h unix/tclIndex unix/Tcl-Info.plist unix/Tclsh-Info.plist +unix/*.zip unix/pkgs/* win/Debug* win/Release* @@ -64,5 +66,7 @@ win/*.manifest win/pkgs/* win/coffbase.txt win/tcl.hpj +win/tclUuid.h win/nmakehlp.out win/nmhlp-out.txt +win/*.zip \ No newline at end of file -- cgit v0.12 From 8698dce99dcfa9483a9925d8a9a66fb63f06f3a8 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 14 Jun 2022 12:54:30 +0000 Subject: Update .gitignore --- .fossil-settings/ignore-glob | 7 ++----- .gitignore | 3 ++- 2 files changed, 4 insertions(+), 6 deletions(-) diff --git a/.fossil-settings/ignore-glob b/.fossil-settings/ignore-glob index d14bd9c..306d5a5 100644 --- a/.fossil-settings/ignore-glob +++ b/.fossil-settings/ignore-glob @@ -24,7 +24,8 @@ */versions.vc */version.vc */libtcl.vfs -*/libtcl_*.zip +*/libtcl*.zip +*/tclUuid.h html libtommath/bn.ilg libtommath/bn.ind @@ -54,11 +55,9 @@ unix/dltest/*.o unix/dltest/*.sl unix/dltest/*.so unix/tcl.pc -unix/tclUuid.h unix/tclIndex unix/Tcl-Info.plist unix/Tclsh-Info.plist -unix/*.zip unix/pkgs/* win/Debug* win/Release* @@ -66,7 +65,5 @@ win/*.manifest win/pkgs/* win/coffbase.txt win/tcl.hpj -win/tclUuid.h win/nmakehlp.out win/nmhlp-out.txt -win/*.zip \ No newline at end of file diff --git a/.gitignore b/.gitignore index 33579cf..74bf502 100644 --- a/.gitignore +++ b/.gitignore @@ -30,7 +30,8 @@ _FOSSIL_ */versions.vc */version.vc */libtcl.vfs -*/libtcl_*.zip +*/libtcl*.zip +*/tclUuid.h libtommath/bn.ilg libtommath/bn.ind libtommath/pretty.build -- cgit v0.12 From d2cb5714faa8e3c9f583924a3f9a345d915aadd9 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 14 Jun 2022 13:48:01 +0000 Subject: Add more testcases for Tcl_GetRange() --- generic/tclTestObj.c | 20 ++++++++++++++++---- tests/stringObj.test | 25 +++++++++++++++++++++++++ 2 files changed, 41 insertions(+), 4 deletions(-) diff --git a/generic/tclTestObj.c b/generic/tclTestObj.c index 3fe9d02..b1a0afa 100644 --- a/generic/tclTestObj.c +++ b/generic/tclTestObj.c @@ -1184,7 +1184,7 @@ TeststringobjCmd( Tcl_Obj **varPtr; static const char *const options[] = { "append", "appendstrings", "get", "get2", "length", "length2", - "set", "set2", "setlength", "maxchars", "getunicode", + "set", "set2", "setlength", "maxchars", "range", "getunicode", "appendself", "appendself2", NULL }; @@ -1350,13 +1350,25 @@ TeststringobjCmd( } Tcl_SetIntObj(Tcl_GetObjResult(interp), length); break; - case 10: /* getunicode */ + case 10: { /* range */ + int first, last; + if (objc != 5) { + goto wrongNumArgs; + } + if ((Tcl_GetIntFromObj(interp, objv[3], &first) != TCL_OK) + || (Tcl_GetIntFromObj(interp, objv[4], &last) != TCL_OK)) { + return TCL_ERROR; + } + Tcl_SetObjResult(interp, Tcl_GetRange(varPtr[varIndex], first, last)); + break; + } + case 11: /* getunicode */ if (objc != 3) { goto wrongNumArgs; } Tcl_GetUnicodeFromObj(varPtr[varIndex], NULL); break; - case 11: /* appendself */ + case 12: /* appendself */ if (objc != 4) { goto wrongNumArgs; } @@ -1387,7 +1399,7 @@ TeststringobjCmd( Tcl_AppendToObj(varPtr[varIndex], string + i, length - i); Tcl_SetObjResult(interp, varPtr[varIndex]); break; - case 12: /* appendself2 */ + case 13: /* appendself2 */ if (objc != 4) { goto wrongNumArgs; } diff --git a/tests/stringObj.test b/tests/stringObj.test index bfe9da1..b799828 100644 --- a/tests/stringObj.test +++ b/tests/stringObj.test @@ -481,6 +481,31 @@ test stringObj-15.8 {Tcl_Append*ToObj: self appends} testobj { teststringobj appendself2 1 3 } foo +test stringObj-16.0 {Tcl_GetRange: normal case} testobj { + teststringobj set 1 abcde + teststringobj range 1 1 3 +} bcd +test stringObj-16.1 {Tcl_GetRange: first > end} testobj { + teststringobj set 1 abcde + teststringobj range 1 10 5 +} {} +test stringObj-16.2 {Tcl_GetRange: last > end} testobj { + teststringobj set 1 abcde + teststringobj range 1 3 13 +} de +test stringObj-16.3 {Tcl_GetRange: first = -1} testobj { + teststringobj set 1 abcde + teststringobj range 1 -1 3 +} abcd +test stringObj-16.4 {Tcl_GetRange: last = -1} testobj { + teststringobj set 1 abcde + teststringobj range 1 1 -1 +} bcde +test stringObj-16.5 {Tcl_GetRange: fist = last = -1} testobj { + teststringobj set 1 abcde + teststringobj range 1 -1 -1 +} abcde + if {[testConstraint testobj]} { testobj freeallvars -- cgit v0.12 From a69a0892a3f864965e5cfa5faf6efebc339e7f4e Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 14 Jun 2022 14:46:30 +0000 Subject: Bigger range for Tcl_GetRange() testcases --- generic/tclTestObj.c | 6 +++--- tests/stringObj.test | 6 +++--- 2 files changed, 6 insertions(+), 6 deletions(-) diff --git a/generic/tclTestObj.c b/generic/tclTestObj.c index e306998..4008b11 100644 --- a/generic/tclTestObj.c +++ b/generic/tclTestObj.c @@ -1319,12 +1319,12 @@ TeststringobjCmd( Tcl_SetWideIntObj(Tcl_GetObjResult(interp), length); break; case 10: { /* range */ - int first, last; + Tcl_WideInt first, last; if (objc != 5) { goto wrongNumArgs; } - if ((Tcl_GetIntFromObj(interp, objv[3], &first) != TCL_OK) - || (Tcl_GetIntFromObj(interp, objv[4], &last) != TCL_OK)) { + if ((Tcl_GetWideIntFromObj(interp, objv[3], &first) != TCL_OK) + || (Tcl_GetWideIntFromObj(interp, objv[4], &last) != TCL_OK)) { return TCL_ERROR; } Tcl_SetObjResult(interp, Tcl_GetRange(varPtr[varIndex], first, last)); diff --git a/tests/stringObj.test b/tests/stringObj.test index d19184b..e63cbdc 100644 --- a/tests/stringObj.test +++ b/tests/stringObj.test @@ -483,15 +483,15 @@ test stringObj-16.2 {Tcl_GetRange: last > end} testobj { teststringobj set 1 abcde teststringobj range 1 3 13 } de -test stringObj-16.3 {Tcl_GetRange: first = -1} testobj { +test stringObj-16.3 {Tcl_GetRange: first = TCL_INDEX_NONE} testobj { teststringobj set 1 abcde teststringobj range 1 -1 3 } abcd -test stringObj-16.4 {Tcl_GetRange: last = -1} testobj { +test stringObj-16.4 {Tcl_GetRange: last = TCL_INDEX_NONE} testobj { teststringobj set 1 abcde teststringobj range 1 1 -1 } bcde -test stringObj-16.5 {Tcl_GetRange: first = last = -1} testobj { +test stringObj-16.5 {Tcl_GetRange: first = last = TCL_INDEX_NONE} testobj { teststringobj set 1 abcde teststringobj range 1 -1 -1 } abcde -- cgit v0.12 From cd11a370748a0056f5d6968020773382050d3d6e Mon Sep 17 00:00:00 2001 From: kjnash Date: Wed, 15 Jun 2022 00:43:58 +0000 Subject: Minor bugfixes to library/http/http.tcl and tests/http.test --- library/http/http.tcl | 38 ++++++++++++++++++++++---------------- tests/http.test | 9 ++++++--- 2 files changed, 28 insertions(+), 19 deletions(-) diff --git a/library/http/http.tcl b/library/http/http.tcl index df44940..cae7e6e 100644 --- a/library/http/http.tcl +++ b/library/http/http.tcl @@ -291,7 +291,7 @@ proc http::Finish {token {errormsg ""} {skipCB 0}} { CloseSocket $state(sock) $token } elseif { ([info exists state(-keepalive)] && $state(-keepalive)) - && ([info exists state(connection)] && ("close" in $state(connection))) + && ([info exists state(connection)] && ("close" ni $state(connection))) } { KeepSocket $token } @@ -771,13 +771,18 @@ proc http::geturl {url args} { foreach {flag value} $args { if {[regexp -- $pat $flag]} { # Validate numbers - if { ([info exists type($flag)] && ![string is $type($flag) -strict $value]) - || ($flag eq "-headers" && [llength $value] % 2 != 0) + if { [info exists type($flag)] + && (![string is $type($flag) -strict $value]) } { unset $token return -code error \ "Bad value for $flag ($value), must be $type($flag)" } + if {($flag eq "-headers") && ([llength $value] % 2 != 0)} { + unset $token + return -code error \ + "Bad value for $flag ($value), number of list elements must be even" + } set state($flag) $value } else { unset $token @@ -981,7 +986,7 @@ proc http::geturl {url args} { set upgradeValues [SplitCommaSeparatedFieldValue \ [GetFieldValue $state(-headers) Upgrade]] set state(upgradeRequest) [expr { "upgrade" in $connectionValues - && [llength $upgradeValue] >= 1}] + && [llength $upgradeValues] >= 1}] if {$isQuery || $isQueryChannel} { # It's a POST. @@ -2701,6 +2706,19 @@ proc http::Event {sock token} { set state(state) body + # According to + # https://developer.mozilla.org/en-US/docs/Web/HTTP/Headers/Connection + # any comma-separated "Connection:" list implies keep-alive, but I + # don't see this in the RFC so we'll play safe and + # scan any list for "close". + # Done here to support combining duplicate header field's values. + if { [info exists state(connection)] + && ("close" ni $state(connection)) + && ("keep-alive" ni $state(connection)) + } { + lappend state(connection) "keep-alive" + } + # If doing a HEAD, then we won't get any body if {$state(-validate)} { Log ^F$tk end of response for HEAD request - token $token @@ -2795,18 +2813,6 @@ proc http::Event {sock token} { foreach el [SplitCommaSeparatedFieldValue $value] { lappend state(connection) [string tolower $el] } - - # According to - # https://developer.mozilla.org/en-US/docs/Web/HTTP/Headers/Connection - # any comma-separated list implies keep-alive, but I - # don't see this in the RFC so we'll play safe and - # scan any list for "close". - # FIXME: support combining duplicate header field's values. - if { "close" ni $state(connection) - && "keep-alive" ni $state(connection) - } { - lappend state(connection) "keep-alive" - } } upgrade { set state(upgrade) [string trim $value] diff --git a/tests/http.test b/tests/http.test index 40113dc..b0f5144 100644 --- a/tests/http.test +++ b/tests/http.test @@ -468,9 +468,12 @@ test http-3.33 {http::geturl application/xml is text} -body { } -cleanup { catch { http::cleanup $token } } -result {test 4660 /test} -test http-3.34 {http::geturl -headers not a dict} -returnCodes error -body { - http::geturl http://test/t -headers NoDict -} -result {Bad value for -headers (NoDict), must be dict} +test http-3.34 {http::geturl -headers not a list} -returnCodes error -body { + http::geturl http://test/t -headers \" +} -result {Bad value for -headers ("), must be list} +test http-3.35 {http::geturl -headers not even number of elements} -returnCodes error -body { + http::geturl http://test/t -headers {List Length 3} +} -result {Bad value for -headers (List Length 3), number of list elements must be even} test http-4.1 {http::Event} -body { set token [http::geturl $url -keepalive 0] -- cgit v0.12 From 4837653d64debe20eb2ef71dca9813510502168f Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 15 Jun 2022 09:25:41 +0000 Subject: Disable tests (conditionally) which cannot run without the UTF16 compatibility layer (TIP #622) --- tests/stringObj.test | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/tests/stringObj.test b/tests/stringObj.test index 437d8c2..c1633bf 100644 --- a/tests/stringObj.test +++ b/tests/stringObj.test @@ -473,27 +473,27 @@ test stringObj-15.8 {Tcl_Append*ToObj: self appends} {testobj tip389 deprecated} teststringobj appendself2 1 3 } foo -test stringObj-16.0 {Tcl_GetRange: normal case} testobj { +test stringObj-16.0 {Tcl_GetRange: normal case} {testobj deprecated} { teststringobj set 1 abcde teststringobj range 1 1 3 } bcd -test stringObj-16.1 {Tcl_GetRange: first > end} testobj { +test stringObj-16.1 {Tcl_GetRange: first > end} {testobj deprecated} { teststringobj set 1 abcde teststringobj range 1 10 5 } {} -test stringObj-16.2 {Tcl_GetRange: last > end} testobj { +test stringObj-16.2 {Tcl_GetRange: last > end} {testobj deprecated} { teststringobj set 1 abcde teststringobj range 1 3 13 } de -test stringObj-16.3 {Tcl_GetRange: first = -1} testobj { +test stringObj-16.3 {Tcl_GetRange: first = -1} {testobj deprecated} { teststringobj set 1 abcde teststringobj range 1 -1 3 } abcd -test stringObj-16.4 {Tcl_GetRange: last = -1} testobj { +test stringObj-16.4 {Tcl_GetRange: last = -1} {testobj deprecated} { teststringobj set 1 abcde teststringobj range 1 1 -1 } bcde -test stringObj-16.5 {Tcl_GetRange: fist = last = -1} testobj { +test stringObj-16.5 {Tcl_GetRange: fist = last = -1} {testobj deprecated} { teststringobj set 1 abcde teststringobj range 1 -1 -1 } abcde -- cgit v0.12 From f9299159657f3c19b59f37dd1de2d580dae51397 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 15 Jun 2022 10:04:41 +0000 Subject: Backport tclStubLib.c from Tcl 9.0 (they should be equal in 8.7 and 9.0) --- generic/tclStubLib.c | 9 ++++++++- 1 file changed, 8 insertions(+), 1 deletion(-) diff --git a/generic/tclStubLib.c b/generic/tclStubLib.c index 46d2f90..f06b2d1 100644 --- a/generic/tclStubLib.c +++ b/generic/tclStubLib.c @@ -17,11 +17,13 @@ MODULE_SCOPE const TclStubs *tclStubsPtr; MODULE_SCOPE const TclPlatStubs *tclPlatStubsPtr; MODULE_SCOPE const TclIntStubs *tclIntStubsPtr; MODULE_SCOPE const TclIntPlatStubs *tclIntPlatStubsPtr; +MODULE_SCOPE void *tclStubsHandle; const TclStubs *tclStubsPtr = NULL; const TclPlatStubs *tclPlatStubsPtr = NULL; const TclIntStubs *tclIntStubsPtr = NULL; const TclIntPlatStubs *tclIntPlatStubsPtr = NULL; +void *tclStubsHandle = NULL; /* * Use our own ISDIGIT to avoid linking to libc on windows @@ -56,10 +58,12 @@ Tcl_InitStubs( { Interp *iPtr = (Interp *)interp; const char *actualVersion = NULL; - ClientData pkgData = NULL; + void *pkgData = NULL; const TclStubs *stubsPtr = iPtr->stubTable; const char *tclName = (((exact&0xFF00) >= 0x900) ? "tcl" : "Tcl"); +#undef TCL_STUB_MAGIC /* We need the TCL_STUB_MAGIC from Tcl 8.x here */ +#define TCL_STUB_MAGIC ((int) 0xFCA3BACF) /* * We can't optimize this check by caching tclStubsPtr because that * prevents apps from being able to load/unload Tcl dynamically multiple @@ -106,6 +110,9 @@ Tcl_InitStubs( /* We are running Tcl 8.x */ stubsPtr = (TclStubs *)pkgData; } + if (tclStubsHandle == NULL) { + tclStubsHandle = INT2PTR(-1); + } tclStubsPtr = stubsPtr; if (stubsPtr->hooks) { -- cgit v0.12 From 5b8c04a70a776616bda6c47500f65e46cf926941 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 15 Jun 2022 11:46:40 +0000 Subject: Remove the Tcl_GetByteArrayFromObj/TclGetByteArrayFromObj stub entries: Those are macro's now. --- generic/tcl.decls | 12 +++++++----- generic/tclBinary.c | 37 ------------------------------------- generic/tclDecls.h | 14 +++++++++----- generic/tclStubInit.c | 20 +++++++++++++------- 4 files changed, 29 insertions(+), 54 deletions(-) diff --git a/generic/tcl.decls b/generic/tcl.decls index 7e625d4..26f0975 100644 --- a/generic/tcl.decls +++ b/generic/tcl.decls @@ -144,8 +144,9 @@ declare 32 { int Tcl_GetBooleanFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr, int *intPtr) } +# Only available in Tcl 8.x, NULL in Tcl 9.0 declare 33 { - unsigned char *TclGetByteArrayFromObj(Tcl_Obj *objPtr, int *lengthPtr) + unsigned char *TclGetByteArrayFromObj(Tcl_Obj *objPtr, int *numBytesPtr) } declare 34 { int Tcl_GetDouble(Tcl_Interp *interp, const char *src, double *doublePtr) @@ -312,10 +313,10 @@ declare 79 { declare 80 { void Tcl_CancelIdleCall(Tcl_IdleProc *idleProc, void *clientData) } -# Removed in 9.0: -#declare 81 { -# int Tcl_Close(Tcl_Interp *interp, Tcl_Channel chan) -#} +# Only available in Tcl 8.x, NULL in Tcl 9.0 +declare 81 { + int Tcl_Close(Tcl_Interp *interp, Tcl_Channel chan) +} declare 82 { int Tcl_CommandComplete(const char *cmd) } @@ -2480,6 +2481,7 @@ declare 651 { declare 652 { Tcl_UniChar *Tcl_GetUnicodeFromObj(Tcl_Obj *objPtr, size_t *lengthPtr) } +# Only available in Tcl 8.x, NULL in Tcl 9.0 declare 653 { unsigned char *Tcl_GetByteArrayFromObj(Tcl_Obj *objPtr, size_t *numBytesPtr) } diff --git a/generic/tclBinary.c b/generic/tclBinary.c index a45e4b2..90efc9f 100644 --- a/generic/tclBinary.c +++ b/generic/tclBinary.c @@ -408,43 +408,6 @@ TclGetBytesFromObj( /* *---------------------------------------------------------------------- * - * Tcl_GetByteArrayFromObj -- - * - * Attempt to get the array of bytes from the Tcl object. If the object - * is not already a ByteArray object, an attempt will be made to convert - * it to one. - * - * Results: - * Pointer to array of bytes representing the ByteArray object. - * - * Side effects: - * Frees old internal rep. Allocates memory for new internal rep. - * - *---------------------------------------------------------------------- - */ - -#undef Tcl_GetByteArrayFromObj -unsigned char * -TclGetByteArrayFromObj( - Tcl_Obj *objPtr, /* The ByteArray object. */ - int *numBytesPtr) /* If non-NULL, write the number of bytes - * in the array here */ -{ - return TclGetBytesFromObj(NULL, objPtr, numBytesPtr); -} - -unsigned char * -Tcl_GetByteArrayFromObj( - Tcl_Obj *objPtr, /* The ByteArray object. */ - size_t *numBytesPtr) /* If non-NULL, write the number of bytes - * in the array here */ -{ - return Tcl_GetBytesFromObj(NULL, objPtr, numBytesPtr); -} - -/* - *---------------------------------------------------------------------- - * * Tcl_SetByteArrayLength -- * * This procedure changes the length of the byte array for this object. diff --git a/generic/tclDecls.h b/generic/tclDecls.h index 677b1dd..a0fee3e 100644 --- a/generic/tclDecls.h +++ b/generic/tclDecls.h @@ -135,7 +135,7 @@ EXTERN int Tcl_GetBooleanFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr, int *intPtr); /* 33 */ EXTERN unsigned char * TclGetByteArrayFromObj(Tcl_Obj *objPtr, - int *lengthPtr); + int *numBytesPtr); /* 34 */ EXTERN int Tcl_GetDouble(Tcl_Interp *interp, const char *src, double *doublePtr); @@ -244,7 +244,8 @@ EXTERN void Tcl_CallWhenDeleted(Tcl_Interp *interp, /* 80 */ EXTERN void Tcl_CancelIdleCall(Tcl_IdleProc *idleProc, void *clientData); -/* Slot 81 is reserved */ +/* 81 */ +EXTERN int Tcl_Close(Tcl_Interp *interp, Tcl_Channel chan); /* 82 */ EXTERN int Tcl_CommandComplete(const char *cmd); /* 83 */ @@ -1851,7 +1852,7 @@ typedef struct TclStubs { void (*tclFreeObj) (Tcl_Obj *objPtr); /* 30 */ int (*tcl_GetBoolean) (Tcl_Interp *interp, const char *src, int *intPtr); /* 31 */ int (*tcl_GetBooleanFromObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, int *intPtr); /* 32 */ - unsigned char * (*tclGetByteArrayFromObj) (Tcl_Obj *objPtr, int *lengthPtr); /* 33 */ + unsigned char * (*tclGetByteArrayFromObj) (Tcl_Obj *objPtr, int *numBytesPtr); /* 33 */ int (*tcl_GetDouble) (Tcl_Interp *interp, const char *src, double *doublePtr); /* 34 */ int (*tcl_GetDoubleFromObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, double *doublePtr); /* 35 */ void (*reserved36)(void); @@ -1899,7 +1900,7 @@ typedef struct TclStubs { int (*tcl_BadChannelOption) (Tcl_Interp *interp, const char *optionName, const char *optionList); /* 78 */ void (*tcl_CallWhenDeleted) (Tcl_Interp *interp, Tcl_InterpDeleteProc *proc, void *clientData); /* 79 */ void (*tcl_CancelIdleCall) (Tcl_IdleProc *idleProc, void *clientData); /* 80 */ - void (*reserved81)(void); + int (*tcl_Close) (Tcl_Interp *interp, Tcl_Channel chan); /* 81 */ int (*tcl_CommandComplete) (const char *cmd); /* 82 */ char * (*tcl_Concat) (size_t argc, const char *const *argv); /* 83 */ size_t (*tcl_ConvertElement) (const char *src, char *dst, int flags); /* 84 */ @@ -2655,7 +2656,8 @@ extern const TclStubs *tclStubsPtr; (tclStubsPtr->tcl_CallWhenDeleted) /* 79 */ #define Tcl_CancelIdleCall \ (tclStubsPtr->tcl_CancelIdleCall) /* 80 */ -/* Slot 81 is reserved */ +#define Tcl_Close \ + (tclStubsPtr->tcl_Close) /* 81 */ #define Tcl_CommandComplete \ (tclStubsPtr->tcl_CommandComplete) /* 82 */ #define Tcl_Concat \ @@ -3937,6 +3939,7 @@ extern const TclStubs *tclStubsPtr; #undef Tcl_GetIndexFromObjStruct #undef Tcl_GetStringFromObj #undef Tcl_GetUnicodeFromObj +#undef TclGetByteArrayFromObj #undef Tcl_GetByteArrayFromObj #undef Tcl_GetBytesFromObj #if defined(USE_TCL_STUBS) @@ -4151,6 +4154,7 @@ extern const TclStubs *tclStubsPtr; # endif #endif +#undef Tcl_Close #define Tcl_Close(interp, chan) Tcl_CloseEx(interp, chan, 0) #undef TclUtfCharComplete diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c index f41321f..0bbf756 100644 --- a/generic/tclStubInit.c +++ b/generic/tclStubInit.c @@ -71,6 +71,12 @@ #undef Tcl_WinConvertError #define Tcl_WinConvertError 0 #endif +#undef Tcl_Close +#define Tcl_Close 0 +#undef TclGetByteArrayFromObj +#define TclGetByteArrayFromObj 0 +#undef Tcl_GetByteArrayFromObj +#define Tcl_GetByteArrayFromObj 0 #if TCL_UTF_MAX < 4 @@ -93,7 +99,7 @@ int TclListObjGetElements(Tcl_Interp *interp, Tcl_Obj *listPtr, size_t n = TCL_INDEX_NONE; int result = Tcl_ListObjGetElements(interp, listPtr, &n, objvPtr); if (objcPtr) { - if ((result == TCL_OK) && (n > INT_MAX)) { + if ((sizeof(int) != sizeof(size_t)) && (result == TCL_OK) && (n > INT_MAX)) { if (interp) { Tcl_AppendResult(interp, "List too large to be processed", NULL); } @@ -108,7 +114,7 @@ int TclListObjLength(Tcl_Interp *interp, Tcl_Obj *listPtr, size_t n = TCL_INDEX_NONE; int result = Tcl_ListObjLength(interp, listPtr, &n); if (lengthPtr) { - if ((result == TCL_OK) && (n > INT_MAX)) { + if ((sizeof(int) != sizeof(size_t)) && (result == TCL_OK) && (n > INT_MAX)) { if (interp) { Tcl_AppendResult(interp, "List too large to be processed", NULL); } @@ -123,7 +129,7 @@ int TclDictObjSize(Tcl_Interp *interp, Tcl_Obj *dictPtr, size_t n = TCL_INDEX_NONE; int result = Tcl_DictObjSize(interp, dictPtr, &n); if (sizePtr) { - if ((result == TCL_OK) && (n > INT_MAX)) { + if ((sizeof(int) != sizeof(size_t)) && (result == TCL_OK) && (n > INT_MAX)) { if (interp) { Tcl_AppendResult(interp, "Dict too large to be processed", NULL); } @@ -138,7 +144,7 @@ int TclSplitList(Tcl_Interp *interp, const char *listStr, int *argcPtr, size_t n = TCL_INDEX_NONE; int result = Tcl_SplitList(interp, listStr, &n, argvPtr); if (argcPtr) { - if ((result == TCL_OK) && (n > INT_MAX)) { + if ((sizeof(int) != sizeof(size_t)) && (result == TCL_OK) && (n > INT_MAX)) { if (interp) { Tcl_AppendResult(interp, "List too large to be processed", NULL); } @@ -153,7 +159,7 @@ void TclSplitPath(const char *path, int *argcPtr, const char ***argvPtr) { size_t n = TCL_INDEX_NONE; Tcl_SplitPath(path, &n, argvPtr); if (argcPtr) { - if (n > INT_MAX) { + if ((sizeof(int) != sizeof(size_t)) && (n > INT_MAX)) { n = TCL_INDEX_NONE; /* No other way to return an error-situation */ Tcl_Free((void *)*argvPtr); *argvPtr = NULL; @@ -165,7 +171,7 @@ Tcl_Obj *TclFSSplitPath(Tcl_Obj *pathPtr, int *lenPtr) { size_t n = TCL_INDEX_NONE; Tcl_Obj *result = Tcl_FSSplitPath(pathPtr, &n); if (lenPtr) { - if (result && (n > INT_MAX)) { + if ((sizeof(int) != sizeof(size_t)) && result && (n > INT_MAX)) { Tcl_DecrRefCount(result); return NULL; } @@ -867,7 +873,7 @@ const TclStubs tclStubs = { Tcl_BadChannelOption, /* 78 */ Tcl_CallWhenDeleted, /* 79 */ Tcl_CancelIdleCall, /* 80 */ - 0, /* 81 */ + Tcl_Close, /* 81 */ Tcl_CommandComplete, /* 82 */ Tcl_Concat, /* 83 */ Tcl_ConvertElement, /* 84 */ -- cgit v0.12 From c23518984f1b61e136d4e57f9554c5f8d3c1d26a Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 15 Jun 2022 12:15:59 +0000 Subject: Add comments in tcl.decls --- generic/tcl.decls | 3 +++ 1 file changed, 3 insertions(+) diff --git a/generic/tcl.decls b/generic/tcl.decls index 264bf99..7788ae1 100644 --- a/generic/tcl.decls +++ b/generic/tcl.decls @@ -142,6 +142,7 @@ declare 32 { int Tcl_GetBooleanFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr, int *intPtr) } +# Only available in Tcl 8.x, NULL in Tcl 9.0 declare 33 { unsigned char *Tcl_GetByteArrayFromObj(Tcl_Obj *objPtr, int *numBytesPtr) } @@ -299,6 +300,7 @@ declare 79 { declare 80 { void Tcl_CancelIdleCall(Tcl_IdleProc *idleProc, ClientData clientData) } +# Only available in Tcl 8.x, NULL in Tcl 9.0 declare 81 { int Tcl_Close(Tcl_Interp *interp, Tcl_Channel chan) } @@ -2421,6 +2423,7 @@ declare 651 { declare 652 { unsigned short *TclGetUnicodeFromObj(Tcl_Obj *objPtr, size_t *lengthPtr) } +# Only available in Tcl 8.x, NULL in Tcl 9.0 declare 653 { unsigned char *TclGetByteArrayFromObj(Tcl_Obj *objPtr, size_t *numBytesPtr) } -- cgit v0.12 From 474c08922f5e9eb3699fba6cf236e4fde61ae390 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 15 Jun 2022 15:12:27 +0000 Subject: (experimental) TclOO > 2**31 args --- generic/tclExecute.c | 6 ++++- generic/tclOO.decls | 14 +++++++++++ generic/tclOO.h | 23 +++++++++++++++++- generic/tclOOCall.c | 6 ++++- generic/tclOODecls.h | 23 ++++++++++++++++++ generic/tclOOMethod.c | 63 +++++++++++++++++++++++++++++++++++++++++++++++++ generic/tclOOStubInit.c | 3 +++ 7 files changed, 135 insertions(+), 3 deletions(-) diff --git a/generic/tclExecute.c b/generic/tclExecute.c index 2b197c6..fe809c1 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -4787,7 +4787,11 @@ TEBCresume( Method *const mPtr = contextPtr->callPtr->chain[newDepth].mPtr; - return mPtr->typePtr->callProc(mPtr->clientData, interp, + if (mPtr->typePtr->version == TCL_OO_METHOD_VERSION_1) { + return mPtr->typePtr->callProc(mPtr->clientData, interp, + (Tcl_ObjectContext) contextPtr, opnd, objv); + } + return ((Tcl_MethodCallProc2 *)(void *)(mPtr->typePtr->callProc))(mPtr->clientData, interp, (Tcl_ObjectContext) contextPtr, opnd, objv); } diff --git a/generic/tclOO.decls b/generic/tclOO.decls index e4063c7..3507c73 100644 --- a/generic/tclOO.decls +++ b/generic/tclOO.decls @@ -135,6 +135,20 @@ declare 30 { declare 31 { Tcl_Obj *Tcl_GetObjectClassName(Tcl_Interp *interp, Tcl_Object object) } +declare 32 { + int Tcl_MethodIsType2(Tcl_Method method, const Tcl_MethodType2 *typePtr, + void **clientDataPtr) +} +declare 33 { + Tcl_Method Tcl_NewInstanceMethod2(Tcl_Interp *interp, Tcl_Object object, + Tcl_Obj *nameObj, int flags, const Tcl_MethodType2 *typePtr, + void *clientData) +} +declare 34 { + Tcl_Method Tcl_NewMethod2(Tcl_Interp *interp, Tcl_Class cls, + Tcl_Obj *nameObj, int flags, const Tcl_MethodType2 *typePtr, + void *clientData) +} ###################################################################### # Private API, exposed to support advanced OO systems that plug in on top of diff --git a/generic/tclOO.h b/generic/tclOO.h index 9c1dd1e..0ddb13c 100644 --- a/generic/tclOO.h +++ b/generic/tclOO.h @@ -62,6 +62,8 @@ typedef struct Tcl_ObjectContext_ *Tcl_ObjectContext; typedef int (Tcl_MethodCallProc)(ClientData clientData, Tcl_Interp *interp, Tcl_ObjectContext objectContext, int objc, Tcl_Obj *const *objv); +typedef int (Tcl_MethodCallProc2)(ClientData clientData, Tcl_Interp *interp, + Tcl_ObjectContext objectContext, size_t objc, Tcl_Obj *const *objv); typedef void (Tcl_MethodDeleteProc)(ClientData clientData); typedef int (Tcl_CloneProc)(Tcl_Interp *interp, ClientData oldClientData, ClientData *newClientData); @@ -77,7 +79,7 @@ typedef int (Tcl_ObjectMapMethodNameProc)(Tcl_Interp *interp, typedef struct { int version; /* Structure version field. Always to be equal - * to TCL_OO_METHOD_VERSION_CURRENT in + * to TCL_OO_METHOD_VERSION_(1|CURRENT) in * declarations. */ const char *name; /* Name of this type of method, mostly for * debugging purposes. */ @@ -92,12 +94,31 @@ typedef struct { * be copied directly. */ } Tcl_MethodType; +typedef struct { + int version; /* Structure version field. Always to be equal + * to TCL_OO_METHOD_VERSION_2 in + * declarations. */ + const char *name; /* Name of this type of method, mostly for + * debugging purposes. */ + Tcl_MethodCallProc2 *callProc; + /* How to invoke this method. */ + Tcl_MethodDeleteProc *deleteProc; + /* How to delete this method's type-specific + * data, or NULL if the type-specific data + * does not need deleting. */ + Tcl_CloneProc *cloneProc; /* How to copy this method's type-specific + * data, or NULL if the type-specific data can + * be copied directly. */ +} Tcl_MethodType2; + /* * The correct value for the version field of the Tcl_MethodType structure. * This allows new versions of the structure to be introduced without breaking * binary compatability. */ +#define TCL_OO_METHOD_VERSION_1 1 +#define TCL_OO_METHOD_VERSION_2 2 #define TCL_OO_METHOD_VERSION_CURRENT 1 /* diff --git a/generic/tclOOCall.c b/generic/tclOOCall.c index d265c1a..5558ab2 100644 --- a/generic/tclOOCall.c +++ b/generic/tclOOCall.c @@ -369,7 +369,11 @@ TclOOInvokeContext( * Run the method implementation. */ - return mPtr->typePtr->callProc(mPtr->clientData, interp, + if (mPtr->typePtr->version == TCL_OO_METHOD_VERSION_1) { + return (mPtr->typePtr->callProc)(mPtr->clientData, interp, + (Tcl_ObjectContext) contextPtr, objc, objv); + } + return ((Tcl_MethodCallProc2 *)(void *)(mPtr->typePtr->callProc))(mPtr->clientData, interp, (Tcl_ObjectContext) contextPtr, objc, objv); } diff --git a/generic/tclOODecls.h b/generic/tclOODecls.h index 3be1e3d..f75d65a 100644 --- a/generic/tclOODecls.h +++ b/generic/tclOODecls.h @@ -123,6 +123,20 @@ TCLAPI Tcl_Class Tcl_GetClassOfObject(Tcl_Object object); /* 31 */ TCLAPI Tcl_Obj * Tcl_GetObjectClassName(Tcl_Interp *interp, Tcl_Object object); +/* 32 */ +TCLAPI int Tcl_MethodIsType2(Tcl_Method method, + const Tcl_MethodType2 *typePtr, + void **clientDataPtr); +/* 33 */ +TCLAPI Tcl_Method Tcl_NewInstanceMethod2(Tcl_Interp *interp, + Tcl_Object object, Tcl_Obj *nameObj, + int flags, const Tcl_MethodType2 *typePtr, + void *clientData); +/* 34 */ +TCLAPI Tcl_Method Tcl_NewMethod2(Tcl_Interp *interp, Tcl_Class cls, + Tcl_Obj *nameObj, int flags, + const Tcl_MethodType2 *typePtr, + void *clientData); typedef struct { const struct TclOOIntStubs *tclOOIntStubs; @@ -164,6 +178,9 @@ typedef struct TclOOStubs { int (*tcl_MethodIsPrivate) (Tcl_Method method); /* 29 */ Tcl_Class (*tcl_GetClassOfObject) (Tcl_Object object); /* 30 */ Tcl_Obj * (*tcl_GetObjectClassName) (Tcl_Interp *interp, Tcl_Object object); /* 31 */ + int (*tcl_MethodIsType2) (Tcl_Method method, const Tcl_MethodType2 *typePtr, void **clientDataPtr); /* 32 */ + Tcl_Method (*tcl_NewInstanceMethod2) (Tcl_Interp *interp, Tcl_Object object, Tcl_Obj *nameObj, int flags, const Tcl_MethodType2 *typePtr, void *clientData); /* 33 */ + Tcl_Method (*tcl_NewMethod2) (Tcl_Interp *interp, Tcl_Class cls, Tcl_Obj *nameObj, int flags, const Tcl_MethodType2 *typePtr, void *clientData); /* 34 */ } TclOOStubs; extern const TclOOStubs *tclOOStubsPtr; @@ -242,6 +259,12 @@ extern const TclOOStubs *tclOOStubsPtr; (tclOOStubsPtr->tcl_GetClassOfObject) /* 30 */ #define Tcl_GetObjectClassName \ (tclOOStubsPtr->tcl_GetObjectClassName) /* 31 */ +#define Tcl_MethodIsType2 \ + (tclOOStubsPtr->tcl_MethodIsType2) /* 32 */ +#define Tcl_NewInstanceMethod2 \ + (tclOOStubsPtr->tcl_NewInstanceMethod2) /* 33 */ +#define Tcl_NewMethod2 \ + (tclOOStubsPtr->tcl_NewMethod2) /* 34 */ #endif /* defined(USE_TCLOO_STUBS) */ diff --git a/generic/tclOOMethod.c b/generic/tclOOMethod.c index ae1f3bd..29f86d4 100644 --- a/generic/tclOOMethod.c +++ b/generic/tclOOMethod.c @@ -187,6 +187,28 @@ Tcl_NewInstanceMethod( oPtr->epoch++; return (Tcl_Method) mPtr; } +Tcl_Method +Tcl_NewInstanceMethod2( + TCL_UNUSED(Tcl_Interp *), + Tcl_Object object, /* The object that has the method attached to + * it. */ + Tcl_Obj *nameObj, /* The name of the method. May be NULL; if so, + * up to caller to manage storage (e.g., when + * it is a constructor or destructor). */ + int flags, /* Whether this is a public method. */ + const Tcl_MethodType2 *typePtr, + /* The type of method this is, which defines + * how to invoke, delete and clone the + * method. */ + void *clientData) /* Some data associated with the particular + * method to be created. */ +{ + if (typePtr->version == TCL_OO_METHOD_VERSION_1) { + Tcl_Panic("%s: Wrong version in typePtr->version, should be TCL_OO_METHOD_VERSION_2", "Tcl_NewInstanceMethod2"); + } + return Tcl_NewInstanceMethod(NULL, object, nameObj, flags, + (const Tcl_MethodType *)typePtr, clientData); +} /* * ---------------------------------------------------------------------- @@ -255,6 +277,27 @@ Tcl_NewMethod( return (Tcl_Method) mPtr; } + +Tcl_Method +Tcl_NewMethod2( + TCL_UNUSED(Tcl_Interp *), + Tcl_Class cls, /* The class to attach the method to. */ + Tcl_Obj *nameObj, /* The name of the object. May be NULL (e.g., + * for constructors or destructors); if so, up + * to caller to manage storage. */ + int flags, /* Whether this is a public method. */ + const Tcl_MethodType2 *typePtr, + /* The type of method this is, which defines + * how to invoke, delete and clone the + * method. */ + void *clientData) /* Some data associated with the particular + * method to be created. */ +{ + if (typePtr->version == TCL_OO_METHOD_VERSION_1) { + Tcl_Panic("%s: Wrong version in typePtr->version, should be TCL_OO_METHOD_VERSION_2", "Tcl_NewMethod2"); + } + return Tcl_NewMethod(NULL, cls, nameObj, flags, (const Tcl_MethodType *)typePtr, clientData); +} /* * ---------------------------------------------------------------------- @@ -1689,6 +1732,26 @@ Tcl_MethodIsType( } int +Tcl_MethodIsType2( + Tcl_Method method, + const Tcl_MethodType2 *typePtr, + void **clientDataPtr) +{ + Method *mPtr = (Method *) method; + + if (typePtr->version == TCL_OO_METHOD_VERSION_1) { + Tcl_Panic("%s: Wrong version in typePtr->version, should be TCL_OO_METHOD_VERSION_2", "Tcl_NewInstanceMethod2"); + } + if (mPtr->typePtr == (const Tcl_MethodType *)typePtr) { + if (clientDataPtr != NULL) { + *clientDataPtr = mPtr->clientData; + } + return 1; + } + return 0; +} + +int Tcl_MethodIsPublic( Tcl_Method method) { diff --git a/generic/tclOOStubInit.c b/generic/tclOOStubInit.c index b9034f0..7b653cb 100644 --- a/generic/tclOOStubInit.c +++ b/generic/tclOOStubInit.c @@ -76,6 +76,9 @@ const TclOOStubs tclOOStubs = { Tcl_MethodIsPrivate, /* 29 */ Tcl_GetClassOfObject, /* 30 */ Tcl_GetObjectClassName, /* 31 */ + Tcl_MethodIsType2, /* 32 */ + Tcl_NewInstanceMethod2, /* 33 */ + Tcl_NewMethod2, /* 34 */ }; /* !END!: Do not edit above this line. */ -- cgit v0.12 From 3ac19cb2d70e938db457aed8f874a2a773ad6567 Mon Sep 17 00:00:00 2001 From: bch Date: Sun, 19 Jun 2022 01:22:08 +0000 Subject: correct LinkVar.3 per [ddaa30125], TIP 312 --- doc/LinkVar.3 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/doc/LinkVar.3 b/doc/LinkVar.3 index de37938..7755b05 100644 --- a/doc/LinkVar.3 +++ b/doc/LinkVar.3 @@ -53,7 +53,7 @@ used. .sp .VS "TIP 312" In \fBTcl_LinkArray\fR, the additional linked types \fBTCL_LINK_CHARS\fR and -\fBTCL_LINK_BYTES\fR may be used. +\fBTCL_LINK_BINARY\fR may be used. .VE "TIP 312" .sp All the above for both functions may be -- cgit v0.12 From 45f0e272f9575641226e0788d0adaa82fb5251ef Mon Sep 17 00:00:00 2001 From: bch Date: Sun, 19 Jun 2022 05:03:00 +0000 Subject: How about fixing all instances (follow-up to [9c4dcc7347])? --- doc/LinkVar.3 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/doc/LinkVar.3 b/doc/LinkVar.3 index 7755b05..40399ac 100644 --- a/doc/LinkVar.3 +++ b/doc/LinkVar.3 @@ -146,11 +146,11 @@ prefix) are accepted as if they are valid too. .RS .PP .VS "TIP 312" -If using an array of these, consider using \fBTCL_LINK_BYTES\fR instead. +If using an array of these, consider using \fBTCL_LINK_BINARY\fR instead. .VE "TIP 312" .RE .TP -\fBTCL_LINK_BYTES\fR +\fBTCL_LINK_BINARY\fR .VS "TIP 312" The C array is of type \fBunsigned char *\fR and is mapped into Tcl as a bytearray. -- cgit v0.12 -- cgit v0.12 From e3b234e70992ea1e4ccf0a5b2f7ff56fc7513b3a Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Sun, 19 Jun 2022 19:32:59 +0000 Subject: Implement Tcl_NRCallObjProc2 --- generic/tcl.decls | 4 ++++ generic/tclBasic.c | 31 +++++++++++++++++++++++++++++++ generic/tclDecls.h | 7 +++++++ generic/tclStubInit.c | 1 + 4 files changed, 43 insertions(+) diff --git a/generic/tcl.decls b/generic/tcl.decls index e2b1db0..dcc0da5 100644 --- a/generic/tcl.decls +++ b/generic/tcl.decls @@ -2519,6 +2519,10 @@ declare 678 { Tcl_ObjCmdProc2 *nreProc2, void *clientData, Tcl_CmdDeleteProc *deleteProc) } +declare 679 { + int Tcl_NRCallObjProc2(Tcl_Interp *interp, Tcl_ObjCmdProc2 *objProc2, + void *clientData, size_t objc, Tcl_Obj *const objv[]) +} # ----- BASELINE -- FOR -- 8.7.0 ----- # diff --git a/generic/tclBasic.c b/generic/tclBasic.c index 2f09944..063afca 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -9178,6 +9178,37 @@ Tcl_NRCallObjProc( return TclNRRunCallbacks(interp, TCL_OK, rootPtr); } +int wrapperNRObjProc( + void *clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const objv[]) +{ + CmdWrapperInfo *info = (CmdWrapperInfo *)clientData; + clientData = info->clientData; + Tcl_ObjCmdProc2 *proc = info->proc; + ckfree(info); + return proc(clientData, interp, objc, objv); +} + +int +Tcl_NRCallObjProc2( + Tcl_Interp *interp, + Tcl_ObjCmdProc2 *objProc, + void *clientData, + size_t objc, + Tcl_Obj *const objv[]) +{ + NRE_callback *rootPtr = TOP_CB(interp); + CmdWrapperInfo *info = (CmdWrapperInfo *)ckalloc(sizeof(CmdWrapperInfo)); + info->clientData = clientData; + info->proc = objProc; + + TclNRAddCallback(interp, Dispatch, wrapperNRObjProc, info, + INT2PTR(objc), objv); + return TclNRRunCallbacks(interp, TCL_OK, rootPtr); +} + /* *---------------------------------------------------------------------- * diff --git a/generic/tclDecls.h b/generic/tclDecls.h index 13abdfd..2a6e62c 100644 --- a/generic/tclDecls.h +++ b/generic/tclDecls.h @@ -2007,6 +2007,10 @@ EXTERN Tcl_Command Tcl_NRCreateCommand2(Tcl_Interp *interp, const char *cmdName, Tcl_ObjCmdProc2 *proc, Tcl_ObjCmdProc2 *nreProc2, void *clientData, Tcl_CmdDeleteProc *deleteProc); +/* 679 */ +EXTERN int Tcl_NRCallObjProc2(Tcl_Interp *interp, + Tcl_ObjCmdProc2 *objProc2, void *clientData, + size_t objc, Tcl_Obj *const objv[]); typedef struct { const struct TclPlatStubs *tclPlatStubs; @@ -2721,6 +2725,7 @@ typedef struct TclStubs { Tcl_Command (*tcl_CreateObjCommand2) (Tcl_Interp *interp, const char *cmdName, Tcl_ObjCmdProc2 *proc2, void *clientData, Tcl_CmdDeleteProc *deleteProc); /* 676 */ Tcl_Trace (*tcl_CreateObjTrace2) (Tcl_Interp *interp, int level, int flags, Tcl_CmdObjTraceProc2 *objProc2, void *clientData, Tcl_CmdObjTraceDeleteProc *delProc); /* 677 */ Tcl_Command (*tcl_NRCreateCommand2) (Tcl_Interp *interp, const char *cmdName, Tcl_ObjCmdProc2 *proc, Tcl_ObjCmdProc2 *nreProc2, void *clientData, Tcl_CmdDeleteProc *deleteProc); /* 678 */ + int (*tcl_NRCallObjProc2) (Tcl_Interp *interp, Tcl_ObjCmdProc2 *objProc2, void *clientData, size_t objc, Tcl_Obj *const objv[]); /* 679 */ } TclStubs; extern const TclStubs *tclStubsPtr; @@ -4107,6 +4112,8 @@ extern const TclStubs *tclStubsPtr; (tclStubsPtr->tcl_CreateObjTrace2) /* 677 */ #define Tcl_NRCreateCommand2 \ (tclStubsPtr->tcl_NRCreateCommand2) /* 678 */ +#define Tcl_NRCallObjProc2 \ + (tclStubsPtr->tcl_NRCallObjProc2) /* 679 */ #endif /* defined(USE_TCL_STUBS) */ diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c index 22b273b..0052682 100644 --- a/generic/tclStubInit.c +++ b/generic/tclStubInit.c @@ -2038,6 +2038,7 @@ const TclStubs tclStubs = { Tcl_CreateObjCommand2, /* 676 */ Tcl_CreateObjTrace2, /* 677 */ Tcl_NRCreateCommand2, /* 678 */ + Tcl_NRCallObjProc2, /* 679 */ }; /* !END!: Do not edit above this line. */ -- cgit v0.12 From 0f72e7de19985f400051e013c40f53c98d2af9d6 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 20 Jun 2022 09:36:33 +0000 Subject: bump http version to 2.9.8 --- library/http/http.tcl | 2 +- library/http/pkgIndex.tcl | 2 +- unix/Makefile.in | 4 ++-- win/Makefile.in | 4 ++-- 4 files changed, 6 insertions(+), 6 deletions(-) diff --git a/library/http/http.tcl b/library/http/http.tcl index cae7e6e..5a09bb8 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.7 +package provide http 2.9.8 namespace eval http { # Allow resourcing to not clobber existing data diff --git a/library/http/pkgIndex.tcl b/library/http/pkgIndex.tcl index e12cf84..bb742fd 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.7 [list tclPkgSetup $dir http 2.9.7 {{http.tcl source {::http::config ::http::formatQuery ::http::geturl ::http::reset ::http::wait ::http::register ::http::unregister ::http::mapReply}}}] +package ifneeded http 2.9.8 [list tclPkgSetup $dir http 2.9.8 {{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 de7f25b..23383cd 100644 --- a/unix/Makefile.in +++ b/unix/Makefile.in @@ -950,9 +950,9 @@ install-libraries: libraries do \ $(INSTALL_DATA) $$i "$(SCRIPT_INSTALL_DIR)/http1.0"; \ done - @echo "Installing package http 2.9.7 as a Tcl Module"; + @echo "Installing package http 2.9.8 as a Tcl Module"; @$(INSTALL_DATA) $(TOP_DIR)/library/http/http.tcl \ - "$(MODULE_INSTALL_DIR)/8.6/http-2.9.7.tm" + "$(MODULE_INSTALL_DIR)/8.6/http-2.9.8.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 37d579b..08fb1b5 100644 --- a/win/Makefile.in +++ b/win/Makefile.in @@ -735,8 +735,8 @@ install-libraries: libraries install-tzdata install-msgs do \ $(COPY) "$$j" "$(SCRIPT_INSTALL_DIR)/http1.0"; \ done; - @echo "Installing package http 2.9.7 as a Tcl Module"; - @$(COPY) $(ROOT_DIR)/library/http/http.tcl "$(MODULE_INSTALL_DIR)/8.6/http-2.9.7.tm"; + @echo "Installing package http 2.9.8 as a Tcl Module"; + @$(COPY) $(ROOT_DIR)/library/http/http.tcl "$(MODULE_INSTALL_DIR)/8.6/http-2.9.8.tm"; @echo "Installing library opt0.4 directory"; @for j in $(ROOT_DIR)/library/opt/*.tcl; \ do \ -- cgit v0.12 From ccabfb8506f946c7cb5f1c38431197e4bdbf42b0 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 20 Jun 2022 10:10:35 +0000 Subject: update doc --- doc/NRE.3 | 10 ++++++++-- 1 file changed, 8 insertions(+), 2 deletions(-) diff --git a/doc/NRE.3 b/doc/NRE.3 index 109e3f0..f76938a 100644 --- a/doc/NRE.3 +++ b/doc/NRE.3 @@ -9,7 +9,7 @@ .so man.macros .BS .SH NAME -Tcl_NRCreateCommand, Tcl_NRCallObjProc, Tcl_NREvalObj, Tcl_NREvalObjv, Tcl_NRCmdSwap, Tcl_NRExprObj, Tcl_NRAddCallback \- Non-Recursive (stackless) evaluation of Tcl scripts. +Tcl_NRCreateCommand, Tcl_NRCreateCommand2, Tcl_NRCallObjProc, Tcl_NRCallObjProc2, Tcl_NREvalObj, Tcl_NREvalObjv, Tcl_NRCmdSwap, Tcl_NRExprObj, Tcl_NRAddCallback \- Non-Recursive (stackless) evaluation of Tcl scripts. .SH SYNOPSIS .nf \fB#include \fR @@ -26,6 +26,9 @@ int \fBTcl_NRCallObjProc\fR(\fIinterp, nreProc, clientData, objc, objv\fR) .sp int +\fBTcl_NRCallObjProc2\fR(\fIinterp, nreProc2, clientData, objc, objv\fR) +.sp +int \fBTcl_NREvalObj\fR(\fIinterp, objPtr, flags\fR) .sp int @@ -52,7 +55,10 @@ Called in order to evaluate a command. Is often just a small wrapper that uses in the same way as the \fIproc\fR argument to \fBTcl_CreateObjCommand\fR(3) (\fIq.v.\fR). .AP Tcl_ObjCmdProc2 *proc2 in -Same as \fIproc\fR, but handles more arguments. +Called in order to evaluate a command. Is often just a small wrapper that uses +\fBTcl_NRCallObjProc2\fR to call \fInreProc2\fR using a new trampoline. Behaves +in the same way as the \fIproc2\fR argument to \fBTcl_CreateObjCommand2\fR(3) +(\fIq.v.\fR). .AP Tcl_ObjCmdProc *nreProc in Called instead of \fIproc\fR when a trampoline is already in use. .AP Tcl_ObjCmdProc2 *nreProc2 in -- cgit v0.12 From 7a44e1418d89449aa3c31828d68632c9f5acc9d2 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 20 Jun 2022 10:16:02 +0000 Subject: indenting --- generic/tclBasic.c | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/generic/tclBasic.c b/generic/tclBasic.c index 063afca..5501897 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -9184,11 +9184,11 @@ int wrapperNRObjProc( int objc, Tcl_Obj *const objv[]) { - CmdWrapperInfo *info = (CmdWrapperInfo *)clientData; - clientData = info->clientData; - Tcl_ObjCmdProc2 *proc = info->proc; - ckfree(info); - return proc(clientData, interp, objc, objv); + CmdWrapperInfo *info = (CmdWrapperInfo *)clientData; + clientData = info->clientData; + Tcl_ObjCmdProc2 *proc = info->proc; + ckfree(info); + return proc(clientData, interp, objc, objv); } int -- cgit v0.12 From 96609fe537a84e955b7be5cf97c64e0737ea7103 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 20 Jun 2022 11:55:29 +0000 Subject: Fix [a55872c242]: tcl8.7 on windows: linking against stubs library is now required in 8.7. If the Tcl library is static (.lib/.a) then the stub library is (with this fix) no longer necessary. If the Tcl library is a dll, document that the stub library is now necessary. --- doc/Tcl_Main.3 | 6 ++++-- win/Makefile.in | 4 ++-- win/makefile.vc | 1 + 3 files changed, 7 insertions(+), 4 deletions(-) diff --git a/doc/Tcl_Main.3 b/doc/Tcl_Main.3 index 904ecbe..6a37cda 100644 --- a/doc/Tcl_Main.3 +++ b/doc/Tcl_Main.3 @@ -85,8 +85,10 @@ that does nothing but invoke \fBTcl_Main\fR. .PP \fBTcl_Main\fR is not provided by the public interface of Tcl's stub library. Programs that call \fBTcl_Main\fR must be linked -against the standard Tcl library. Extensions (stub-enabled or -not) are not intended to call \fBTcl_Main\fR. +against the standard Tcl library. If the standard Tcl library is +a dll (so, not a static .lib/.a) , then the program must be linked +against the stub library as well. Extensions +(stub-enabled or not) are not intended to call \fBTcl_Main\fR. .PP \fBTcl_Main\fR is not thread-safe. It should only be called by a single main thread of a multi-threaded application. This diff --git a/win/Makefile.in b/win/Makefile.in index 8fef0cc..cf1ea7b 100644 --- a/win/Makefile.in +++ b/win/Makefile.in @@ -573,9 +573,9 @@ ${TCL_DLL_FILE}: ${TCL_OBJS} tcl.$(RES) @ZLIB_DLL_FILE@ @TOMMATH_DLL_FILE@ ${TCL || echo 'ignore zip-error by adjust sfx process (not executable?)'; \ fi -${TCL_LIB_FILE}: ${TCL_OBJS} +${TCL_LIB_FILE}: ${TCL_OBJS} tclWinPanic.$(OBJEXT) ${DDE_OBJS} ${REG_OBJS} @$(RM) ${TCL_LIB_FILE} - @MAKE_LIB@ ${TCL_OBJS} ${DDE_OBJS} ${REG_OBJS} + @MAKE_LIB@ ${TCL_OBJS} tclWinPanic.$(OBJEXT) ${DDE_OBJS} ${REG_OBJS} @POST_MAKE_LIB@ ${DDE_DLL_FILE}: ${TCL_STUB_LIB_FILE} ${DDE_OBJS} diff --git a/win/makefile.vc b/win/makefile.vc index 6ff6118..7c61580 100644 --- a/win/makefile.vc +++ b/win/makefile.vc @@ -428,6 +428,7 @@ PLATFORMOBJS = \ $(TMP_DIR)\tclWinThrd.obj \ $(TMP_DIR)\tclWinTime.obj \ !if $(STATIC_BUILD) + $(TMP_DIR)\tclWinPanic.obj \ $(TMP_DIR)\tclWinReg.obj \ $(TMP_DIR)\tclWinDde.obj \ !else -- cgit v0.12 From 5cff72948737cb3c3ab522d799ffa3a8301d224b Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 20 Jun 2022 15:18:23 +0000 Subject: Unneeded type-cast --- generic/tclProc.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/generic/tclProc.c b/generic/tclProc.c index f2dd98a..17635e7 100644 --- a/generic/tclProc.c +++ b/generic/tclProc.c @@ -2277,7 +2277,7 @@ TclUpdateReturnInfo( Tcl_ObjCmdProc * TclGetObjInterpProc(void) { - return (Tcl_ObjCmdProc *) TclObjInterpProc; + return TclObjInterpProc; } /* -- cgit v0.12 From 38b53dd47e3408dfed6a9fd179106652332b3b1e Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 22 Jun 2022 16:36:02 +0000 Subject: Allow spacing between '#' and 'define', while recognising version in header-files --- 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 75ed97e..b3433cc 100755 --- a/tools/tcltk-man2html.tcl +++ b/tools/tcltk-man2html.tcl @@ -43,7 +43,7 @@ proc getversion {tclh {name {}}} { # highlighting straight in some editors if {[regexp -lineanchor \ [string map [list @name@ $name] \ - {^#define\s+@name@_VERSION\s+\"([^.])+\.([^.\"]+)}] \ + {^\s*#define\s+@name@_VERSION\s+\"([^.])+\.([^.\"]+)}] \ $data -> major minor]} { return [list $major $minor] } -- cgit v0.12 From 2d7f0917cb782422a47ff20620f7d0f6f5779f9e Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 23 Jun 2022 08:56:45 +0000 Subject: Use "void *" in stead of ClientData in tclDecls.h (backported from 9.0) --- generic/tcl.decls | 138 ++++++++++++------------- generic/tclDecls.h | 298 +++++++++++++++++++++++++---------------------------- 2 files changed, 211 insertions(+), 225 deletions(-) diff --git a/generic/tcl.decls b/generic/tcl.decls index 7788ae1..4b95098 100644 --- a/generic/tcl.decls +++ b/generic/tcl.decls @@ -65,7 +65,7 @@ declare 8 { declare 9 unix { void Tcl_CreateFileHandler(int fd, int mask, Tcl_FileProc *proc, - ClientData clientData) + void *clientData) } declare 10 unix { void Tcl_DeleteFileHandler(int fd) @@ -269,7 +269,7 @@ declare 70 { } declare 71 { Tcl_AsyncHandler Tcl_AsyncCreate(Tcl_AsyncProc *proc, - ClientData clientData) + void *clientData) } declare 72 { void Tcl_AsyncDelete(Tcl_AsyncHandler async) @@ -295,10 +295,10 @@ declare 78 { } declare 79 { void Tcl_CallWhenDeleted(Tcl_Interp *interp, Tcl_InterpDeleteProc *proc, - ClientData clientData) + void *clientData) } declare 80 { - void Tcl_CancelIdleCall(Tcl_IdleProc *idleProc, ClientData clientData) + void Tcl_CancelIdleCall(Tcl_IdleProc *idleProc, void *clientData) } # Only available in Tcl 8.x, NULL in Tcl 9.0 declare 81 { @@ -329,27 +329,27 @@ declare 87 { } declare 88 { Tcl_Channel Tcl_CreateChannel(const Tcl_ChannelType *typePtr, - const char *chanName, ClientData instanceData, int mask) + const char *chanName, void *instanceData, int mask) } declare 89 { void Tcl_CreateChannelHandler(Tcl_Channel chan, int mask, - Tcl_ChannelProc *proc, ClientData clientData) + Tcl_ChannelProc *proc, void *clientData) } declare 90 { void Tcl_CreateCloseHandler(Tcl_Channel chan, Tcl_CloseProc *proc, - ClientData clientData) + void *clientData) } declare 91 { Tcl_Command Tcl_CreateCommand(Tcl_Interp *interp, const char *cmdName, - Tcl_CmdProc *proc, ClientData clientData, + Tcl_CmdProc *proc, void *clientData, Tcl_CmdDeleteProc *deleteProc) } declare 92 { void Tcl_CreateEventSource(Tcl_EventSetupProc *setupProc, - Tcl_EventCheckProc *checkProc, ClientData clientData) + Tcl_EventCheckProc *checkProc, void *clientData) } declare 93 { - void Tcl_CreateExitHandler(Tcl_ExitProc *proc, ClientData clientData) + void Tcl_CreateExitHandler(Tcl_ExitProc *proc, void *clientData) } declare 94 { Tcl_Interp *Tcl_CreateInterp(void) @@ -357,12 +357,12 @@ declare 94 { declare 95 {deprecated {}} { void Tcl_CreateMathFunc(Tcl_Interp *interp, const char *name, int numArgs, Tcl_ValueType *argTypes, - Tcl_MathProc *proc, ClientData clientData) + Tcl_MathProc *proc, void *clientData) } declare 96 { Tcl_Command Tcl_CreateObjCommand(Tcl_Interp *interp, const char *cmdName, - Tcl_ObjCmdProc *proc, ClientData clientData, + Tcl_ObjCmdProc *proc, void *clientData, Tcl_CmdDeleteProc *deleteProc) } declare 97 { @@ -371,22 +371,22 @@ declare 97 { } declare 98 { Tcl_TimerToken Tcl_CreateTimerHandler(int milliseconds, - Tcl_TimerProc *proc, ClientData clientData) + Tcl_TimerProc *proc, void *clientData) } declare 99 { Tcl_Trace Tcl_CreateTrace(Tcl_Interp *interp, int level, - Tcl_CmdTraceProc *proc, ClientData clientData) + Tcl_CmdTraceProc *proc, void *clientData) } declare 100 { void Tcl_DeleteAssocData(Tcl_Interp *interp, const char *name) } declare 101 { void Tcl_DeleteChannelHandler(Tcl_Channel chan, Tcl_ChannelProc *proc, - ClientData clientData) + void *clientData) } declare 102 { void Tcl_DeleteCloseHandler(Tcl_Channel chan, Tcl_CloseProc *proc, - ClientData clientData) + void *clientData) } declare 103 { int Tcl_DeleteCommand(Tcl_Interp *interp, const char *cmdName) @@ -395,14 +395,14 @@ declare 104 { int Tcl_DeleteCommandFromToken(Tcl_Interp *interp, Tcl_Command command) } declare 105 { - void Tcl_DeleteEvents(Tcl_EventDeleteProc *proc, ClientData clientData) + void Tcl_DeleteEvents(Tcl_EventDeleteProc *proc, void *clientData) } declare 106 { void Tcl_DeleteEventSource(Tcl_EventSetupProc *setupProc, - Tcl_EventCheckProc *checkProc, ClientData clientData) + Tcl_EventCheckProc *checkProc, void *clientData) } declare 107 { - void Tcl_DeleteExitHandler(Tcl_ExitProc *proc, ClientData clientData) + void Tcl_DeleteExitHandler(Tcl_ExitProc *proc, void *clientData) } declare 108 { void Tcl_DeleteHashEntry(Tcl_HashEntry *entryPtr) @@ -424,13 +424,13 @@ declare 113 { } declare 114 { void Tcl_DontCallWhenDeleted(Tcl_Interp *interp, - Tcl_InterpDeleteProc *proc, ClientData clientData) + Tcl_InterpDeleteProc *proc, void *clientData) } declare 115 { int Tcl_DoOneEvent(int flags) } declare 116 { - void Tcl_DoWhenIdle(Tcl_IdleProc *proc, ClientData clientData) + void Tcl_DoWhenIdle(Tcl_IdleProc *proc, void *clientData) } declare 117 { char *Tcl_DStringAppend(Tcl_DString *dsPtr, const char *bytes, int length) @@ -478,7 +478,7 @@ declare 131 {deprecated {No longer in use, changed to macro}} { int Tcl_EvalObj(Tcl_Interp *interp, Tcl_Obj *objPtr) } declare 132 { - void Tcl_EventuallyFree(ClientData clientData, Tcl_FreeProc *freeProc) + void Tcl_EventuallyFree(void *clientData, Tcl_FreeProc *freeProc) } declare 133 { TCL_NORETURN void Tcl_Exit(int status) @@ -539,7 +539,7 @@ declare 149 { int *objcPtr, Tcl_Obj ***objv) } declare 150 { - ClientData Tcl_GetAssocData(Tcl_Interp *interp, const char *name, + void *Tcl_GetAssocData(Tcl_Interp *interp, const char *name, Tcl_InterpDeleteProc **procPtr) } declare 151 { @@ -551,10 +551,10 @@ declare 152 { } declare 153 { int Tcl_GetChannelHandle(Tcl_Channel chan, int direction, - ClientData *handlePtr) + void **handlePtr) } declare 154 { - ClientData Tcl_GetChannelInstanceData(Tcl_Channel chan) + void *Tcl_GetChannelInstanceData(Tcl_Channel chan) } declare 155 { int Tcl_GetChannelMode(Tcl_Channel chan) @@ -601,7 +601,7 @@ declare 166 { declare 167 unix { int Tcl_GetOpenFile(Tcl_Interp *interp, const char *chanID, - int forWriting, int checkUsage, ClientData *filePtr) + int forWriting, int checkUsage, void **filePtr) } # Obsolete. Should now use Tcl_FSGetPathType which is objectified # and therefore usually faster. @@ -678,13 +678,13 @@ declare 187 { # } declare 189 { - Tcl_Channel Tcl_MakeFileChannel(ClientData handle, int mode) + Tcl_Channel Tcl_MakeFileChannel(void *handle, int mode) } declare 190 { int Tcl_MakeSafe(Tcl_Interp *interp) } declare 191 { - Tcl_Channel Tcl_MakeTcpClientChannel(ClientData tcpSocket) + Tcl_Channel Tcl_MakeTcpClientChannel(void *tcpSocket) } declare 192 { char *Tcl_Merge(int argc, const char *const *argv) @@ -719,10 +719,10 @@ declare 199 { declare 200 { Tcl_Channel Tcl_OpenTcpServer(Tcl_Interp *interp, int port, const char *host, Tcl_TcpAcceptProc *acceptProc, - ClientData callbackData) + void *callbackData) } declare 201 { - void Tcl_Preserve(ClientData data) + void Tcl_Preserve(void *data) } declare 202 { void Tcl_PrintDouble(Tcl_Interp *interp, double value, char *dst) @@ -770,7 +770,7 @@ declare 215 { const char **startPtr, const char **endPtr) } declare 216 { - void Tcl_Release(ClientData clientData) + void Tcl_Release(void *clientData) } declare 217 { void Tcl_ResetResult(Tcl_Interp *interp) @@ -792,7 +792,7 @@ declare 222 { } declare 223 { void Tcl_SetAssocData(Tcl_Interp *interp, const char *name, - Tcl_InterpDeleteProc *proc, ClientData clientData) + Tcl_InterpDeleteProc *proc, void *clientData) } declare 224 { void Tcl_SetChannelBufferSize(Tcl_Channel chan, int sz) @@ -873,11 +873,11 @@ declare 246 {deprecated {}} { } declare 247 {deprecated {No longer in use, changed to macro}} { int Tcl_TraceVar(Tcl_Interp *interp, const char *varName, int flags, - Tcl_VarTraceProc *proc, ClientData clientData) + Tcl_VarTraceProc *proc, void *clientData) } declare 248 { int Tcl_TraceVar2(Tcl_Interp *interp, const char *part1, const char *part2, - int flags, Tcl_VarTraceProc *proc, ClientData clientData) + int flags, Tcl_VarTraceProc *proc, void *clientData) } declare 249 { char *Tcl_TranslateFileName(Tcl_Interp *interp, const char *name, @@ -901,12 +901,12 @@ declare 254 { } declare 255 {deprecated {No longer in use, changed to macro}} { void Tcl_UntraceVar(Tcl_Interp *interp, const char *varName, int flags, - Tcl_VarTraceProc *proc, ClientData clientData) + Tcl_VarTraceProc *proc, void *clientData) } declare 256 { void Tcl_UntraceVar2(Tcl_Interp *interp, const char *part1, const char *part2, int flags, Tcl_VarTraceProc *proc, - ClientData clientData) + void *clientData) } declare 257 { void Tcl_UpdateLinkedVar(Tcl_Interp *interp, const char *varName) @@ -923,13 +923,13 @@ declare 260 { int Tcl_VarEval(Tcl_Interp *interp, ...) } declare 261 {deprecated {No longer in use, changed to macro}} { - ClientData Tcl_VarTraceInfo(Tcl_Interp *interp, const char *varName, - int flags, Tcl_VarTraceProc *procPtr, ClientData prevClientData) + void *Tcl_VarTraceInfo(Tcl_Interp *interp, const char *varName, + int flags, Tcl_VarTraceProc *procPtr, void *prevClientData) } declare 262 { - ClientData Tcl_VarTraceInfo2(Tcl_Interp *interp, const char *part1, + void *Tcl_VarTraceInfo2(Tcl_Interp *interp, const char *part1, const char *part2, int flags, Tcl_VarTraceProc *procPtr, - ClientData prevClientData) + void *prevClientData) } declare 263 { int Tcl_Write(Tcl_Channel chan, const char *s, int slen) @@ -1010,7 +1010,7 @@ declare 280 { declare 281 { Tcl_Channel Tcl_StackChannel(Tcl_Interp *interp, - const Tcl_ChannelType *typePtr, ClientData instanceData, + const Tcl_ChannelType *typePtr, void *instanceData, int mask, Tcl_Channel prevChan) } declare 282 { @@ -1038,10 +1038,10 @@ declare 287 { Tcl_Encoding Tcl_CreateEncoding(const Tcl_EncodingType *typePtr) } declare 288 { - void Tcl_CreateThreadExitHandler(Tcl_ExitProc *proc, ClientData clientData) + void Tcl_CreateThreadExitHandler(Tcl_ExitProc *proc, void *clientData) } declare 289 { - void Tcl_DeleteThreadExitHandler(Tcl_ExitProc *proc, ClientData clientData) + void Tcl_DeleteThreadExitHandler(Tcl_ExitProc *proc, void *clientData) } declare 290 { void Tcl_DiscardResult(Tcl_SavedResult *statePtr) @@ -1074,7 +1074,7 @@ declare 297 { void Tcl_FinalizeThread(void) } declare 298 { - void Tcl_FinalizeNotifier(ClientData clientData) + void Tcl_FinalizeNotifier(void *clientData) } declare 299 { void Tcl_FreeEncoding(Tcl_Encoding encoding) @@ -1104,7 +1104,7 @@ declare 306 { const char *part2, int flags) } declare 307 { - ClientData Tcl_InitNotifier(void) + void *Tcl_InitNotifier(void) } declare 308 { void Tcl_MutexLock(Tcl_Mutex *mutexPtr) @@ -1220,7 +1220,7 @@ declare 342 {deprecated {Use Tcl_SetEncodingSearchPath}} { void Tcl_SetDefaultEncodingDir(const char *path) } declare 343 { - void Tcl_AlertNotifier(ClientData clientData) + void Tcl_AlertNotifier(void *clientData) } declare 344 { void Tcl_ServiceModeHook(int mode) @@ -1380,7 +1380,7 @@ declare 389 { int Tcl_GetChannelNamesEx(Tcl_Interp *interp, const char *pattern) } declare 390 { - int Tcl_ProcObjCmd(ClientData clientData, Tcl_Interp *interp, + int Tcl_ProcObjCmd(void *clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) } declare 391 { @@ -1391,7 +1391,7 @@ declare 392 { } declare 393 { int Tcl_CreateThread(Tcl_ThreadId *idPtr, Tcl_ThreadCreateProc *proc, - ClientData clientData, int stackSize, int flags) + void *clientData, int stackSize, int flags) } # Introduced in 8.3.2 @@ -1508,17 +1508,17 @@ declare 424 { void Tcl_InitObjHashTable(Tcl_HashTable *tablePtr) } declare 425 { - ClientData Tcl_CommandTraceInfo(Tcl_Interp *interp, const char *varName, + void *Tcl_CommandTraceInfo(Tcl_Interp *interp, const char *varName, int flags, Tcl_CommandTraceProc *procPtr, - ClientData prevClientData) + void *prevClientData) } declare 426 { int Tcl_TraceCommand(Tcl_Interp *interp, const char *varName, int flags, - Tcl_CommandTraceProc *proc, ClientData clientData) + Tcl_CommandTraceProc *proc, void *clientData) } declare 427 { void Tcl_UntraceCommand(Tcl_Interp *interp, const char *varName, - int flags, Tcl_CommandTraceProc *proc, ClientData clientData) + int flags, Tcl_CommandTraceProc *proc, void *clientData) } declare 428 { char *Tcl_AttemptAlloc(unsigned int size) @@ -1551,7 +1551,7 @@ declare 434 { declare 435 {deprecated {}} { int Tcl_GetMathFuncInfo(Tcl_Interp *interp, const char *name, int *numArgsPtr, Tcl_ValueType **argTypesPtr, - Tcl_MathProc **procPtr, ClientData *clientDataPtr) + Tcl_MathProc **procPtr, void **clientDataPtr) } declare 436 {deprecated {}} { Tcl_Obj *Tcl_ListMathFuncs(Tcl_Interp *interp, const char *pattern) @@ -1656,7 +1656,7 @@ declare 464 { Tcl_Obj *const objv[]) } declare 465 { - ClientData Tcl_FSGetInternalRep(Tcl_Obj *pathPtr, + void *Tcl_FSGetInternalRep(Tcl_Obj *pathPtr, const Tcl_Filesystem *fsPtr) } declare 466 { @@ -1667,7 +1667,7 @@ declare 467 { } declare 468 { Tcl_Obj *Tcl_FSNewNativePath(const Tcl_Filesystem *fromFilesystem, - ClientData clientData) + void *clientData) } declare 469 { const void *Tcl_FSGetNativePath(Tcl_Obj *pathPtr) @@ -1682,13 +1682,13 @@ declare 472 { Tcl_Obj *Tcl_FSListVolumes(void) } declare 473 { - int Tcl_FSRegister(ClientData clientData, const Tcl_Filesystem *fsPtr) + int Tcl_FSRegister(void *clientData, const Tcl_Filesystem *fsPtr) } declare 474 { int Tcl_FSUnregister(const Tcl_Filesystem *fsPtr) } declare 475 { - ClientData Tcl_FSData(const Tcl_Filesystem *fsPtr) + void *Tcl_FSData(const Tcl_Filesystem *fsPtr) } declare 476 { const char *Tcl_FSGetTranslatedStringPath(Tcl_Interp *interp, @@ -1723,7 +1723,7 @@ declare 482 { # TIP#32 (object-enabled traces) kbk declare 483 { Tcl_Trace Tcl_CreateObjTrace(Tcl_Interp *interp, int level, int flags, - Tcl_CmdObjTraceProc *objProc, ClientData clientData, + Tcl_CmdObjTraceProc *objProc, void *clientData, Tcl_CmdObjTraceDeleteProc *delProc) } declare 484 { @@ -1821,7 +1821,7 @@ declare 505 { # dkf, API by Brent Welch? declare 506 { Tcl_Namespace *Tcl_CreateNamespace(Tcl_Interp *interp, const char *name, - ClientData clientData, Tcl_NamespaceDeleteProc *deleteProc) + void *clientData, Tcl_NamespaceDeleteProc *deleteProc) } declare 507 { void Tcl_DeleteNamespace(Tcl_Namespace *nsPtr) @@ -1878,12 +1878,12 @@ declare 519 {nostub {Don't use this function in a stub-enabled extension}} { # TIP#143 (resource limits) dkf declare 520 { void Tcl_LimitAddHandler(Tcl_Interp *interp, int type, - Tcl_LimitHandlerProc *handlerProc, ClientData clientData, + Tcl_LimitHandlerProc *handlerProc, void *clientData, Tcl_LimitHandlerDeleteProc *deleteProc) } declare 521 { void Tcl_LimitRemoveHandler(Tcl_Interp *interp, int type, - Tcl_LimitHandlerProc *handlerProc, ClientData clientData) + Tcl_LimitHandlerProc *handlerProc, void *clientData) } declare 522 { int Tcl_LimitReady(Tcl_Interp *interp) @@ -1996,12 +1996,12 @@ declare 551 { declare 552 { void Tcl_SetTimeProc(Tcl_GetTimeProc *getProc, Tcl_ScaleTimeProc *scaleProc, - ClientData clientData) + void *clientData) } declare 553 { void Tcl_QueryTimeProc(Tcl_GetTimeProc **getProc, Tcl_ScaleTimeProc **scaleProc, - ClientData *clientData) + void **clientData) } # TIP#218 (driver thread actions) davygrvy/akupries ChannelType ver 4 @@ -2115,7 +2115,7 @@ declare 579 { # TIP #285 (script cancellation support) jmistachkin declare 580 { int Tcl_CancelEval(Tcl_Interp *interp, Tcl_Obj *resultObjPtr, - ClientData clientData, int flags) + void *clientData, int flags) } declare 581 { int Tcl_Canceled(Tcl_Interp *interp, int flags) @@ -2131,7 +2131,7 @@ declare 582 { declare 583 { Tcl_Command Tcl_NRCreateCommand(Tcl_Interp *interp, const char *cmdName, Tcl_ObjCmdProc *proc, - Tcl_ObjCmdProc *nreProc, ClientData clientData, + Tcl_ObjCmdProc *nreProc, void *clientData, Tcl_CmdDeleteProc *deleteProc) } declare 584 { @@ -2147,14 +2147,14 @@ declare 586 { } declare 587 { void Tcl_NRAddCallback(Tcl_Interp *interp, Tcl_NRPostProc *postProcPtr, - ClientData data0, ClientData data1, ClientData data2, - ClientData data3) + void *data0, void *data1, void *data2, + void *data3) } # For use by NR extenders, to have a simple way to also provide a (required!) # classic objProc declare 588 { int Tcl_NRCallObjProc(Tcl_Interp *interp, Tcl_ObjCmdProc *objProc, - ClientData clientData, int objc, Tcl_Obj *const objv[]) + void *clientData, int objc, Tcl_Obj *const objv[]) } # TIP#316 (Tcl_StatBuf reader functions) dkf @@ -2331,7 +2331,7 @@ declare 630 { declare 631 { Tcl_Channel Tcl_OpenTcpServerEx(Tcl_Interp *interp, const char *service, const char *host, unsigned int flags, Tcl_TcpAcceptProc *acceptProc, - ClientData callbackData) + void *callbackData) } # TIP #430 diff --git a/generic/tclDecls.h b/generic/tclDecls.h index b439f50..0371cc7 100644 --- a/generic/tclDecls.h +++ b/generic/tclDecls.h @@ -77,12 +77,12 @@ EXTERN char * Tcl_DbCkrealloc(char *ptr, unsigned int size, #if !defined(_WIN32) && !defined(MAC_OSX_TCL) /* UNIX */ /* 9 */ EXTERN void Tcl_CreateFileHandler(int fd, int mask, - Tcl_FileProc *proc, ClientData clientData); + Tcl_FileProc *proc, void *clientData); #endif /* UNIX */ #ifdef MAC_OSX_TCL /* MACOSX */ /* 9 */ EXTERN void Tcl_CreateFileHandler(int fd, int mask, - Tcl_FileProc *proc, ClientData clientData); + Tcl_FileProc *proc, void *clientData); #endif /* MACOSX */ #if !defined(_WIN32) && !defined(MAC_OSX_TCL) /* UNIX */ /* 10 */ @@ -263,7 +263,7 @@ EXTERN void Tcl_AppendElement(Tcl_Interp *interp, EXTERN void Tcl_AppendResult(Tcl_Interp *interp, ...); /* 71 */ EXTERN Tcl_AsyncHandler Tcl_AsyncCreate(Tcl_AsyncProc *proc, - ClientData clientData); + void *clientData); /* 72 */ EXTERN void Tcl_AsyncDelete(Tcl_AsyncHandler async); /* 73 */ @@ -284,11 +284,10 @@ EXTERN int Tcl_BadChannelOption(Tcl_Interp *interp, const char *optionList); /* 79 */ EXTERN void Tcl_CallWhenDeleted(Tcl_Interp *interp, - Tcl_InterpDeleteProc *proc, - ClientData clientData); + Tcl_InterpDeleteProc *proc, void *clientData); /* 80 */ EXTERN void Tcl_CancelIdleCall(Tcl_IdleProc *idleProc, - ClientData clientData); + void *clientData); /* 81 */ EXTERN int Tcl_Close(Tcl_Interp *interp, Tcl_Channel chan); /* 82 */ @@ -313,26 +312,26 @@ EXTERN int Tcl_CreateAliasObj(Tcl_Interp *childInterp, Tcl_Obj *const objv[]); /* 88 */ EXTERN Tcl_Channel Tcl_CreateChannel(const Tcl_ChannelType *typePtr, - const char *chanName, - ClientData instanceData, int mask); + const char *chanName, void *instanceData, + int mask); /* 89 */ EXTERN void Tcl_CreateChannelHandler(Tcl_Channel chan, int mask, - Tcl_ChannelProc *proc, ClientData clientData); + Tcl_ChannelProc *proc, void *clientData); /* 90 */ EXTERN void Tcl_CreateCloseHandler(Tcl_Channel chan, - Tcl_CloseProc *proc, ClientData clientData); + Tcl_CloseProc *proc, void *clientData); /* 91 */ EXTERN Tcl_Command Tcl_CreateCommand(Tcl_Interp *interp, const char *cmdName, Tcl_CmdProc *proc, - ClientData clientData, + void *clientData, Tcl_CmdDeleteProc *deleteProc); /* 92 */ EXTERN void Tcl_CreateEventSource(Tcl_EventSetupProc *setupProc, Tcl_EventCheckProc *checkProc, - ClientData clientData); + void *clientData); /* 93 */ EXTERN void Tcl_CreateExitHandler(Tcl_ExitProc *proc, - ClientData clientData); + void *clientData); /* 94 */ EXTERN Tcl_Interp * Tcl_CreateInterp(void); /* 95 */ @@ -340,31 +339,30 @@ TCL_DEPRECATED("") void Tcl_CreateMathFunc(Tcl_Interp *interp, const char *name, int numArgs, Tcl_ValueType *argTypes, Tcl_MathProc *proc, - ClientData clientData); + void *clientData); /* 96 */ EXTERN Tcl_Command Tcl_CreateObjCommand(Tcl_Interp *interp, const char *cmdName, Tcl_ObjCmdProc *proc, - ClientData clientData, + void *clientData, Tcl_CmdDeleteProc *deleteProc); /* 97 */ EXTERN Tcl_Interp * Tcl_CreateChild(Tcl_Interp *interp, const char *name, int isSafe); /* 98 */ EXTERN Tcl_TimerToken Tcl_CreateTimerHandler(int milliseconds, - Tcl_TimerProc *proc, ClientData clientData); + Tcl_TimerProc *proc, void *clientData); /* 99 */ EXTERN Tcl_Trace Tcl_CreateTrace(Tcl_Interp *interp, int level, - Tcl_CmdTraceProc *proc, - ClientData clientData); + Tcl_CmdTraceProc *proc, void *clientData); /* 100 */ EXTERN void Tcl_DeleteAssocData(Tcl_Interp *interp, const char *name); /* 101 */ EXTERN void Tcl_DeleteChannelHandler(Tcl_Channel chan, - Tcl_ChannelProc *proc, ClientData clientData); + Tcl_ChannelProc *proc, void *clientData); /* 102 */ EXTERN void Tcl_DeleteCloseHandler(Tcl_Channel chan, - Tcl_CloseProc *proc, ClientData clientData); + Tcl_CloseProc *proc, void *clientData); /* 103 */ EXTERN int Tcl_DeleteCommand(Tcl_Interp *interp, const char *cmdName); @@ -373,14 +371,14 @@ EXTERN int Tcl_DeleteCommandFromToken(Tcl_Interp *interp, Tcl_Command command); /* 105 */ EXTERN void Tcl_DeleteEvents(Tcl_EventDeleteProc *proc, - ClientData clientData); + void *clientData); /* 106 */ EXTERN void Tcl_DeleteEventSource(Tcl_EventSetupProc *setupProc, Tcl_EventCheckProc *checkProc, - ClientData clientData); + void *clientData); /* 107 */ EXTERN void Tcl_DeleteExitHandler(Tcl_ExitProc *proc, - ClientData clientData); + void *clientData); /* 108 */ EXTERN void Tcl_DeleteHashEntry(Tcl_HashEntry *entryPtr); /* 109 */ @@ -395,13 +393,11 @@ EXTERN void Tcl_DeleteTimerHandler(Tcl_TimerToken token); EXTERN void Tcl_DeleteTrace(Tcl_Interp *interp, Tcl_Trace trace); /* 114 */ EXTERN void Tcl_DontCallWhenDeleted(Tcl_Interp *interp, - Tcl_InterpDeleteProc *proc, - ClientData clientData); + Tcl_InterpDeleteProc *proc, void *clientData); /* 115 */ EXTERN int Tcl_DoOneEvent(int flags); /* 116 */ -EXTERN void Tcl_DoWhenIdle(Tcl_IdleProc *proc, - ClientData clientData); +EXTERN void Tcl_DoWhenIdle(Tcl_IdleProc *proc, void *clientData); /* 117 */ EXTERN char * Tcl_DStringAppend(Tcl_DString *dsPtr, const char *bytes, int length); @@ -439,7 +435,7 @@ EXTERN int Tcl_EvalFile(Tcl_Interp *interp, TCL_DEPRECATED("No longer in use, changed to macro") int Tcl_EvalObj(Tcl_Interp *interp, Tcl_Obj *objPtr); /* 132 */ -EXTERN void Tcl_EventuallyFree(ClientData clientData, +EXTERN void Tcl_EventuallyFree(void *clientData, Tcl_FreeProc *freeProc); /* 133 */ EXTERN TCL_NORETURN void Tcl_Exit(int status); @@ -495,7 +491,7 @@ EXTERN int Tcl_GetAliasObj(Tcl_Interp *interp, const char **targetCmdPtr, int *objcPtr, Tcl_Obj ***objv); /* 150 */ -EXTERN ClientData Tcl_GetAssocData(Tcl_Interp *interp, +EXTERN void * Tcl_GetAssocData(Tcl_Interp *interp, const char *name, Tcl_InterpDeleteProc **procPtr); /* 151 */ @@ -505,9 +501,9 @@ EXTERN Tcl_Channel Tcl_GetChannel(Tcl_Interp *interp, EXTERN int Tcl_GetChannelBufferSize(Tcl_Channel chan); /* 153 */ EXTERN int Tcl_GetChannelHandle(Tcl_Channel chan, int direction, - ClientData *handlePtr); + void **handlePtr); /* 154 */ -EXTERN ClientData Tcl_GetChannelInstanceData(Tcl_Channel chan); +EXTERN void * Tcl_GetChannelInstanceData(Tcl_Channel chan); /* 155 */ EXTERN int Tcl_GetChannelMode(Tcl_Channel chan); /* 156 */ @@ -541,13 +537,13 @@ EXTERN Tcl_Obj * Tcl_GetObjResult(Tcl_Interp *interp); /* 167 */ EXTERN int Tcl_GetOpenFile(Tcl_Interp *interp, const char *chanID, int forWriting, - int checkUsage, ClientData *filePtr); + int checkUsage, void **filePtr); #endif /* UNIX */ #ifdef MAC_OSX_TCL /* MACOSX */ /* 167 */ EXTERN int Tcl_GetOpenFile(Tcl_Interp *interp, const char *chanID, int forWriting, - int checkUsage, ClientData *filePtr); + int checkUsage, void **filePtr); #endif /* MACOSX */ /* 168 */ EXTERN Tcl_PathType Tcl_GetPathType(const char *path); @@ -602,11 +598,11 @@ EXTERN int Tcl_LinkVar(Tcl_Interp *interp, const char *varName, void *addr, int type); /* Slot 188 is reserved */ /* 189 */ -EXTERN Tcl_Channel Tcl_MakeFileChannel(ClientData handle, int mode); +EXTERN Tcl_Channel Tcl_MakeFileChannel(void *handle, int mode); /* 190 */ EXTERN int Tcl_MakeSafe(Tcl_Interp *interp); /* 191 */ -EXTERN Tcl_Channel Tcl_MakeTcpClientChannel(ClientData tcpSocket); +EXTERN Tcl_Channel Tcl_MakeTcpClientChannel(void *tcpSocket); /* 192 */ EXTERN char * Tcl_Merge(int argc, const char *const *argv); /* 193 */ @@ -635,9 +631,9 @@ EXTERN Tcl_Channel Tcl_OpenTcpClient(Tcl_Interp *interp, int port, EXTERN Tcl_Channel Tcl_OpenTcpServer(Tcl_Interp *interp, int port, const char *host, Tcl_TcpAcceptProc *acceptProc, - ClientData callbackData); + void *callbackData); /* 201 */ -EXTERN void Tcl_Preserve(ClientData data); +EXTERN void Tcl_Preserve(void *data); /* 202 */ EXTERN void Tcl_PrintDouble(Tcl_Interp *interp, double value, char *dst); @@ -676,7 +672,7 @@ EXTERN int Tcl_RegExpMatch(Tcl_Interp *interp, const char *text, EXTERN void Tcl_RegExpRange(Tcl_RegExp regexp, int index, const char **startPtr, const char **endPtr); /* 216 */ -EXTERN void Tcl_Release(ClientData clientData); +EXTERN void Tcl_Release(void *clientData); /* 217 */ EXTERN void Tcl_ResetResult(Tcl_Interp *interp); /* 218 */ @@ -694,7 +690,7 @@ EXTERN int Tcl_ServiceEvent(int flags); /* 223 */ EXTERN void Tcl_SetAssocData(Tcl_Interp *interp, const char *name, Tcl_InterpDeleteProc *proc, - ClientData clientData); + void *clientData); /* 224 */ EXTERN void Tcl_SetChannelBufferSize(Tcl_Channel chan, int sz); /* 225 */ @@ -765,12 +761,11 @@ int Tcl_TellOld(Tcl_Channel chan); TCL_DEPRECATED("No longer in use, changed to macro") int Tcl_TraceVar(Tcl_Interp *interp, const char *varName, int flags, Tcl_VarTraceProc *proc, - ClientData clientData); + void *clientData); /* 248 */ EXTERN int Tcl_TraceVar2(Tcl_Interp *interp, const char *part1, const char *part2, int flags, - Tcl_VarTraceProc *proc, - ClientData clientData); + Tcl_VarTraceProc *proc, void *clientData); /* 249 */ EXTERN char * Tcl_TranslateFileName(Tcl_Interp *interp, const char *name, Tcl_DString *bufferPtr); @@ -794,13 +789,12 @@ EXTERN int Tcl_UnsetVar2(Tcl_Interp *interp, const char *part1, TCL_DEPRECATED("No longer in use, changed to macro") void Tcl_UntraceVar(Tcl_Interp *interp, const char *varName, int flags, - Tcl_VarTraceProc *proc, - ClientData clientData); + Tcl_VarTraceProc *proc, void *clientData); /* 256 */ EXTERN void Tcl_UntraceVar2(Tcl_Interp *interp, const char *part1, const char *part2, int flags, Tcl_VarTraceProc *proc, - ClientData clientData); + void *clientData); /* 257 */ EXTERN void Tcl_UpdateLinkedVar(Tcl_Interp *interp, const char *varName); @@ -817,15 +811,15 @@ EXTERN int Tcl_UpVar2(Tcl_Interp *interp, const char *frameName, EXTERN int Tcl_VarEval(Tcl_Interp *interp, ...); /* 261 */ TCL_DEPRECATED("No longer in use, changed to macro") -ClientData Tcl_VarTraceInfo(Tcl_Interp *interp, +void * Tcl_VarTraceInfo(Tcl_Interp *interp, const char *varName, int flags, Tcl_VarTraceProc *procPtr, - ClientData prevClientData); + void *prevClientData); /* 262 */ -EXTERN ClientData Tcl_VarTraceInfo2(Tcl_Interp *interp, +EXTERN void * Tcl_VarTraceInfo2(Tcl_Interp *interp, const char *part1, const char *part2, int flags, Tcl_VarTraceProc *procPtr, - ClientData prevClientData); + void *prevClientData); /* 263 */ EXTERN int Tcl_Write(Tcl_Channel chan, const char *s, int slen); /* 264 */ @@ -884,7 +878,7 @@ EXTERN void Tcl_InitMemory(Tcl_Interp *interp); /* 281 */ EXTERN Tcl_Channel Tcl_StackChannel(Tcl_Interp *interp, const Tcl_ChannelType *typePtr, - ClientData instanceData, int mask, + void *instanceData, int mask, Tcl_Channel prevChan); /* 282 */ EXTERN int Tcl_UnstackChannel(Tcl_Interp *interp, @@ -901,10 +895,10 @@ EXTERN void Tcl_AppendObjToObj(Tcl_Obj *objPtr, EXTERN Tcl_Encoding Tcl_CreateEncoding(const Tcl_EncodingType *typePtr); /* 288 */ EXTERN void Tcl_CreateThreadExitHandler(Tcl_ExitProc *proc, - ClientData clientData); + void *clientData); /* 289 */ EXTERN void Tcl_DeleteThreadExitHandler(Tcl_ExitProc *proc, - ClientData clientData); + void *clientData); /* 290 */ EXTERN void Tcl_DiscardResult(Tcl_SavedResult *statePtr); /* 291 */ @@ -932,7 +926,7 @@ EXTERN char * Tcl_ExternalToUtfDString(Tcl_Encoding encoding, /* 297 */ EXTERN void Tcl_FinalizeThread(void); /* 298 */ -EXTERN void Tcl_FinalizeNotifier(ClientData clientData); +EXTERN void Tcl_FinalizeNotifier(void *clientData); /* 299 */ EXTERN void Tcl_FreeEncoding(Tcl_Encoding encoding); /* 300 */ @@ -955,7 +949,7 @@ EXTERN void * Tcl_GetThreadData(Tcl_ThreadDataKey *keyPtr, EXTERN Tcl_Obj * Tcl_GetVar2Ex(Tcl_Interp *interp, const char *part1, const char *part2, int flags); /* 307 */ -EXTERN ClientData Tcl_InitNotifier(void); +EXTERN void * Tcl_InitNotifier(void); /* 308 */ EXTERN void Tcl_MutexLock(Tcl_Mutex *mutexPtr); /* 309 */ @@ -1047,7 +1041,7 @@ const char * Tcl_GetDefaultEncodingDir(void); TCL_DEPRECATED("Use Tcl_SetEncodingSearchPath") void Tcl_SetDefaultEncodingDir(const char *path); /* 343 */ -EXTERN void Tcl_AlertNotifier(ClientData clientData); +EXTERN void Tcl_AlertNotifier(void *clientData); /* 344 */ EXTERN void Tcl_ServiceModeHook(int mode); /* 345 */ @@ -1175,18 +1169,16 @@ EXTERN int Tcl_GetChannelNames(Tcl_Interp *interp); EXTERN int Tcl_GetChannelNamesEx(Tcl_Interp *interp, const char *pattern); /* 390 */ -EXTERN int Tcl_ProcObjCmd(ClientData clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); +EXTERN int Tcl_ProcObjCmd(void *clientData, Tcl_Interp *interp, + int objc, Tcl_Obj *const objv[]); /* 391 */ EXTERN void Tcl_ConditionFinalize(Tcl_Condition *condPtr); /* 392 */ EXTERN void Tcl_MutexFinalize(Tcl_Mutex *mutex); /* 393 */ EXTERN int Tcl_CreateThread(Tcl_ThreadId *idPtr, - Tcl_ThreadCreateProc *proc, - ClientData clientData, int stackSize, - int flags); + Tcl_ThreadCreateProc *proc, void *clientData, + int stackSize, int flags); /* 394 */ EXTERN int Tcl_ReadRaw(Tcl_Channel chan, char *dst, int bytesToRead); @@ -1276,20 +1268,18 @@ EXTERN void Tcl_InitCustomHashTable(Tcl_HashTable *tablePtr, /* 424 */ EXTERN void Tcl_InitObjHashTable(Tcl_HashTable *tablePtr); /* 425 */ -EXTERN ClientData Tcl_CommandTraceInfo(Tcl_Interp *interp, +EXTERN void * Tcl_CommandTraceInfo(Tcl_Interp *interp, const char *varName, int flags, Tcl_CommandTraceProc *procPtr, - ClientData prevClientData); + void *prevClientData); /* 426 */ EXTERN int Tcl_TraceCommand(Tcl_Interp *interp, const char *varName, int flags, - Tcl_CommandTraceProc *proc, - ClientData clientData); + Tcl_CommandTraceProc *proc, void *clientData); /* 427 */ EXTERN void Tcl_UntraceCommand(Tcl_Interp *interp, const char *varName, int flags, - Tcl_CommandTraceProc *proc, - ClientData clientData); + Tcl_CommandTraceProc *proc, void *clientData); /* 428 */ EXTERN char * Tcl_AttemptAlloc(unsigned int size); /* 429 */ @@ -1312,8 +1302,7 @@ TCL_DEPRECATED("") int Tcl_GetMathFuncInfo(Tcl_Interp *interp, const char *name, int *numArgsPtr, Tcl_ValueType **argTypesPtr, - Tcl_MathProc **procPtr, - ClientData *clientDataPtr); + Tcl_MathProc **procPtr, void **clientDataPtr); /* 436 */ TCL_DEPRECATED("") Tcl_Obj * Tcl_ListMathFuncs(Tcl_Interp *interp, @@ -1398,7 +1387,7 @@ EXTERN Tcl_Obj * Tcl_FSGetNormalizedPath(Tcl_Interp *interp, EXTERN Tcl_Obj * Tcl_FSJoinToPath(Tcl_Obj *pathPtr, int objc, Tcl_Obj *const objv[]); /* 465 */ -EXTERN ClientData Tcl_FSGetInternalRep(Tcl_Obj *pathPtr, +EXTERN void * Tcl_FSGetInternalRep(Tcl_Obj *pathPtr, const Tcl_Filesystem *fsPtr); /* 466 */ EXTERN Tcl_Obj * Tcl_FSGetTranslatedPath(Tcl_Interp *interp, @@ -1408,7 +1397,7 @@ EXTERN int Tcl_FSEvalFile(Tcl_Interp *interp, Tcl_Obj *fileName); /* 468 */ EXTERN Tcl_Obj * Tcl_FSNewNativePath( const Tcl_Filesystem *fromFilesystem, - ClientData clientData); + void *clientData); /* 469 */ EXTERN const void * Tcl_FSGetNativePath(Tcl_Obj *pathPtr); /* 470 */ @@ -1418,12 +1407,12 @@ EXTERN Tcl_Obj * Tcl_FSPathSeparator(Tcl_Obj *pathPtr); /* 472 */ EXTERN Tcl_Obj * Tcl_FSListVolumes(void); /* 473 */ -EXTERN int Tcl_FSRegister(ClientData clientData, +EXTERN int Tcl_FSRegister(void *clientData, const Tcl_Filesystem *fsPtr); /* 474 */ EXTERN int Tcl_FSUnregister(const Tcl_Filesystem *fsPtr); /* 475 */ -EXTERN ClientData Tcl_FSData(const Tcl_Filesystem *fsPtr); +EXTERN void * Tcl_FSData(const Tcl_Filesystem *fsPtr); /* 476 */ EXTERN const char * Tcl_FSGetTranslatedStringPath(Tcl_Interp *interp, Tcl_Obj *pathPtr); @@ -1443,7 +1432,7 @@ EXTERN void Tcl_GetTime(Tcl_Time *timeBuf); /* 483 */ EXTERN Tcl_Trace Tcl_CreateObjTrace(Tcl_Interp *interp, int level, int flags, Tcl_CmdObjTraceProc *objProc, - ClientData clientData, + void *clientData, Tcl_CmdObjTraceDeleteProc *delProc); /* 484 */ EXTERN int Tcl_GetCommandInfoFromToken(Tcl_Command token, @@ -1514,7 +1503,7 @@ EXTERN void Tcl_RegisterConfig(Tcl_Interp *interp, const char *valEncoding); /* 506 */ EXTERN Tcl_Namespace * Tcl_CreateNamespace(Tcl_Interp *interp, - const char *name, ClientData clientData, + const char *name, void *clientData, Tcl_NamespaceDeleteProc *deleteProc); /* 507 */ EXTERN void Tcl_DeleteNamespace(Tcl_Namespace *nsPtr); @@ -1555,12 +1544,12 @@ EXTERN Tcl_ExitProc * Tcl_SetExitProc(TCL_NORETURN1 Tcl_ExitProc *proc); /* 520 */ EXTERN void Tcl_LimitAddHandler(Tcl_Interp *interp, int type, Tcl_LimitHandlerProc *handlerProc, - ClientData clientData, + void *clientData, Tcl_LimitHandlerDeleteProc *deleteProc); /* 521 */ EXTERN void Tcl_LimitRemoveHandler(Tcl_Interp *interp, int type, Tcl_LimitHandlerProc *handlerProc, - ClientData clientData); + void *clientData); /* 522 */ EXTERN int Tcl_LimitReady(Tcl_Interp *interp); /* 523 */ @@ -1643,11 +1632,11 @@ EXTERN int Tcl_GetEnsembleNamespace(Tcl_Interp *interp, /* 552 */ EXTERN void Tcl_SetTimeProc(Tcl_GetTimeProc *getProc, Tcl_ScaleTimeProc *scaleProc, - ClientData clientData); + void *clientData); /* 553 */ EXTERN void Tcl_QueryTimeProc(Tcl_GetTimeProc **getProc, Tcl_ScaleTimeProc **scaleProc, - ClientData *clientData); + void **clientData); /* 554 */ EXTERN Tcl_DriverThreadActionProc * Tcl_ChannelThreadActionProc( const Tcl_ChannelType *chanTypePtr); @@ -1724,7 +1713,7 @@ EXTERN void Tcl_AppendPrintfToObj(Tcl_Obj *objPtr, const char *format, ...) TCL_FORMAT_PRINTF(2, 3); /* 580 */ EXTERN int Tcl_CancelEval(Tcl_Interp *interp, - Tcl_Obj *resultObjPtr, ClientData clientData, + Tcl_Obj *resultObjPtr, void *clientData, int flags); /* 581 */ EXTERN int Tcl_Canceled(Tcl_Interp *interp, int flags); @@ -1735,8 +1724,7 @@ EXTERN int Tcl_CreatePipe(Tcl_Interp *interp, /* 583 */ EXTERN Tcl_Command Tcl_NRCreateCommand(Tcl_Interp *interp, const char *cmdName, Tcl_ObjCmdProc *proc, - Tcl_ObjCmdProc *nreProc, - ClientData clientData, + Tcl_ObjCmdProc *nreProc, void *clientData, Tcl_CmdDeleteProc *deleteProc); /* 584 */ EXTERN int Tcl_NREvalObj(Tcl_Interp *interp, Tcl_Obj *objPtr, @@ -1749,14 +1737,12 @@ EXTERN int Tcl_NRCmdSwap(Tcl_Interp *interp, Tcl_Command cmd, int objc, Tcl_Obj *const objv[], int flags); /* 587 */ EXTERN void Tcl_NRAddCallback(Tcl_Interp *interp, - Tcl_NRPostProc *postProcPtr, - ClientData data0, ClientData data1, - ClientData data2, ClientData data3); + Tcl_NRPostProc *postProcPtr, void *data0, + void *data1, void *data2, void *data3); /* 588 */ EXTERN int Tcl_NRCallObjProc(Tcl_Interp *interp, - Tcl_ObjCmdProc *objProc, - ClientData clientData, int objc, - Tcl_Obj *const objv[]); + Tcl_ObjCmdProc *objProc, void *clientData, + int objc, Tcl_Obj *const objv[]); /* 589 */ EXTERN unsigned Tcl_GetFSDeviceFromStat(const Tcl_StatBuf *statPtr); /* 590 */ @@ -1872,7 +1858,7 @@ EXTERN Tcl_Channel Tcl_OpenTcpServerEx(Tcl_Interp *interp, const char *service, const char *host, unsigned int flags, Tcl_TcpAcceptProc *acceptProc, - ClientData callbackData); + void *callbackData); /* 632 */ EXTERN int TclZipfs_Mount(Tcl_Interp *interp, const char *mountPoint, const char *zipname, @@ -2011,13 +1997,13 @@ typedef struct TclStubs { void (*tcl_DbCkfree) (char *ptr, const char *file, int line); /* 7 */ char * (*tcl_DbCkrealloc) (char *ptr, unsigned int size, const char *file, int line); /* 8 */ #if !defined(_WIN32) && !defined(MAC_OSX_TCL) /* UNIX */ - void (*tcl_CreateFileHandler) (int fd, int mask, Tcl_FileProc *proc, ClientData clientData); /* 9 */ + void (*tcl_CreateFileHandler) (int fd, int mask, Tcl_FileProc *proc, void *clientData); /* 9 */ #endif /* UNIX */ #if defined(_WIN32) /* WIN */ void (*reserved9)(void); #endif /* WIN */ #ifdef MAC_OSX_TCL /* MACOSX */ - void (*tcl_CreateFileHandler) (int fd, int mask, Tcl_FileProc *proc, ClientData clientData); /* 9 */ + void (*tcl_CreateFileHandler) (int fd, int mask, Tcl_FileProc *proc, void *clientData); /* 9 */ #endif /* MACOSX */ #if !defined(_WIN32) && !defined(MAC_OSX_TCL) /* UNIX */ void (*tcl_DeleteFileHandler) (int fd); /* 10 */ @@ -2088,7 +2074,7 @@ typedef struct TclStubs { void (*tcl_AllowExceptions) (Tcl_Interp *interp); /* 68 */ void (*tcl_AppendElement) (Tcl_Interp *interp, const char *element); /* 69 */ void (*tcl_AppendResult) (Tcl_Interp *interp, ...); /* 70 */ - Tcl_AsyncHandler (*tcl_AsyncCreate) (Tcl_AsyncProc *proc, ClientData clientData); /* 71 */ + Tcl_AsyncHandler (*tcl_AsyncCreate) (Tcl_AsyncProc *proc, void *clientData); /* 71 */ void (*tcl_AsyncDelete) (Tcl_AsyncHandler async); /* 72 */ int (*tcl_AsyncInvoke) (Tcl_Interp *interp, int code); /* 73 */ void (*tcl_AsyncMark) (Tcl_AsyncHandler async); /* 74 */ @@ -2096,8 +2082,8 @@ typedef struct TclStubs { TCL_DEPRECATED_API("No longer in use, changed to macro") void (*tcl_BackgroundError) (Tcl_Interp *interp); /* 76 */ TCL_DEPRECATED_API("Use Tcl_UtfBackslash") char (*tcl_Backslash) (const char *src, int *readPtr); /* 77 */ int (*tcl_BadChannelOption) (Tcl_Interp *interp, const char *optionName, const char *optionList); /* 78 */ - void (*tcl_CallWhenDeleted) (Tcl_Interp *interp, Tcl_InterpDeleteProc *proc, ClientData clientData); /* 79 */ - void (*tcl_CancelIdleCall) (Tcl_IdleProc *idleProc, ClientData clientData); /* 80 */ + void (*tcl_CallWhenDeleted) (Tcl_Interp *interp, Tcl_InterpDeleteProc *proc, void *clientData); /* 79 */ + void (*tcl_CancelIdleCall) (Tcl_IdleProc *idleProc, void *clientData); /* 80 */ int (*tcl_Close) (Tcl_Interp *interp, Tcl_Channel chan); /* 81 */ int (*tcl_CommandComplete) (const char *cmd); /* 82 */ char * (*tcl_Concat) (int argc, const char *const *argv); /* 83 */ @@ -2105,35 +2091,35 @@ typedef struct TclStubs { int (*tcl_ConvertCountedElement) (const char *src, int 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 */ - Tcl_Channel (*tcl_CreateChannel) (const Tcl_ChannelType *typePtr, const char *chanName, ClientData instanceData, int mask); /* 88 */ - void (*tcl_CreateChannelHandler) (Tcl_Channel chan, int mask, Tcl_ChannelProc *proc, ClientData clientData); /* 89 */ - void (*tcl_CreateCloseHandler) (Tcl_Channel chan, Tcl_CloseProc *proc, ClientData clientData); /* 90 */ - Tcl_Command (*tcl_CreateCommand) (Tcl_Interp *interp, const char *cmdName, Tcl_CmdProc *proc, ClientData clientData, Tcl_CmdDeleteProc *deleteProc); /* 91 */ - void (*tcl_CreateEventSource) (Tcl_EventSetupProc *setupProc, Tcl_EventCheckProc *checkProc, ClientData clientData); /* 92 */ - void (*tcl_CreateExitHandler) (Tcl_ExitProc *proc, ClientData clientData); /* 93 */ + 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 */ + Tcl_Command (*tcl_CreateCommand) (Tcl_Interp *interp, const char *cmdName, Tcl_CmdProc *proc, void *clientData, Tcl_CmdDeleteProc *deleteProc); /* 91 */ + void (*tcl_CreateEventSource) (Tcl_EventSetupProc *setupProc, Tcl_EventCheckProc *checkProc, void *clientData); /* 92 */ + void (*tcl_CreateExitHandler) (Tcl_ExitProc *proc, void *clientData); /* 93 */ Tcl_Interp * (*tcl_CreateInterp) (void); /* 94 */ - TCL_DEPRECATED_API("") void (*tcl_CreateMathFunc) (Tcl_Interp *interp, const char *name, int numArgs, Tcl_ValueType *argTypes, Tcl_MathProc *proc, ClientData clientData); /* 95 */ - Tcl_Command (*tcl_CreateObjCommand) (Tcl_Interp *interp, const char *cmdName, Tcl_ObjCmdProc *proc, ClientData clientData, Tcl_CmdDeleteProc *deleteProc); /* 96 */ + TCL_DEPRECATED_API("") void (*tcl_CreateMathFunc) (Tcl_Interp *interp, const char *name, int numArgs, Tcl_ValueType *argTypes, Tcl_MathProc *proc, void *clientData); /* 95 */ + Tcl_Command (*tcl_CreateObjCommand) (Tcl_Interp *interp, const char *cmdName, Tcl_ObjCmdProc *proc, void *clientData, Tcl_CmdDeleteProc *deleteProc); /* 96 */ Tcl_Interp * (*tcl_CreateChild) (Tcl_Interp *interp, const char *name, int isSafe); /* 97 */ - Tcl_TimerToken (*tcl_CreateTimerHandler) (int milliseconds, Tcl_TimerProc *proc, ClientData clientData); /* 98 */ - Tcl_Trace (*tcl_CreateTrace) (Tcl_Interp *interp, int level, Tcl_CmdTraceProc *proc, ClientData clientData); /* 99 */ + Tcl_TimerToken (*tcl_CreateTimerHandler) (int milliseconds, Tcl_TimerProc *proc, void *clientData); /* 98 */ + Tcl_Trace (*tcl_CreateTrace) (Tcl_Interp *interp, int level, Tcl_CmdTraceProc *proc, void *clientData); /* 99 */ void (*tcl_DeleteAssocData) (Tcl_Interp *interp, const char *name); /* 100 */ - void (*tcl_DeleteChannelHandler) (Tcl_Channel chan, Tcl_ChannelProc *proc, ClientData clientData); /* 101 */ - void (*tcl_DeleteCloseHandler) (Tcl_Channel chan, Tcl_CloseProc *proc, ClientData clientData); /* 102 */ + void (*tcl_DeleteChannelHandler) (Tcl_Channel chan, Tcl_ChannelProc *proc, void *clientData); /* 101 */ + void (*tcl_DeleteCloseHandler) (Tcl_Channel chan, Tcl_CloseProc *proc, void *clientData); /* 102 */ int (*tcl_DeleteCommand) (Tcl_Interp *interp, const char *cmdName); /* 103 */ int (*tcl_DeleteCommandFromToken) (Tcl_Interp *interp, Tcl_Command command); /* 104 */ - void (*tcl_DeleteEvents) (Tcl_EventDeleteProc *proc, ClientData clientData); /* 105 */ - void (*tcl_DeleteEventSource) (Tcl_EventSetupProc *setupProc, Tcl_EventCheckProc *checkProc, ClientData clientData); /* 106 */ - void (*tcl_DeleteExitHandler) (Tcl_ExitProc *proc, ClientData clientData); /* 107 */ + void (*tcl_DeleteEvents) (Tcl_EventDeleteProc *proc, void *clientData); /* 105 */ + void (*tcl_DeleteEventSource) (Tcl_EventSetupProc *setupProc, Tcl_EventCheckProc *checkProc, void *clientData); /* 106 */ + void (*tcl_DeleteExitHandler) (Tcl_ExitProc *proc, void *clientData); /* 107 */ 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_DeleteTimerHandler) (Tcl_TimerToken token); /* 112 */ void (*tcl_DeleteTrace) (Tcl_Interp *interp, Tcl_Trace trace); /* 113 */ - void (*tcl_DontCallWhenDeleted) (Tcl_Interp *interp, Tcl_InterpDeleteProc *proc, ClientData clientData); /* 114 */ + void (*tcl_DontCallWhenDeleted) (Tcl_Interp *interp, Tcl_InterpDeleteProc *proc, void *clientData); /* 114 */ int (*tcl_DoOneEvent) (int flags); /* 115 */ - void (*tcl_DoWhenIdle) (Tcl_IdleProc *proc, ClientData clientData); /* 116 */ + void (*tcl_DoWhenIdle) (Tcl_IdleProc *proc, void *clientData); /* 116 */ char * (*tcl_DStringAppend) (Tcl_DString *dsPtr, const char *bytes, int length); /* 117 */ char * (*tcl_DStringAppendElement) (Tcl_DString *dsPtr, const char *element); /* 118 */ void (*tcl_DStringEndSublist) (Tcl_DString *dsPtr); /* 119 */ @@ -2149,7 +2135,7 @@ typedef struct TclStubs { int (*tcl_Eval) (Tcl_Interp *interp, const char *script); /* 129 */ int (*tcl_EvalFile) (Tcl_Interp *interp, const char *fileName); /* 130 */ TCL_DEPRECATED_API("No longer in use, changed to macro") int (*tcl_EvalObj) (Tcl_Interp *interp, Tcl_Obj *objPtr); /* 131 */ - void (*tcl_EventuallyFree) (ClientData clientData, Tcl_FreeProc *freeProc); /* 132 */ + void (*tcl_EventuallyFree) (void *clientData, Tcl_FreeProc *freeProc); /* 132 */ TCL_NORETURN1 void (*tcl_Exit) (int status); /* 133 */ int (*tcl_ExposeCommand) (Tcl_Interp *interp, const char *hiddenCmdToken, const char *cmdName); /* 134 */ int (*tcl_ExprBoolean) (Tcl_Interp *interp, const char *expr, int *ptr); /* 135 */ @@ -2167,11 +2153,11 @@ typedef struct TclStubs { TCL_DEPRECATED_API("see TIP #559. Use Tcl_ResetResult") void (*tcl_FreeResult) (Tcl_Interp *interp); /* 147 */ int (*tcl_GetAlias) (Tcl_Interp *interp, const char *childCmd, Tcl_Interp **targetInterpPtr, const char **targetCmdPtr, int *argcPtr, const char ***argvPtr); /* 148 */ int (*tcl_GetAliasObj) (Tcl_Interp *interp, const char *childCmd, Tcl_Interp **targetInterpPtr, const char **targetCmdPtr, int *objcPtr, Tcl_Obj ***objv); /* 149 */ - ClientData (*tcl_GetAssocData) (Tcl_Interp *interp, const char *name, Tcl_InterpDeleteProc **procPtr); /* 150 */ + 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 */ - int (*tcl_GetChannelHandle) (Tcl_Channel chan, int direction, ClientData *handlePtr); /* 153 */ - ClientData (*tcl_GetChannelInstanceData) (Tcl_Channel chan); /* 154 */ + 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 */ const char * (*tcl_GetChannelName) (Tcl_Channel chan); /* 156 */ int (*tcl_GetChannelOption) (Tcl_Interp *interp, Tcl_Channel chan, const char *optionName, Tcl_DString *dsPtr); /* 157 */ @@ -2185,13 +2171,13 @@ typedef struct TclStubs { const char * (*tcl_GetNameOfExecutable) (void); /* 165 */ Tcl_Obj * (*tcl_GetObjResult) (Tcl_Interp *interp); /* 166 */ #if !defined(_WIN32) && !defined(MAC_OSX_TCL) /* UNIX */ - int (*tcl_GetOpenFile) (Tcl_Interp *interp, const char *chanID, int forWriting, int checkUsage, ClientData *filePtr); /* 167 */ + int (*tcl_GetOpenFile) (Tcl_Interp *interp, const char *chanID, int forWriting, int checkUsage, void **filePtr); /* 167 */ #endif /* UNIX */ #if defined(_WIN32) /* WIN */ void (*reserved167)(void); #endif /* WIN */ #ifdef MAC_OSX_TCL /* MACOSX */ - int (*tcl_GetOpenFile) (Tcl_Interp *interp, const char *chanID, int forWriting, int checkUsage, ClientData *filePtr); /* 167 */ + int (*tcl_GetOpenFile) (Tcl_Interp *interp, const char *chanID, int forWriting, int checkUsage, void **filePtr); /* 167 */ #endif /* MACOSX */ Tcl_PathType (*tcl_GetPathType) (const char *path); /* 168 */ int (*tcl_Gets) (Tcl_Channel chan, Tcl_DString *dsPtr); /* 169 */ @@ -2214,9 +2200,9 @@ typedef struct TclStubs { char * (*tcl_JoinPath) (int 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) (ClientData handle, int mode); /* 189 */ + Tcl_Channel (*tcl_MakeFileChannel) (void *handle, int mode); /* 189 */ int (*tcl_MakeSafe) (Tcl_Interp *interp); /* 190 */ - Tcl_Channel (*tcl_MakeTcpClientChannel) (ClientData tcpSocket); /* 191 */ + Tcl_Channel (*tcl_MakeTcpClientChannel) (void *tcpSocket); /* 191 */ char * (*tcl_Merge) (int argc, const char *const *argv); /* 192 */ Tcl_HashEntry * (*tcl_NextHashEntry) (Tcl_HashSearch *searchPtr); /* 193 */ void (*tcl_NotifyChannel) (Tcl_Channel channel, int mask); /* 194 */ @@ -2225,8 +2211,8 @@ typedef struct TclStubs { Tcl_Channel (*tcl_OpenCommandChannel) (Tcl_Interp *interp, int 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, ClientData callbackData); /* 200 */ - void (*tcl_Preserve) (ClientData data); /* 201 */ + Tcl_Channel (*tcl_OpenTcpServer) (Tcl_Interp *interp, int port, const char *host, Tcl_TcpAcceptProc *acceptProc, void *callbackData); /* 200 */ + void (*tcl_Preserve) (void *data); /* 201 */ 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 */ @@ -2241,14 +2227,14 @@ typedef struct TclStubs { int (*tcl_RegExpExec) (Tcl_Interp *interp, Tcl_RegExp regexp, const char *text, const char *start); /* 213 */ int (*tcl_RegExpMatch) (Tcl_Interp *interp, const char *text, const char *pattern); /* 214 */ void (*tcl_RegExpRange) (Tcl_RegExp regexp, int index, const char **startPtr, const char **endPtr); /* 215 */ - void (*tcl_Release) (ClientData clientData); /* 216 */ + void (*tcl_Release) (void *clientData); /* 216 */ void (*tcl_ResetResult) (Tcl_Interp *interp); /* 217 */ int (*tcl_ScanElement) (const char *src, int *flagPtr); /* 218 */ int (*tcl_ScanCountedElement) (const char *src, int length, int *flagPtr); /* 219 */ TCL_DEPRECATED_API("") int (*tcl_SeekOld) (Tcl_Channel chan, int offset, int mode); /* 220 */ int (*tcl_ServiceAll) (void); /* 221 */ int (*tcl_ServiceEvent) (int flags); /* 222 */ - void (*tcl_SetAssocData) (Tcl_Interp *interp, const char *name, Tcl_InterpDeleteProc *proc, ClientData clientData); /* 223 */ + void (*tcl_SetAssocData) (Tcl_Interp *interp, const char *name, Tcl_InterpDeleteProc *proc, void *clientData); /* 223 */ void (*tcl_SetChannelBufferSize) (Tcl_Channel chan, int sz); /* 224 */ int (*tcl_SetChannelOption) (Tcl_Interp *interp, Tcl_Channel chan, const char *optionName, const char *newValue); /* 225 */ int (*tcl_SetCommandInfo) (Tcl_Interp *interp, const char *cmdName, const Tcl_CmdInfo *infoPtr); /* 226 */ @@ -2272,22 +2258,22 @@ typedef struct TclStubs { TCL_DEPRECATED_API("Don't use this function in a stub-enabled extension") void (*tcl_StaticLibrary) (Tcl_Interp *interp, const char *prefix, Tcl_LibraryInitProc *initProc, Tcl_LibraryInitProc *safeInitProc); /* 244 */ TCL_DEPRECATED_API("No longer in use, changed to macro") int (*tcl_StringMatch) (const char *str, const char *pattern); /* 245 */ TCL_DEPRECATED_API("") int (*tcl_TellOld) (Tcl_Channel chan); /* 246 */ - TCL_DEPRECATED_API("No longer in use, changed to macro") int (*tcl_TraceVar) (Tcl_Interp *interp, const char *varName, int flags, Tcl_VarTraceProc *proc, ClientData clientData); /* 247 */ - int (*tcl_TraceVar2) (Tcl_Interp *interp, const char *part1, const char *part2, int flags, Tcl_VarTraceProc *proc, ClientData clientData); /* 248 */ + TCL_DEPRECATED_API("No longer in use, changed to macro") int (*tcl_TraceVar) (Tcl_Interp *interp, const char *varName, int flags, Tcl_VarTraceProc *proc, void *clientData); /* 247 */ + int (*tcl_TraceVar2) (Tcl_Interp *interp, const char *part1, const char *part2, int flags, Tcl_VarTraceProc *proc, void *clientData); /* 248 */ char * (*tcl_TranslateFileName) (Tcl_Interp *interp, const char *name, Tcl_DString *bufferPtr); /* 249 */ int (*tcl_Ungets) (Tcl_Channel chan, const char *str, int len, int atHead); /* 250 */ void (*tcl_UnlinkVar) (Tcl_Interp *interp, const char *varName); /* 251 */ int (*tcl_UnregisterChannel) (Tcl_Interp *interp, Tcl_Channel chan); /* 252 */ TCL_DEPRECATED_API("No longer in use, changed to macro") int (*tcl_UnsetVar) (Tcl_Interp *interp, const char *varName, int flags); /* 253 */ int (*tcl_UnsetVar2) (Tcl_Interp *interp, const char *part1, const char *part2, int flags); /* 254 */ - TCL_DEPRECATED_API("No longer in use, changed to macro") void (*tcl_UntraceVar) (Tcl_Interp *interp, const char *varName, int flags, Tcl_VarTraceProc *proc, ClientData clientData); /* 255 */ - void (*tcl_UntraceVar2) (Tcl_Interp *interp, const char *part1, const char *part2, int flags, Tcl_VarTraceProc *proc, ClientData clientData); /* 256 */ + TCL_DEPRECATED_API("No longer in use, changed to macro") void (*tcl_UntraceVar) (Tcl_Interp *interp, const char *varName, int flags, Tcl_VarTraceProc *proc, void *clientData); /* 255 */ + void (*tcl_UntraceVar2) (Tcl_Interp *interp, const char *part1, const char *part2, int flags, Tcl_VarTraceProc *proc, void *clientData); /* 256 */ void (*tcl_UpdateLinkedVar) (Tcl_Interp *interp, const char *varName); /* 257 */ TCL_DEPRECATED_API("No longer in use, changed to macro") int (*tcl_UpVar) (Tcl_Interp *interp, const char *frameName, const char *varName, const char *localName, int flags); /* 258 */ int (*tcl_UpVar2) (Tcl_Interp *interp, const char *frameName, const char *part1, const char *part2, const char *localName, int flags); /* 259 */ int (*tcl_VarEval) (Tcl_Interp *interp, ...); /* 260 */ - TCL_DEPRECATED_API("No longer in use, changed to macro") ClientData (*tcl_VarTraceInfo) (Tcl_Interp *interp, const char *varName, int flags, Tcl_VarTraceProc *procPtr, ClientData prevClientData); /* 261 */ - ClientData (*tcl_VarTraceInfo2) (Tcl_Interp *interp, const char *part1, const char *part2, int flags, Tcl_VarTraceProc *procPtr, ClientData prevClientData); /* 262 */ + TCL_DEPRECATED_API("No longer in use, changed to macro") void * (*tcl_VarTraceInfo) (Tcl_Interp *interp, const char *varName, int flags, Tcl_VarTraceProc *procPtr, void *prevClientData); /* 261 */ + void * (*tcl_VarTraceInfo2) (Tcl_Interp *interp, const char *part1, const char *part2, int flags, Tcl_VarTraceProc *procPtr, void *prevClientData); /* 262 */ int (*tcl_Write) (Tcl_Channel chan, const char *s, int slen); /* 263 */ void (*tcl_WrongNumArgs) (Tcl_Interp *interp, int objc, Tcl_Obj *const objv[], const char *message); /* 264 */ int (*tcl_DumpActiveMemory) (const char *fileName); /* 265 */ @@ -2306,15 +2292,15 @@ typedef struct TclStubs { TCL_DEPRECATED_API("see TIP #422") TCL_NORETURN1 void (*tcl_PanicVA) (const char *format, va_list argList); /* 278 */ void (*tcl_GetVersion) (int *major, int *minor, int *patchLevel, int *type); /* 279 */ void (*tcl_InitMemory) (Tcl_Interp *interp); /* 280 */ - Tcl_Channel (*tcl_StackChannel) (Tcl_Interp *interp, const Tcl_ChannelType *typePtr, ClientData instanceData, int mask, Tcl_Channel prevChan); /* 281 */ + Tcl_Channel (*tcl_StackChannel) (Tcl_Interp *interp, const Tcl_ChannelType *typePtr, void *instanceData, int mask, Tcl_Channel prevChan); /* 281 */ int (*tcl_UnstackChannel) (Tcl_Interp *interp, Tcl_Channel chan); /* 282 */ Tcl_Channel (*tcl_GetStackedChannel) (Tcl_Channel chan); /* 283 */ void (*tcl_SetMainLoop) (Tcl_MainLoopProc *proc); /* 284 */ void (*reserved285)(void); void (*tcl_AppendObjToObj) (Tcl_Obj *objPtr, Tcl_Obj *appendObjPtr); /* 286 */ Tcl_Encoding (*tcl_CreateEncoding) (const Tcl_EncodingType *typePtr); /* 287 */ - void (*tcl_CreateThreadExitHandler) (Tcl_ExitProc *proc, ClientData clientData); /* 288 */ - void (*tcl_DeleteThreadExitHandler) (Tcl_ExitProc *proc, ClientData clientData); /* 289 */ + void (*tcl_CreateThreadExitHandler) (Tcl_ExitProc *proc, void *clientData); /* 288 */ + void (*tcl_DeleteThreadExitHandler) (Tcl_ExitProc *proc, void *clientData); /* 289 */ void (*tcl_DiscardResult) (Tcl_SavedResult *statePtr); /* 290 */ int (*tcl_EvalEx) (Tcl_Interp *interp, const char *script, int numBytes, int flags); /* 291 */ int (*tcl_EvalObjv) (Tcl_Interp *interp, int objc, Tcl_Obj *const objv[], int flags); /* 292 */ @@ -2323,7 +2309,7 @@ typedef struct TclStubs { int (*tcl_ExternalToUtf) (Tcl_Interp *interp, Tcl_Encoding encoding, const char *src, int srcLen, int flags, Tcl_EncodingState *statePtr, char *dst, int dstLen, int *srcReadPtr, int *dstWrotePtr, int *dstCharsPtr); /* 295 */ char * (*tcl_ExternalToUtfDString) (Tcl_Encoding encoding, const char *src, int srcLen, Tcl_DString *dsPtr); /* 296 */ void (*tcl_FinalizeThread) (void); /* 297 */ - void (*tcl_FinalizeNotifier) (ClientData clientData); /* 298 */ + void (*tcl_FinalizeNotifier) (void *clientData); /* 298 */ void (*tcl_FreeEncoding) (Tcl_Encoding encoding); /* 299 */ Tcl_ThreadId (*tcl_GetCurrentThread) (void); /* 300 */ Tcl_Encoding (*tcl_GetEncoding) (Tcl_Interp *interp, const char *name); /* 301 */ @@ -2332,7 +2318,7 @@ typedef struct TclStubs { int (*tcl_GetIndexFromObjStruct) (Tcl_Interp *interp, Tcl_Obj *objPtr, const void *tablePtr, int offset, const char *msg, int flags, void *indexPtr); /* 304 */ void * (*tcl_GetThreadData) (Tcl_ThreadDataKey *keyPtr, int size); /* 305 */ Tcl_Obj * (*tcl_GetVar2Ex) (Tcl_Interp *interp, const char *part1, const char *part2, int flags); /* 306 */ - ClientData (*tcl_InitNotifier) (void); /* 307 */ + void * (*tcl_InitNotifier) (void); /* 307 */ void (*tcl_MutexLock) (Tcl_Mutex *mutexPtr); /* 308 */ void (*tcl_MutexUnlock) (Tcl_Mutex *mutexPtr); /* 309 */ void (*tcl_ConditionNotify) (Tcl_Condition *condPtr); /* 310 */ @@ -2368,7 +2354,7 @@ typedef struct TclStubs { char * (*tcl_GetString) (Tcl_Obj *objPtr); /* 340 */ TCL_DEPRECATED_API("Use Tcl_GetEncodingSearchPath") const char * (*tcl_GetDefaultEncodingDir) (void); /* 341 */ TCL_DEPRECATED_API("Use Tcl_SetEncodingSearchPath") void (*tcl_SetDefaultEncodingDir) (const char *path); /* 342 */ - void (*tcl_AlertNotifier) (ClientData clientData); /* 343 */ + void (*tcl_AlertNotifier) (void *clientData); /* 343 */ void (*tcl_ServiceModeHook) (int mode); /* 344 */ int (*tcl_UniCharIsAlnum) (int ch); /* 345 */ int (*tcl_UniCharIsAlpha) (int ch); /* 346 */ @@ -2415,10 +2401,10 @@ typedef struct TclStubs { Tcl_Mutex * (*tcl_GetAllocMutex) (void); /* 387 */ int (*tcl_GetChannelNames) (Tcl_Interp *interp); /* 388 */ int (*tcl_GetChannelNamesEx) (Tcl_Interp *interp, const char *pattern); /* 389 */ - int (*tcl_ProcObjCmd) (ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); /* 390 */ + int (*tcl_ProcObjCmd) (void *clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); /* 390 */ void (*tcl_ConditionFinalize) (Tcl_Condition *condPtr); /* 391 */ void (*tcl_MutexFinalize) (Tcl_Mutex *mutex); /* 392 */ - int (*tcl_CreateThread) (Tcl_ThreadId *idPtr, Tcl_ThreadCreateProc *proc, ClientData clientData, int stackSize, int flags); /* 393 */ + int (*tcl_CreateThread) (Tcl_ThreadId *idPtr, Tcl_ThreadCreateProc *proc, void *clientData, int stackSize, int flags); /* 393 */ int (*tcl_ReadRaw) (Tcl_Channel chan, char *dst, int bytesToRead); /* 394 */ int (*tcl_WriteRaw) (Tcl_Channel chan, const char *src, int srcLen); /* 395 */ Tcl_Channel (*tcl_GetTopChannel) (Tcl_Channel chan); /* 396 */ @@ -2450,9 +2436,9 @@ typedef struct TclStubs { 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 */ void (*tcl_InitObjHashTable) (Tcl_HashTable *tablePtr); /* 424 */ - ClientData (*tcl_CommandTraceInfo) (Tcl_Interp *interp, const char *varName, int flags, Tcl_CommandTraceProc *procPtr, ClientData prevClientData); /* 425 */ - int (*tcl_TraceCommand) (Tcl_Interp *interp, const char *varName, int flags, Tcl_CommandTraceProc *proc, ClientData clientData); /* 426 */ - void (*tcl_UntraceCommand) (Tcl_Interp *interp, const char *varName, int flags, Tcl_CommandTraceProc *proc, ClientData clientData); /* 427 */ + void * (*tcl_CommandTraceInfo) (Tcl_Interp *interp, const char *varName, int flags, Tcl_CommandTraceProc *procPtr, void *prevClientData); /* 425 */ + int (*tcl_TraceCommand) (Tcl_Interp *interp, const char *varName, int flags, Tcl_CommandTraceProc *proc, void *clientData); /* 426 */ + void (*tcl_UntraceCommand) (Tcl_Interp *interp, const char *varName, int flags, Tcl_CommandTraceProc *proc, void *clientData); /* 427 */ char * (*tcl_AttemptAlloc) (unsigned int size); /* 428 */ char * (*tcl_AttemptDbCkalloc) (unsigned int size, const char *file, int line); /* 429 */ char * (*tcl_AttemptRealloc) (char *ptr, unsigned int size); /* 430 */ @@ -2460,7 +2446,7 @@ typedef struct TclStubs { int (*tcl_AttemptSetObjLength) (Tcl_Obj *objPtr, int length); /* 432 */ Tcl_ThreadId (*tcl_GetChannelThread) (Tcl_Channel channel); /* 433 */ 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("") int (*tcl_GetMathFuncInfo) (Tcl_Interp *interp, const char *name, int *numArgsPtr, Tcl_ValueType **argTypesPtr, Tcl_MathProc **procPtr, void **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 */ int (*tcl_DetachChannel) (Tcl_Interp *interp, Tcl_Channel channel); /* 438 */ @@ -2490,17 +2476,17 @@ typedef struct TclStubs { 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, int objc, Tcl_Obj *const objv[]); /* 464 */ - ClientData (*tcl_FSGetInternalRep) (Tcl_Obj *pathPtr, const Tcl_Filesystem *fsPtr); /* 465 */ + void * (*tcl_FSGetInternalRep) (Tcl_Obj *pathPtr, const Tcl_Filesystem *fsPtr); /* 465 */ Tcl_Obj * (*tcl_FSGetTranslatedPath) (Tcl_Interp *interp, Tcl_Obj *pathPtr); /* 466 */ int (*tcl_FSEvalFile) (Tcl_Interp *interp, Tcl_Obj *fileName); /* 467 */ - Tcl_Obj * (*tcl_FSNewNativePath) (const Tcl_Filesystem *fromFilesystem, ClientData clientData); /* 468 */ + Tcl_Obj * (*tcl_FSNewNativePath) (const Tcl_Filesystem *fromFilesystem, void *clientData); /* 468 */ const void * (*tcl_FSGetNativePath) (Tcl_Obj *pathPtr); /* 469 */ Tcl_Obj * (*tcl_FSFileSystemInfo) (Tcl_Obj *pathPtr); /* 470 */ Tcl_Obj * (*tcl_FSPathSeparator) (Tcl_Obj *pathPtr); /* 471 */ Tcl_Obj * (*tcl_FSListVolumes) (void); /* 472 */ - int (*tcl_FSRegister) (ClientData clientData, const Tcl_Filesystem *fsPtr); /* 473 */ + int (*tcl_FSRegister) (void *clientData, const Tcl_Filesystem *fsPtr); /* 473 */ int (*tcl_FSUnregister) (const Tcl_Filesystem *fsPtr); /* 474 */ - ClientData (*tcl_FSData) (const Tcl_Filesystem *fsPtr); /* 475 */ + void * (*tcl_FSData) (const Tcl_Filesystem *fsPtr); /* 475 */ const char * (*tcl_FSGetTranslatedStringPath) (Tcl_Interp *interp, Tcl_Obj *pathPtr); /* 476 */ CONST86 Tcl_Filesystem * (*tcl_FSGetFileSystemForPath) (Tcl_Obj *pathPtr); /* 477 */ Tcl_PathType (*tcl_FSGetPathType) (Tcl_Obj *pathPtr); /* 478 */ @@ -2508,7 +2494,7 @@ typedef struct TclStubs { void (*tcl_FSMountsChanged) (const Tcl_Filesystem *fsPtr); /* 480 */ int (*tcl_EvalTokensStandard) (Tcl_Interp *interp, Tcl_Token *tokenPtr, int count); /* 481 */ void (*tcl_GetTime) (Tcl_Time *timeBuf); /* 482 */ - Tcl_Trace (*tcl_CreateObjTrace) (Tcl_Interp *interp, int level, int flags, Tcl_CmdObjTraceProc *objProc, ClientData clientData, Tcl_CmdObjTraceDeleteProc *delProc); /* 483 */ + Tcl_Trace (*tcl_CreateObjTrace) (Tcl_Interp *interp, int level, int flags, Tcl_CmdObjTraceProc *objProc, void *clientData, Tcl_CmdObjTraceDeleteProc *delProc); /* 483 */ int (*tcl_GetCommandInfoFromToken) (Tcl_Command token, Tcl_CmdInfo *infoPtr); /* 484 */ int (*tcl_SetCommandInfoFromToken) (Tcl_Command token, const Tcl_CmdInfo *infoPtr); /* 485 */ Tcl_Obj * (*tcl_DbNewWideIntObj) (Tcl_WideInt wideValue, const char *file, int line); /* 486 */ @@ -2531,7 +2517,7 @@ typedef struct TclStubs { 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 */ - Tcl_Namespace * (*tcl_CreateNamespace) (Tcl_Interp *interp, const char *name, ClientData clientData, Tcl_NamespaceDeleteProc *deleteProc); /* 506 */ + Tcl_Namespace * (*tcl_CreateNamespace) (Tcl_Interp *interp, const char *name, void *clientData, Tcl_NamespaceDeleteProc *deleteProc); /* 506 */ void (*tcl_DeleteNamespace) (Tcl_Namespace *nsPtr); /* 507 */ int (*tcl_AppendExportList) (Tcl_Interp *interp, Tcl_Namespace *nsPtr, Tcl_Obj *objPtr); /* 508 */ int (*tcl_Export) (Tcl_Interp *interp, Tcl_Namespace *nsPtr, const char *pattern, int resetListFirst); /* 509 */ @@ -2545,8 +2531,8 @@ typedef struct TclStubs { void (*tcl_GetCommandFullName) (Tcl_Interp *interp, Tcl_Command command, Tcl_Obj *objPtr); /* 517 */ int (*tcl_FSEvalFileEx) (Tcl_Interp *interp, Tcl_Obj *fileName, const char *encodingName); /* 518 */ TCL_DEPRECATED_API("Don't use this function in a stub-enabled extension") Tcl_ExitProc * (*tcl_SetExitProc) (TCL_NORETURN1 Tcl_ExitProc *proc); /* 519 */ - void (*tcl_LimitAddHandler) (Tcl_Interp *interp, int type, Tcl_LimitHandlerProc *handlerProc, ClientData clientData, Tcl_LimitHandlerDeleteProc *deleteProc); /* 520 */ - void (*tcl_LimitRemoveHandler) (Tcl_Interp *interp, int type, Tcl_LimitHandlerProc *handlerProc, ClientData clientData); /* 521 */ + void (*tcl_LimitAddHandler) (Tcl_Interp *interp, int type, Tcl_LimitHandlerProc *handlerProc, void *clientData, Tcl_LimitHandlerDeleteProc *deleteProc); /* 520 */ + void (*tcl_LimitRemoveHandler) (Tcl_Interp *interp, int type, Tcl_LimitHandlerProc *handlerProc, void *clientData); /* 521 */ int (*tcl_LimitReady) (Tcl_Interp *interp); /* 522 */ int (*tcl_LimitCheck) (Tcl_Interp *interp); /* 523 */ int (*tcl_LimitExceeded) (Tcl_Interp *interp); /* 524 */ @@ -2577,8 +2563,8 @@ typedef struct TclStubs { int (*tcl_GetEnsembleUnknownHandler) (Tcl_Interp *interp, Tcl_Command token, Tcl_Obj **unknownListPtr); /* 549 */ int (*tcl_GetEnsembleFlags) (Tcl_Interp *interp, Tcl_Command token, int *flagsPtr); /* 550 */ int (*tcl_GetEnsembleNamespace) (Tcl_Interp *interp, Tcl_Command token, Tcl_Namespace **namespacePtrPtr); /* 551 */ - void (*tcl_SetTimeProc) (Tcl_GetTimeProc *getProc, Tcl_ScaleTimeProc *scaleProc, ClientData clientData); /* 552 */ - void (*tcl_QueryTimeProc) (Tcl_GetTimeProc **getProc, Tcl_ScaleTimeProc **scaleProc, ClientData *clientData); /* 553 */ + void (*tcl_SetTimeProc) (Tcl_GetTimeProc *getProc, Tcl_ScaleTimeProc *scaleProc, void *clientData); /* 552 */ + void (*tcl_QueryTimeProc) (Tcl_GetTimeProc **getProc, Tcl_ScaleTimeProc **scaleProc, void **clientData); /* 553 */ Tcl_DriverThreadActionProc * (*tcl_ChannelThreadActionProc) (const Tcl_ChannelType *chanTypePtr); /* 554 */ Tcl_Obj * (*tcl_NewBignumObj) (void *value); /* 555 */ Tcl_Obj * (*tcl_DbNewBignumObj) (void *value, const char *file, int line); /* 556 */ @@ -2605,15 +2591,15 @@ typedef struct TclStubs { int (*tcl_AppendFormatToObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, const char *format, int 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, ClientData clientData, int flags); /* 580 */ + int (*tcl_CancelEval) (Tcl_Interp *interp, Tcl_Obj *resultObjPtr, void *clientData, int flags); /* 580 */ int (*tcl_Canceled) (Tcl_Interp *interp, int flags); /* 581 */ 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, ClientData clientData, Tcl_CmdDeleteProc *deleteProc); /* 583 */ + 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 */ - void (*tcl_NRAddCallback) (Tcl_Interp *interp, Tcl_NRPostProc *postProcPtr, ClientData data0, ClientData data1, ClientData data2, ClientData data3); /* 587 */ - int (*tcl_NRCallObjProc) (Tcl_Interp *interp, Tcl_ObjCmdProc *objProc, ClientData clientData, int objc, Tcl_Obj *const objv[]); /* 588 */ + 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 */ unsigned (*tcl_GetFSDeviceFromStat) (const Tcl_StatBuf *statPtr); /* 589 */ unsigned (*tcl_GetFSInodeFromStat) (const Tcl_StatBuf *statPtr); /* 590 */ unsigned (*tcl_GetModeFromStat) (const Tcl_StatBuf *statPtr); /* 591 */ @@ -2656,7 +2642,7 @@ typedef struct TclStubs { void * (*tcl_FindSymbol) (Tcl_Interp *interp, Tcl_LoadHandle handle, const char *symbol); /* 628 */ int (*tcl_FSUnloadFile) (Tcl_Interp *interp, Tcl_LoadHandle handlePtr); /* 629 */ void (*tcl_ZlibStreamSetCompressionDictionary) (Tcl_ZlibStream zhandle, Tcl_Obj *compressionDictionaryObj); /* 630 */ - Tcl_Channel (*tcl_OpenTcpServerEx) (Tcl_Interp *interp, const char *service, const char *host, unsigned int flags, Tcl_TcpAcceptProc *acceptProc, ClientData callbackData); /* 631 */ + Tcl_Channel (*tcl_OpenTcpServerEx) (Tcl_Interp *interp, const char *service, const char *host, unsigned int flags, Tcl_TcpAcceptProc *acceptProc, void *callbackData); /* 631 */ int (*tclZipfs_Mount) (Tcl_Interp *interp, const char *mountPoint, const char *zipname, const char *passwd); /* 632 */ int (*tclZipfs_Unmount) (Tcl_Interp *interp, const char *mountPoint); /* 633 */ Tcl_Obj * (*tclZipfs_TclLibrary) (void); /* 634 */ -- cgit v0.12 From d8ca9aa4063da1a8feecfa3efb60c4fc1a72b5bf Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 23 Jun 2022 08:58:56 +0000 Subject: Use TCL_HASH_TYPE in stead of "unsigned int", wherever the Tcl 9.0 type is "size_t", in tclDecls.h --- generic/tcl.decls | 18 +++++++++--------- generic/tclDecls.h | 36 ++++++++++++++++++------------------ 2 files changed, 27 insertions(+), 27 deletions(-) diff --git a/generic/tcl.decls b/generic/tcl.decls index 4b95098..a5b5539 100644 --- a/generic/tcl.decls +++ b/generic/tcl.decls @@ -40,22 +40,22 @@ declare 2 { TCL_NORETURN void Tcl_Panic(const char *format, ...) } declare 3 { - char *Tcl_Alloc(unsigned int size) + char *Tcl_Alloc(TCL_HASH_TYPE size) } declare 4 { void Tcl_Free(char *ptr) } declare 5 { - char *Tcl_Realloc(char *ptr, unsigned int size) + char *Tcl_Realloc(char *ptr, TCL_HASH_TYPE size) } declare 6 { - char *Tcl_DbCkalloc(unsigned int size, const char *file, int line) + char *Tcl_DbCkalloc(TCL_HASH_TYPE size, const char *file, int line) } declare 7 { void Tcl_DbCkfree(char *ptr, const char *file, int line) } declare 8 { - char *Tcl_DbCkrealloc(char *ptr, unsigned int size, + char *Tcl_DbCkrealloc(char *ptr, TCL_HASH_TYPE size, const char *file, int line) } @@ -1521,16 +1521,16 @@ declare 427 { int flags, Tcl_CommandTraceProc *proc, void *clientData) } declare 428 { - char *Tcl_AttemptAlloc(unsigned int size) + char *Tcl_AttemptAlloc(TCL_HASH_TYPE size) } declare 429 { - char *Tcl_AttemptDbCkalloc(unsigned int size, const char *file, int line) + char *Tcl_AttemptDbCkalloc(TCL_HASH_TYPE size, const char *file, int line) } declare 430 { - char *Tcl_AttemptRealloc(char *ptr, unsigned int size) + char *Tcl_AttemptRealloc(char *ptr, TCL_HASH_TYPE size) } declare 431 { - char *Tcl_AttemptDbCkrealloc(char *ptr, unsigned int size, + char *Tcl_AttemptDbCkrealloc(char *ptr, TCL_HASH_TYPE size, const char *file, int line) } declare 432 { @@ -2356,7 +2356,7 @@ declare 636 { } declare 637 { char *Tcl_InitStringRep(Tcl_Obj *objPtr, const char *bytes, - unsigned int numBytes) + TCL_HASH_TYPE numBytes) } declare 638 { Tcl_ObjInternalRep *Tcl_FetchInternalRep(Tcl_Obj *objPtr, const Tcl_ObjType *typePtr) diff --git a/generic/tclDecls.h b/generic/tclDecls.h index 0371cc7..bd22890 100644 --- a/generic/tclDecls.h +++ b/generic/tclDecls.h @@ -61,18 +61,18 @@ EXTERN const char * Tcl_PkgRequireEx(Tcl_Interp *interp, /* 2 */ EXTERN TCL_NORETURN void Tcl_Panic(const char *format, ...) TCL_FORMAT_PRINTF(1, 2); /* 3 */ -EXTERN char * Tcl_Alloc(unsigned int size); +EXTERN char * Tcl_Alloc(TCL_HASH_TYPE size); /* 4 */ EXTERN void Tcl_Free(char *ptr); /* 5 */ -EXTERN char * Tcl_Realloc(char *ptr, unsigned int size); +EXTERN char * Tcl_Realloc(char *ptr, TCL_HASH_TYPE size); /* 6 */ -EXTERN char * Tcl_DbCkalloc(unsigned int size, const char *file, +EXTERN char * Tcl_DbCkalloc(TCL_HASH_TYPE size, const char *file, int line); /* 7 */ EXTERN void Tcl_DbCkfree(char *ptr, const char *file, int line); /* 8 */ -EXTERN char * Tcl_DbCkrealloc(char *ptr, unsigned int size, +EXTERN char * Tcl_DbCkrealloc(char *ptr, TCL_HASH_TYPE size, const char *file, int line); #if !defined(_WIN32) && !defined(MAC_OSX_TCL) /* UNIX */ /* 9 */ @@ -1281,14 +1281,14 @@ EXTERN void Tcl_UntraceCommand(Tcl_Interp *interp, const char *varName, int flags, Tcl_CommandTraceProc *proc, void *clientData); /* 428 */ -EXTERN char * Tcl_AttemptAlloc(unsigned int size); +EXTERN char * Tcl_AttemptAlloc(TCL_HASH_TYPE size); /* 429 */ -EXTERN char * Tcl_AttemptDbCkalloc(unsigned int size, +EXTERN char * Tcl_AttemptDbCkalloc(TCL_HASH_TYPE size, const char *file, int line); /* 430 */ -EXTERN char * Tcl_AttemptRealloc(char *ptr, unsigned int size); +EXTERN char * Tcl_AttemptRealloc(char *ptr, TCL_HASH_TYPE size); /* 431 */ -EXTERN char * Tcl_AttemptDbCkrealloc(char *ptr, unsigned int size, +EXTERN char * Tcl_AttemptDbCkrealloc(char *ptr, TCL_HASH_TYPE size, const char *file, int line); /* 432 */ EXTERN int Tcl_AttemptSetObjLength(Tcl_Obj *objPtr, int length); @@ -1876,7 +1876,7 @@ EXTERN int TclZipfs_MountBuffer(Tcl_Interp *interp, EXTERN void Tcl_FreeInternalRep(Tcl_Obj *objPtr); /* 637 */ EXTERN char * Tcl_InitStringRep(Tcl_Obj *objPtr, const char *bytes, - unsigned int numBytes); + TCL_HASH_TYPE numBytes); /* 638 */ EXTERN Tcl_ObjInternalRep * Tcl_FetchInternalRep(Tcl_Obj *objPtr, const Tcl_ObjType *typePtr); @@ -1990,12 +1990,12 @@ typedef struct TclStubs { int (*tcl_PkgProvideEx) (Tcl_Interp *interp, const char *name, const char *version, const void *clientData); /* 0 */ const char * (*tcl_PkgRequireEx) (Tcl_Interp *interp, const char *name, const char *version, int exact, void *clientDataPtr); /* 1 */ TCL_NORETURN1 void (*tcl_Panic) (const char *format, ...) TCL_FORMAT_PRINTF(1, 2); /* 2 */ - char * (*tcl_Alloc) (unsigned int size); /* 3 */ + char * (*tcl_Alloc) (TCL_HASH_TYPE size); /* 3 */ void (*tcl_Free) (char *ptr); /* 4 */ - char * (*tcl_Realloc) (char *ptr, unsigned int size); /* 5 */ - char * (*tcl_DbCkalloc) (unsigned int size, const char *file, int line); /* 6 */ + char * (*tcl_Realloc) (char *ptr, TCL_HASH_TYPE size); /* 5 */ + char * (*tcl_DbCkalloc) (TCL_HASH_TYPE size, const char *file, int line); /* 6 */ void (*tcl_DbCkfree) (char *ptr, const char *file, int line); /* 7 */ - char * (*tcl_DbCkrealloc) (char *ptr, unsigned int size, const char *file, int line); /* 8 */ + char * (*tcl_DbCkrealloc) (char *ptr, TCL_HASH_TYPE size, const char *file, int line); /* 8 */ #if !defined(_WIN32) && !defined(MAC_OSX_TCL) /* UNIX */ void (*tcl_CreateFileHandler) (int fd, int mask, Tcl_FileProc *proc, void *clientData); /* 9 */ #endif /* UNIX */ @@ -2439,10 +2439,10 @@ typedef struct TclStubs { void * (*tcl_CommandTraceInfo) (Tcl_Interp *interp, const char *varName, int flags, Tcl_CommandTraceProc *procPtr, void *prevClientData); /* 425 */ int (*tcl_TraceCommand) (Tcl_Interp *interp, const char *varName, int flags, Tcl_CommandTraceProc *proc, void *clientData); /* 426 */ void (*tcl_UntraceCommand) (Tcl_Interp *interp, const char *varName, int flags, Tcl_CommandTraceProc *proc, void *clientData); /* 427 */ - char * (*tcl_AttemptAlloc) (unsigned int size); /* 428 */ - char * (*tcl_AttemptDbCkalloc) (unsigned int size, const char *file, int line); /* 429 */ - char * (*tcl_AttemptRealloc) (char *ptr, unsigned int size); /* 430 */ - char * (*tcl_AttemptDbCkrealloc) (char *ptr, unsigned int size, const char *file, int line); /* 431 */ + char * (*tcl_AttemptAlloc) (TCL_HASH_TYPE size); /* 428 */ + char * (*tcl_AttemptDbCkalloc) (TCL_HASH_TYPE size, const char *file, int line); /* 429 */ + char * (*tcl_AttemptRealloc) (char *ptr, TCL_HASH_TYPE size); /* 430 */ + char * (*tcl_AttemptDbCkrealloc) (char *ptr, TCL_HASH_TYPE size, const char *file, int line); /* 431 */ int (*tcl_AttemptSetObjLength) (Tcl_Obj *objPtr, int length); /* 432 */ Tcl_ThreadId (*tcl_GetChannelThread) (Tcl_Channel channel); /* 433 */ unsigned short * (*tcl_GetUnicodeFromObj) (Tcl_Obj *objPtr, int *lengthPtr); /* 434 */ @@ -2648,7 +2648,7 @@ typedef struct TclStubs { Tcl_Obj * (*tclZipfs_TclLibrary) (void); /* 634 */ int (*tclZipfs_MountBuffer) (Tcl_Interp *interp, const char *mountPoint, unsigned char *data, size_t datalen, int copy); /* 635 */ void (*tcl_FreeInternalRep) (Tcl_Obj *objPtr); /* 636 */ - char * (*tcl_InitStringRep) (Tcl_Obj *objPtr, const char *bytes, unsigned int numBytes); /* 637 */ + char * (*tcl_InitStringRep) (Tcl_Obj *objPtr, const char *bytes, TCL_HASH_TYPE numBytes); /* 637 */ Tcl_ObjInternalRep * (*tcl_FetchInternalRep) (Tcl_Obj *objPtr, const Tcl_ObjType *typePtr); /* 638 */ void (*tcl_StoreInternalRep) (Tcl_Obj *objPtr, const Tcl_ObjType *typePtr, const Tcl_ObjInternalRep *irPtr); /* 639 */ int (*tcl_HasStringRep) (Tcl_Obj *objPtr); /* 640 */ -- cgit v0.12 From 1d210f93a2585643e58447b4773efc94243ad9de Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 23 Jun 2022 12:20:15 +0000 Subject: Use "void *" in stead of ClientData in tclInt.decs/tclOO.decls (backported from 9.0) --- generic/tclInt.decls | 20 ++++++++++---------- generic/tclIntDecls.h | 43 +++++++++++++++++++++---------------------- generic/tclOO.decls | 22 +++++++++++----------- generic/tclOODecls.h | 28 ++++++++++++++-------------- generic/tclOOIntDecls.h | 28 ++++++++++++++-------------- 5 files changed, 70 insertions(+), 71 deletions(-) diff --git a/generic/tclInt.decls b/generic/tclInt.decls index 6b0bdae..5a9f4f0 100644 --- a/generic/tclInt.decls +++ b/generic/tclInt.decls @@ -80,7 +80,7 @@ declare 12 { # Tcl_DString *headPtr, char *tail, Tcl_GlobTypeData *types) #} declare 14 { - int TclDumpMemoryInfo(ClientData clientData, int flags) + int TclDumpMemoryInfo(void *clientData, int flags) } # Removed in 8.1: # declare 15 { @@ -227,11 +227,11 @@ declare 51 { # int flags) #} declare 53 { - int TclInvokeObjectCommand(ClientData clientData, Tcl_Interp *interp, + int TclInvokeObjectCommand(void *clientData, Tcl_Interp *interp, int argc, const char **argv) } declare 54 { - int TclInvokeStringCommand(ClientData clientData, Tcl_Interp *interp, + int TclInvokeStringCommand(void *clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) } declare 55 { @@ -267,7 +267,7 @@ declare 62 { int TclObjCommandComplete(Tcl_Obj *cmdPtr) } declare 63 { - int TclObjInterpProc(ClientData clientData, Tcl_Interp *interp, + int TclObjInterpProc(void *clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) } declare 64 { @@ -357,7 +357,7 @@ declare 81 { # void TclPlatformInit(Tcl_Interp *interp) # } declare 88 {deprecated {}} { - char *TclPrecTraceProc(ClientData clientData, Tcl_Interp *interp, + char *TclPrecTraceProc(void *clientData, Tcl_Interp *interp, const char *name1, const char *name2, int flags) } declare 89 { @@ -377,7 +377,7 @@ declare 92 { const char *procName) } declare 93 { - void TclProcDeleteProc(ClientData clientData) + void TclProcDeleteProc(void *clientData) } # Removed in 8.5: #declare 94 { @@ -459,7 +459,7 @@ declare 112 { } declare 113 { Tcl_Namespace *TclCreateNamespace(Tcl_Interp *interp, const char *name, - ClientData clientData, Tcl_NamespaceDeleteProc *deleteProc) + void *clientData, Tcl_NamespaceDeleteProc *deleteProc) } declare 114 { void TclDeleteNamespace(Tcl_Namespace *nsPtr) @@ -565,7 +565,7 @@ declare 141 { } declare 142 { int TclSetByteCodeFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr, - CompileHookProc *hookProc, ClientData clientData) + CompileHookProc *hookProc, void *clientData) } declare 143 { int TclAddLiteralObj(struct CompileEnv *envPtr, Tcl_Obj *objPtr, @@ -642,7 +642,7 @@ declare 161 { Tcl_Obj *cmdObjPtr) } declare 162 { - void TclChannelEventScriptInvoker(ClientData clientData, int flags) + void TclChannelEventScriptInvoker(void *clientData, int flags) } # ALERT: The result of 'TclGetInstructionTable' is actually a @@ -940,7 +940,7 @@ declare 237 { # NRE functions for "rogue" extensions to exploit NRE; they will need to # include NRE.h too. declare 238 { - int TclNRInterpProc(ClientData clientData, Tcl_Interp *interp, + int TclNRInterpProc(void *clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) } declare 239 { diff --git a/generic/tclIntDecls.h b/generic/tclIntDecls.h index 28b2a61..33b6883 100644 --- a/generic/tclIntDecls.h +++ b/generic/tclIntDecls.h @@ -96,7 +96,7 @@ EXTERN void TclDeleteVars(Interp *iPtr, TclVarHashTable *tablePtr); /* Slot 13 is reserved */ /* 14 */ -EXTERN int TclDumpMemoryInfo(ClientData clientData, int flags); +EXTERN int TclDumpMemoryInfo(void *clientData, int flags); /* Slot 15 is reserved */ /* 16 */ EXTERN void TclExprFloatError(Tcl_Interp *interp, double value); @@ -173,11 +173,11 @@ EXTERN void TclInitCompiledLocals(Tcl_Interp *interp, EXTERN int TclInterpInit(Tcl_Interp *interp); /* Slot 52 is reserved */ /* 53 */ -EXTERN int TclInvokeObjectCommand(ClientData clientData, +EXTERN int TclInvokeObjectCommand(void *clientData, Tcl_Interp *interp, int argc, const char **argv); /* 54 */ -EXTERN int TclInvokeStringCommand(ClientData clientData, +EXTERN int TclInvokeStringCommand(void *clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); /* 55 */ @@ -197,7 +197,7 @@ EXTERN Tcl_Obj * TclNewProcBodyObj(Proc *procPtr); /* 62 */ EXTERN int TclObjCommandComplete(Tcl_Obj *cmdPtr); /* 63 */ -EXTERN int TclObjInterpProc(ClientData clientData, +EXTERN int TclObjInterpProc(void *clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); /* 64 */ @@ -235,7 +235,7 @@ EXTERN void * TclpRealloc(void *ptr, unsigned int size); /* Slot 87 is reserved */ /* 88 */ TCL_DEPRECATED("") -char * TclPrecTraceProc(ClientData clientData, +char * TclPrecTraceProc(void *clientData, Tcl_Interp *interp, const char *name1, const char *name2, int flags); /* 89 */ @@ -250,7 +250,7 @@ EXTERN int TclProcCompileProc(Tcl_Interp *interp, Proc *procPtr, const char *description, const char *procName); /* 93 */ -EXTERN void TclProcDeleteProc(ClientData clientData); +EXTERN void TclProcDeleteProc(void *clientData); /* Slot 94 is reserved */ /* Slot 95 is reserved */ /* 96 */ @@ -293,7 +293,7 @@ EXTERN int TclAppendExportList(Tcl_Interp *interp, Tcl_Namespace *nsPtr, Tcl_Obj *objPtr); /* 113 */ EXTERN Tcl_Namespace * TclCreateNamespace(Tcl_Interp *interp, - const char *name, ClientData clientData, + const char *name, void *clientData, Tcl_NamespaceDeleteProc *deleteProc); /* 114 */ EXTERN void TclDeleteNamespace(Tcl_Namespace *nsPtr); @@ -370,7 +370,7 @@ EXTERN const char * TclpGetCwd(Tcl_Interp *interp, Tcl_DString *cwdPtr); /* 142 */ EXTERN int TclSetByteCodeFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr, CompileHookProc *hookProc, - ClientData clientData); + void *clientData); /* 143 */ EXTERN int TclAddLiteralObj(struct CompileEnv *envPtr, Tcl_Obj *objPtr, LiteralEntry **litPtrPtr); @@ -415,7 +415,7 @@ const char * TclGetStartupScriptFileName(void); EXTERN int TclChannelTransform(Tcl_Interp *interp, Tcl_Channel chan, Tcl_Obj *cmdObjPtr); /* 162 */ -EXTERN void TclChannelEventScriptInvoker(ClientData clientData, +EXTERN void TclChannelEventScriptInvoker(void *clientData, int flags); /* 163 */ EXTERN const void * TclGetInstructionTable(void); @@ -584,9 +584,8 @@ void TclBackgroundException(Tcl_Interp *interp, int code); /* 237 */ EXTERN int TclResetCancellation(Tcl_Interp *interp, int force); /* 238 */ -EXTERN int TclNRInterpProc(ClientData clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); +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, @@ -678,7 +677,7 @@ typedef struct TclIntStubs { void (*tclDeleteCompiledLocalVars) (Interp *iPtr, CallFrame *framePtr); /* 11 */ void (*tclDeleteVars) (Interp *iPtr, TclVarHashTable *tablePtr); /* 12 */ void (*reserved13)(void); - int (*tclDumpMemoryInfo) (ClientData clientData, int flags); /* 14 */ + int (*tclDumpMemoryInfo) (void *clientData, int flags); /* 14 */ void (*reserved15)(void); void (*tclExprFloatError) (Tcl_Interp *interp, double value); /* 16 */ void (*reserved17)(void); @@ -717,8 +716,8 @@ typedef struct TclIntStubs { void (*tclInitCompiledLocals) (Tcl_Interp *interp, CallFrame *framePtr, Namespace *nsPtr); /* 50 */ int (*tclInterpInit) (Tcl_Interp *interp); /* 51 */ void (*reserved52)(void); - int (*tclInvokeObjectCommand) (ClientData clientData, Tcl_Interp *interp, int argc, const char **argv); /* 53 */ - int (*tclInvokeStringCommand) (ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); /* 54 */ + int (*tclInvokeObjectCommand) (void *clientData, Tcl_Interp *interp, int argc, const char **argv); /* 53 */ + int (*tclInvokeStringCommand) (void *clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); /* 54 */ Proc * (*tclIsProc) (Command *cmdPtr); /* 55 */ void (*reserved56)(void); void (*reserved57)(void); @@ -727,7 +726,7 @@ typedef struct TclIntStubs { int (*tclNeedSpace) (const char *start, const char *end); /* 60 */ Tcl_Obj * (*tclNewProcBodyObj) (Proc *procPtr); /* 61 */ int (*tclObjCommandComplete) (Tcl_Obj *cmdPtr); /* 62 */ - int (*tclObjInterpProc) (ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); /* 63 */ + int (*tclObjInterpProc) (void *clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); /* 63 */ int (*tclObjInvoke) (Tcl_Interp *interp, int objc, Tcl_Obj *const objv[], int flags); /* 64 */ void (*reserved65)(void); void (*reserved66)(void); @@ -752,12 +751,12 @@ typedef struct TclIntStubs { void (*reserved85)(void); void (*reserved86)(void); void (*reserved87)(void); - TCL_DEPRECATED_API("") char * (*tclPrecTraceProc) (ClientData clientData, Tcl_Interp *interp, const char *name1, const char *name2, int flags); /* 88 */ + TCL_DEPRECATED_API("") char * (*tclPrecTraceProc) (void *clientData, Tcl_Interp *interp, const char *name1, const char *name2, int flags); /* 88 */ int (*tclPreventAliasLoop) (Tcl_Interp *interp, Tcl_Interp *cmdInterp, Tcl_Command cmd); /* 89 */ void (*reserved90)(void); void (*tclProcCleanupProc) (Proc *procPtr); /* 91 */ int (*tclProcCompileProc) (Tcl_Interp *interp, Proc *procPtr, Tcl_Obj *bodyPtr, Namespace *nsPtr, const char *description, const char *procName); /* 92 */ - void (*tclProcDeleteProc) (ClientData clientData); /* 93 */ + void (*tclProcDeleteProc) (void *clientData); /* 93 */ void (*reserved94)(void); void (*reserved95)(void); int (*tclRenameCommand) (Tcl_Interp *interp, const char *oldName, const char *newName); /* 96 */ @@ -777,7 +776,7 @@ typedef struct TclIntStubs { int (*tclSockMinimumBuffers) (void *sock, int size); /* 110 */ void (*tcl_AddInterpResolvers) (Tcl_Interp *interp, const char *name, Tcl_ResolveCmdProc *cmdProc, Tcl_ResolveVarProc *varProc, Tcl_ResolveCompiledVarProc *compiledVarProc); /* 111 */ int (*tclAppendExportList) (Tcl_Interp *interp, Tcl_Namespace *nsPtr, Tcl_Obj *objPtr); /* 112 */ - Tcl_Namespace * (*tclCreateNamespace) (Tcl_Interp *interp, const char *name, ClientData clientData, Tcl_NamespaceDeleteProc *deleteProc); /* 113 */ + Tcl_Namespace * (*tclCreateNamespace) (Tcl_Interp *interp, const char *name, void *clientData, Tcl_NamespaceDeleteProc *deleteProc); /* 113 */ void (*tclDeleteNamespace) (Tcl_Namespace *nsPtr); /* 114 */ int (*tclExport) (Tcl_Interp *interp, Tcl_Namespace *nsPtr, const char *pattern, int resetListFirst); /* 115 */ Tcl_Command (*tclFindCommand) (Tcl_Interp *interp, const char *name, Tcl_Namespace *contextNsPtr, int flags); /* 116 */ @@ -806,7 +805,7 @@ typedef struct TclIntStubs { void (*reserved139)(void); void (*reserved140)(void); const char * (*tclpGetCwd) (Tcl_Interp *interp, Tcl_DString *cwdPtr); /* 141 */ - int (*tclSetByteCodeFromAny) (Tcl_Interp *interp, Tcl_Obj *objPtr, CompileHookProc *hookProc, ClientData clientData); /* 142 */ + int (*tclSetByteCodeFromAny) (Tcl_Interp *interp, Tcl_Obj *objPtr, CompileHookProc *hookProc, void *clientData); /* 142 */ int (*tclAddLiteralObj) (struct CompileEnv *envPtr, Tcl_Obj *objPtr, LiteralEntry **litPtrPtr); /* 143 */ void (*tclHideLiteral) (Tcl_Interp *interp, struct CompileEnv *envPtr, int index); /* 144 */ const struct AuxDataType * (*tclGetAuxDataType) (const char *typeName); /* 145 */ @@ -826,7 +825,7 @@ typedef struct TclIntStubs { TCL_DEPRECATED_API("use public Tcl_GetStartupScript()") const char * (*tclGetStartupScriptFileName) (void); /* 159 */ void (*reserved160)(void); int (*tclChannelTransform) (Tcl_Interp *interp, Tcl_Channel chan, Tcl_Obj *cmdObjPtr); /* 161 */ - void (*tclChannelEventScriptInvoker) (ClientData clientData, int flags); /* 162 */ + void (*tclChannelEventScriptInvoker) (void *clientData, int flags); /* 162 */ const void * (*tclGetInstructionTable) (void); /* 163 */ void (*tclExpandCodeArray) (void *envPtr); /* 164 */ void (*tclpSetInitialEncodings) (void); /* 165 */ @@ -902,7 +901,7 @@ typedef struct TclIntStubs { void (*tclInitVarHashTable) (TclVarHashTable *tablePtr, Namespace *nsPtr); /* 235 */ TCL_DEPRECATED_API("use Tcl_BackgroundException") void (*tclBackgroundException) (Tcl_Interp *interp, int code); /* 236 */ int (*tclResetCancellation) (Tcl_Interp *interp, int force); /* 237 */ - int (*tclNRInterpProc) (ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); /* 238 */ + int (*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 (*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 */ diff --git a/generic/tclOO.decls b/generic/tclOO.decls index e4063c7..c6ffccd 100644 --- a/generic/tclOO.decls +++ b/generic/tclOO.decls @@ -51,7 +51,7 @@ declare 8 { } declare 9 { int Tcl_MethodIsType(Tcl_Method method, const Tcl_MethodType *typePtr, - ClientData *clientDataPtr) + void **clientDataPtr) } declare 10 { Tcl_Obj *Tcl_MethodName(Tcl_Method method) @@ -59,12 +59,12 @@ declare 10 { declare 11 { Tcl_Method Tcl_NewInstanceMethod(Tcl_Interp *interp, Tcl_Object object, Tcl_Obj *nameObj, int flags, const Tcl_MethodType *typePtr, - ClientData clientData) + void *clientData) } declare 12 { Tcl_Method Tcl_NewMethod(Tcl_Interp *interp, Tcl_Class cls, Tcl_Obj *nameObj, int flags, const Tcl_MethodType *typePtr, - ClientData clientData) + void *clientData) } declare 13 { Tcl_Object Tcl_NewObjectInstance(Tcl_Interp *interp, Tcl_Class cls, @@ -87,20 +87,20 @@ declare 18 { int Tcl_ObjectContextSkippedArgs(Tcl_ObjectContext context) } declare 19 { - ClientData Tcl_ClassGetMetadata(Tcl_Class clazz, + void *Tcl_ClassGetMetadata(Tcl_Class clazz, const Tcl_ObjectMetadataType *typePtr) } declare 20 { void Tcl_ClassSetMetadata(Tcl_Class clazz, - const Tcl_ObjectMetadataType *typePtr, ClientData metadata) + const Tcl_ObjectMetadataType *typePtr, void *metadata) } declare 21 { - ClientData Tcl_ObjectGetMetadata(Tcl_Object object, + void *Tcl_ObjectGetMetadata(Tcl_Object object, const Tcl_ObjectMetadataType *typePtr) } declare 22 { void Tcl_ObjectSetMetadata(Tcl_Object object, - const Tcl_ObjectMetadataType *typePtr, ClientData metadata) + const Tcl_ObjectMetadataType *typePtr, void *metadata) } declare 23 { int Tcl_ObjectContextInvokeNext(Tcl_Interp *interp, @@ -150,14 +150,14 @@ declare 0 { declare 1 { Tcl_Method TclOOMakeProcInstanceMethod(Tcl_Interp *interp, Object *oPtr, int flags, Tcl_Obj *nameObj, Tcl_Obj *argsObj, Tcl_Obj *bodyObj, - const Tcl_MethodType *typePtr, ClientData clientData, + const Tcl_MethodType *typePtr, void *clientData, Proc **procPtrPtr) } declare 2 { 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, - ClientData clientData, Proc **procPtrPtr) + void *clientData, Proc **procPtrPtr) } declare 3 { Method *TclOONewProcInstanceMethod(Tcl_Interp *interp, Object *oPtr, @@ -188,13 +188,13 @@ declare 9 { Tcl_Method TclOONewProcInstanceMethodEx(Tcl_Interp *interp, Tcl_Object oPtr, TclOO_PreCallProc *preCallPtr, TclOO_PostCallProc *postCallPtr, ProcErrorProc *errProc, - ClientData clientData, Tcl_Obj *nameObj, Tcl_Obj *argsObj, + void *clientData, Tcl_Obj *nameObj, Tcl_Obj *argsObj, Tcl_Obj *bodyObj, int flags, void **internalTokenPtr) } declare 10 { Tcl_Method TclOONewProcMethodEx(Tcl_Interp *interp, Tcl_Class clsPtr, TclOO_PreCallProc *preCallPtr, TclOO_PostCallProc *postCallPtr, - ProcErrorProc *errProc, ClientData clientData, Tcl_Obj *nameObj, + ProcErrorProc *errProc, void *clientData, Tcl_Obj *nameObj, Tcl_Obj *argsObj, Tcl_Obj *bodyObj, int flags, void **internalTokenPtr) } diff --git a/generic/tclOODecls.h b/generic/tclOODecls.h index 3be1e3d..6ba5d14 100644 --- a/generic/tclOODecls.h +++ b/generic/tclOODecls.h @@ -53,19 +53,19 @@ TCLAPI int Tcl_MethodIsPublic(Tcl_Method method); /* 9 */ TCLAPI int Tcl_MethodIsType(Tcl_Method method, const Tcl_MethodType *typePtr, - ClientData *clientDataPtr); + void **clientDataPtr); /* 10 */ TCLAPI Tcl_Obj * Tcl_MethodName(Tcl_Method method); /* 11 */ TCLAPI Tcl_Method Tcl_NewInstanceMethod(Tcl_Interp *interp, Tcl_Object object, Tcl_Obj *nameObj, int flags, const Tcl_MethodType *typePtr, - ClientData clientData); + void *clientData); /* 12 */ TCLAPI Tcl_Method Tcl_NewMethod(Tcl_Interp *interp, Tcl_Class cls, Tcl_Obj *nameObj, int flags, const Tcl_MethodType *typePtr, - ClientData clientData); + void *clientData); /* 13 */ TCLAPI Tcl_Object Tcl_NewObjectInstance(Tcl_Interp *interp, Tcl_Class cls, const char *nameStr, @@ -84,19 +84,19 @@ TCLAPI Tcl_Object Tcl_ObjectContextObject(Tcl_ObjectContext context); TCLAPI int Tcl_ObjectContextSkippedArgs( Tcl_ObjectContext context); /* 19 */ -TCLAPI ClientData Tcl_ClassGetMetadata(Tcl_Class clazz, +TCLAPI void * Tcl_ClassGetMetadata(Tcl_Class clazz, const Tcl_ObjectMetadataType *typePtr); /* 20 */ TCLAPI void Tcl_ClassSetMetadata(Tcl_Class clazz, const Tcl_ObjectMetadataType *typePtr, - ClientData metadata); + void *metadata); /* 21 */ -TCLAPI ClientData Tcl_ObjectGetMetadata(Tcl_Object object, +TCLAPI void * Tcl_ObjectGetMetadata(Tcl_Object object, const Tcl_ObjectMetadataType *typePtr); /* 22 */ TCLAPI void Tcl_ObjectSetMetadata(Tcl_Object object, const Tcl_ObjectMetadataType *typePtr, - ClientData metadata); + void *metadata); /* 23 */ TCLAPI int Tcl_ObjectContextInvokeNext(Tcl_Interp *interp, Tcl_ObjectContext context, int objc, @@ -141,20 +141,20 @@ typedef struct TclOOStubs { Tcl_Class (*tcl_MethodDeclarerClass) (Tcl_Method method); /* 6 */ Tcl_Object (*tcl_MethodDeclarerObject) (Tcl_Method method); /* 7 */ int (*tcl_MethodIsPublic) (Tcl_Method method); /* 8 */ - int (*tcl_MethodIsType) (Tcl_Method method, const Tcl_MethodType *typePtr, ClientData *clientDataPtr); /* 9 */ + int (*tcl_MethodIsType) (Tcl_Method method, const Tcl_MethodType *typePtr, void **clientDataPtr); /* 9 */ 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, ClientData clientData); /* 11 */ - Tcl_Method (*tcl_NewMethod) (Tcl_Interp *interp, Tcl_Class cls, Tcl_Obj *nameObj, int flags, const Tcl_MethodType *typePtr, ClientData clientData); /* 12 */ + 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 */ int (*tcl_ObjectDeleted) (Tcl_Object object); /* 14 */ 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 */ - ClientData (*tcl_ClassGetMetadata) (Tcl_Class clazz, const Tcl_ObjectMetadataType *typePtr); /* 19 */ - void (*tcl_ClassSetMetadata) (Tcl_Class clazz, const Tcl_ObjectMetadataType *typePtr, ClientData metadata); /* 20 */ - ClientData (*tcl_ObjectGetMetadata) (Tcl_Object object, const Tcl_ObjectMetadataType *typePtr); /* 21 */ - void (*tcl_ObjectSetMetadata) (Tcl_Object object, const Tcl_ObjectMetadataType *typePtr, ClientData metadata); /* 22 */ + 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 */ + 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 */ Tcl_ObjectMapMethodNameProc * (*tcl_ObjectGetMethodNameMapper) (Tcl_Object object); /* 24 */ void (*tcl_ObjectSetMethodNameMapper) (Tcl_Object object, Tcl_ObjectMapMethodNameProc *mapMethodNameProc); /* 25 */ diff --git a/generic/tclOOIntDecls.h b/generic/tclOOIntDecls.h index 74a8d81..6a5cfd3 100644 --- a/generic/tclOOIntDecls.h +++ b/generic/tclOOIntDecls.h @@ -22,14 +22,14 @@ TCLAPI Tcl_Method TclOOMakeProcInstanceMethod(Tcl_Interp *interp, Object *oPtr, int flags, Tcl_Obj *nameObj, Tcl_Obj *argsObj, Tcl_Obj *bodyObj, const Tcl_MethodType *typePtr, - ClientData clientData, Proc **procPtrPtr); + void *clientData, Proc **procPtrPtr); /* 2 */ TCLAPI 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, - ClientData clientData, Proc **procPtrPtr); + void *clientData, Proc **procPtrPtr); /* 3 */ TCLAPI Method * TclOONewProcInstanceMethod(Tcl_Interp *interp, Object *oPtr, int flags, Tcl_Obj *nameObj, @@ -59,19 +59,19 @@ TCLAPI Tcl_Method TclOONewProcInstanceMethodEx(Tcl_Interp *interp, Tcl_Object oPtr, TclOO_PreCallProc *preCallPtr, TclOO_PostCallProc *postCallPtr, - ProcErrorProc *errProc, - ClientData clientData, Tcl_Obj *nameObj, - Tcl_Obj *argsObj, Tcl_Obj *bodyObj, - int flags, void **internalTokenPtr); + ProcErrorProc *errProc, void *clientData, + Tcl_Obj *nameObj, Tcl_Obj *argsObj, + Tcl_Obj *bodyObj, int flags, + void **internalTokenPtr); /* 10 */ TCLAPI Tcl_Method TclOONewProcMethodEx(Tcl_Interp *interp, Tcl_Class clsPtr, TclOO_PreCallProc *preCallPtr, TclOO_PostCallProc *postCallPtr, - ProcErrorProc *errProc, - ClientData clientData, Tcl_Obj *nameObj, - Tcl_Obj *argsObj, Tcl_Obj *bodyObj, - int flags, void **internalTokenPtr); + ProcErrorProc *errProc, void *clientData, + Tcl_Obj *nameObj, Tcl_Obj *argsObj, + Tcl_Obj *bodyObj, int flags, + void **internalTokenPtr); /* 11 */ TCLAPI int TclOOInvokeObject(Tcl_Interp *interp, Tcl_Object object, Tcl_Class startCls, @@ -97,16 +97,16 @@ typedef struct TclOOIntStubs { void *hooks; Tcl_Object (*tclOOGetDefineCmdContext) (Tcl_Interp *interp); /* 0 */ - Tcl_Method (*tclOOMakeProcInstanceMethod) (Tcl_Interp *interp, Object *oPtr, int flags, Tcl_Obj *nameObj, Tcl_Obj *argsObj, Tcl_Obj *bodyObj, const Tcl_MethodType *typePtr, ClientData clientData, Proc **procPtrPtr); /* 1 */ - 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, ClientData clientData, Proc **procPtrPtr); /* 2 */ + Tcl_Method (*tclOOMakeProcInstanceMethod) (Tcl_Interp *interp, Object *oPtr, int flags, Tcl_Obj *nameObj, Tcl_Obj *argsObj, Tcl_Obj *bodyObj, const Tcl_MethodType *typePtr, void *clientData, Proc **procPtrPtr); /* 1 */ + 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 (*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, ClientData 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, ClientData clientData, Tcl_Obj *nameObj, Tcl_Obj *argsObj, Tcl_Obj *bodyObj, int flags, void **internalTokenPtr); /* 10 */ + 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 */ 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 */ -- cgit v0.12 From 84e0e40683b23f57e307b5deac6e05ba58852181 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 23 Jun 2022 12:21:13 +0000 Subject: Remove unused typedef's --- generic/tcl.h | 8 -------- 1 file changed, 8 deletions(-) diff --git a/generic/tcl.h b/generic/tcl.h index 274be35..61b0c48 100644 --- a/generic/tcl.h +++ b/generic/tcl.h @@ -578,14 +578,6 @@ typedef struct Tcl_RegExpInfo { } Tcl_RegExpInfo; /* - * Picky compilers complain if this typdef doesn't appear before the struct's - * reference in tclDecls.h. - */ - -typedef Tcl_StatBuf *Tcl_Stat_; -typedef struct stat *Tcl_OldStat_; - -/* *---------------------------------------------------------------------------- * When a TCL command returns, the interpreter contains a result from the * command. Programmers are strongly encouraged to use one of the functions -- cgit v0.12 From a96dae7f0f22970833799aa44043355ece05f3d4 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 23 Jun 2022 12:57:09 +0000 Subject: Slightly better integer overflow handling in Tcl_ListObjReplace() --- generic/tclListObj.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/generic/tclListObj.c b/generic/tclListObj.c index 9bc4e47..88a332f 100644 --- a/generic/tclListObj.c +++ b/generic/tclListObj.c @@ -889,7 +889,7 @@ Tcl_ListObjReplace( } if (count < 0) { count = 0; - } else if (first > INT_MAX - count /* Handle integer overflow */ + } else if (count > LIST_MAX /* Handle integer overflow */ || numElems < first+count) { count = numElems - first; -- cgit v0.12 From 65cf5b39664345503c534418c57505e118a9b3a8 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 23 Jun 2022 14:57:28 +0000 Subject: Restore NS_DEAD flag value (from 0x04 back to 0x02, how it was in Tcl 8.6). It is used in nsf, changing the value in Tcl 8.7 would mean a binary incompatibility. --- generic/tclInt.h | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/generic/tclInt.h b/generic/tclInt.h index 294ff97..72107ef 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -423,8 +423,9 @@ struct NamespacePathEntry { */ #define NS_DYING 0x01 -#define NS_TEARDOWN 0x02 -#define NS_DEAD 0x04 +#define NS_DEAD 0x02 +#define NS_TEARDOWN 0x04 +#define NS_KILLED 0x04 /* Same as NS_TEARDOWN (Deprecated) */ #define NS_SUPPRESS_COMPILATION 0x08 /* -- cgit v0.12 From f527a3f4568093147bf17db414cc0340bbac5045 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 23 Jun 2022 15:33:48 +0000 Subject: more "unsigned int" -> TCL_HASH_TYPE --- generic/tcl.h | 2 +- generic/tclCompile.h | 16 ++++++++-------- generic/tclInt.h | 50 +++++++++++++++++++++++++------------------------- 3 files changed, 34 insertions(+), 34 deletions(-) diff --git a/generic/tcl.h b/generic/tcl.h index 61b0c48..94c236a 100644 --- a/generic/tcl.h +++ b/generic/tcl.h @@ -1291,7 +1291,7 @@ typedef struct Tcl_HashSearch { typedef struct { void *next; /* Search position for underlying hash * table. */ - unsigned int epoch; /* Epoch marker for dictionary being searched, + TCL_HASH_TYPE epoch; /* Epoch marker for dictionary being searched, * or 0 if search has terminated. */ Tcl_Dict dictionaryPtr; /* Reference to dictionary being searched. */ } Tcl_DictSearch; diff --git a/generic/tclCompile.h b/generic/tclCompile.h index ae30c19..1f40d46 100644 --- a/generic/tclCompile.h +++ b/generic/tclCompile.h @@ -135,7 +135,7 @@ typedef struct ExceptionAux { int numBreakTargets; /* The number of [break]s that want to be * targeted to the place where this loop * exception will be bound to. */ - unsigned int *breakTargets; /* The offsets of the INST_JUMP4 instructions + TCL_HASH_TYPE *breakTargets; /* The offsets of the INST_JUMP4 instructions * issued by the [break]s that we must * update. Note that resizing a jump (via * TclFixupForwardJump) can cause the contents @@ -145,7 +145,7 @@ typedef struct ExceptionAux { int numContinueTargets; /* The number of [continue]s that want to be * targeted to the place where this loop * exception will be bound to. */ - unsigned int *continueTargets; /* The offsets of the INST_JUMP4 instructions + TCL_HASH_TYPE *continueTargets; /* The offsets of the INST_JUMP4 instructions * issued by the [continue]s that we must * update. Note that resizing a jump (via * TclFixupForwardJump) can cause the contents @@ -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); + TCL_HASH_TYPE pcOffset); /* * We define a separate AuxDataType struct to hold type-related information @@ -417,7 +417,7 @@ typedef struct ByteCode { * procs are specific to an interpreter so the * code emitted will depend on the * interpreter. */ - unsigned int compileEpoch; /* Value of iPtr->compileEpoch when this + TCL_HASH_TYPE compileEpoch; /* Value of iPtr->compileEpoch when this * ByteCode was compiled. Used to invalidate * code when, e.g., commands with compile * procs are redefined. */ @@ -425,11 +425,11 @@ typedef struct ByteCode { * compiled. If the code is executed if a * different namespace, it must be * recompiled. */ - unsigned int nsEpoch; /* Value of nsPtr->resolverEpoch when this + TCL_HASH_TYPE nsEpoch; /* Value of nsPtr->resolverEpoch when this * ByteCode was compiled. Used to invalidate * code when new namespace resolution rules * are put into effect. */ - unsigned int refCount; /* Reference count: set 1 when created plus 1 + TCL_HASH_TYPE refCount; /* Reference count: set 1 when created plus 1 * for each execution of the code currently * active. This structure can be freed when * refCount becomes zero. */ @@ -1124,7 +1124,7 @@ MODULE_SCOPE int TclCreateExceptRange(ExceptionRangeType type, CompileEnv *envPtr); MODULE_SCOPE ExecEnv * TclCreateExecEnv(Tcl_Interp *interp, int size); MODULE_SCOPE Tcl_Obj * TclCreateLiteral(Interp *iPtr, const char *bytes, - int length, unsigned int hash, int *newPtr, + int length, TCL_HASH_TYPE hash, int *newPtr, Namespace *nsPtr, int flags, LiteralEntry **globalPtrPtr); MODULE_SCOPE void TclDeleteExecEnv(ExecEnv *eePtr); @@ -1138,7 +1138,7 @@ MODULE_SCOPE ExceptionRange * TclGetExceptionRangeForPc(unsigned char *pc, MODULE_SCOPE void TclExpandJumpFixupArray(JumpFixupArray *fixupArrayPtr); MODULE_SCOPE int TclNRExecuteByteCode(Tcl_Interp *interp, ByteCode *codePtr); -MODULE_SCOPE Tcl_Obj * TclFetchLiteral(CompileEnv *envPtr, unsigned int index); +MODULE_SCOPE Tcl_Obj * TclFetchLiteral(CompileEnv *envPtr, TCL_HASH_TYPE index); MODULE_SCOPE int TclFindCompiledLocal(const char *name, int nameChars, int create, CompileEnv *envPtr); MODULE_SCOPE int TclFixupForwardJump(CompileEnv *envPtr, diff --git a/generic/tclInt.h b/generic/tclInt.h index 72107ef..7425123 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -298,7 +298,7 @@ typedef struct Namespace { * frames for this namespace that are on the * Tcl call stack. The namespace won't be * freed until activationCount becomes zero. */ - unsigned int refCount; /* Count of references by namespaceName + TCL_HASH_TYPE refCount; /* Count of references by namespaceName * objects. The namespace can't be freed until * refCount becomes zero. */ Tcl_HashTable cmdTable; /* Contains all the commands currently @@ -323,12 +323,12 @@ typedef struct Namespace { * registered using "namespace export". */ int maxExportPatterns; /* Mumber of export patterns for which space * is currently allocated. */ - unsigned int cmdRefEpoch; /* Incremented if a newly added command + TCL_HASH_TYPE cmdRefEpoch; /* Incremented if a newly added command * shadows a command for which this namespace * has already cached a Command* pointer; this * causes all its cached Command* pointers to * be invalidated. */ - unsigned int resolverEpoch; /* Incremented whenever (a) the name + TCL_HASH_TYPE resolverEpoch; /* Incremented whenever (a) the name * resolution rules change for this namespace * or (b) a newly added command shadows a * command that is compiled to bytecodes. This @@ -355,7 +355,7 @@ typedef struct Namespace { * LookupCompiledLocal to resolve variable * references within the namespace at compile * time. */ - unsigned int exportLookupEpoch; /* Incremented whenever a command is added to + TCL_HASH_TYPE exportLookupEpoch; /* Incremented whenever a command is added to * a namespace, removed from a namespace or * the exports of a namespace are changed. * Allows TIP#112-driven command lists to be @@ -455,7 +455,7 @@ typedef struct EnsembleConfig { * if the command has been deleted (or never * existed; the global namespace never has an * ensemble command.) */ - unsigned int epoch; /* The epoch at which this ensemble's table of + TCL_HASH_TYPE epoch; /* The epoch at which this ensemble's table of * exported commands is valid. */ char **subcommandArrayPtr; /* Array of ensemble subcommand names. At all * consistent points, this will have the same @@ -568,7 +568,7 @@ typedef struct CommandTrace { struct CommandTrace *nextPtr; /* Next in list of traces associated with a * particular command. */ - unsigned int refCount; /* Used to ensure this structure is not + TCL_HASH_TYPE refCount; /* Used to ensure this structure is not * deleted too early. Keeps track of how many * pieces of code have a pointer to this * structure. */ @@ -641,7 +641,7 @@ typedef struct Var { typedef struct VarInHash { Var var; - unsigned int refCount; /* Counts number of active uses of this + TCL_HASH_TYPE refCount; /* Counts number of active uses of this * variable: 1 for the entry in the hash * table, 1 for each additional variable whose * linkPtr points here, 1 for each nested @@ -978,7 +978,7 @@ typedef struct CompiledLocal { typedef struct Proc { struct Interp *iPtr; /* Interpreter for which this command is * defined. */ - unsigned int refCount; /* Reference count: 1 if still present in + TCL_HASH_TYPE refCount; /* Reference count: 1 if still present in * command table plus 1 for each call to the * procedure that is currently active. This * structure can be freed when refCount @@ -1095,7 +1095,7 @@ typedef struct AssocData { */ typedef struct LocalCache { - unsigned int refCount; + TCL_HASH_TYPE refCount; int numVars; Tcl_Obj *varName0; } LocalCache; @@ -1261,7 +1261,7 @@ typedef struct CmdFrame { typedef struct CFWord { CmdFrame *framePtr; /* CmdFrame to access. */ int word; /* Index of the word in the command. */ - unsigned int refCount; /* Number of times the word is on the + TCL_HASH_TYPE refCount; /* Number of times the word is on the * stack. */ } CFWord; @@ -1529,7 +1529,7 @@ typedef struct LiteralEntry { * NULL if end of chain. */ Tcl_Obj *objPtr; /* Points to Tcl object that holds the * literal's bytes and length. */ - unsigned int refCount; /* If in an interpreter's global literal + TCL_HASH_TYPE refCount; /* If in an interpreter's global literal * table, the number of ByteCode structures * that share the literal object; the literal * entry can be freed when refCount drops to @@ -1547,13 +1547,13 @@ typedef struct LiteralTable { LiteralEntry *staticBuckets[TCL_SMALL_HASH_TABLE]; /* Bucket array used for small tables to avoid * mallocs and frees. */ - unsigned int numBuckets; /* Total number of buckets allocated at + TCL_HASH_TYPE numBuckets; /* Total number of buckets allocated at * **buckets. */ - unsigned int numEntries; /* Total number of entries present in + TCL_HASH_TYPE numEntries; /* Total number of entries present in * table. */ - unsigned int rebuildSize; /* Enlarge table when numEntries gets to be + TCL_HASH_TYPE rebuildSize; /* Enlarge table when numEntries gets to be * this large. */ - unsigned int mask; /* Mask value used in hashing function. */ + TCL_HASH_TYPE mask; /* Mask value used in hashing function. */ } LiteralTable; /* @@ -1671,12 +1671,12 @@ typedef struct Command { * recreated). */ Namespace *nsPtr; /* Points to the namespace containing this * command. */ - unsigned int refCount; /* 1 if in command hashtable plus 1 for each + TCL_HASH_TYPE refCount; /* 1 if in command hashtable plus 1 for each * reference from a CmdName Tcl object * representing a command's name in a ByteCode * instruction sequence. This structure can be * freed when refCount becomes zero. */ - unsigned int cmdEpoch; /* Incremented to invalidate any references + TCL_HASH_TYPE cmdEpoch; /* Incremented to invalidate any references * that point to this command when it is * renamed, deleted, hidden, or exposed. */ CompileProc *compileProc; /* Procedure called to compile command. NULL @@ -1942,7 +1942,7 @@ typedef struct Interp { * compiled by the interpreter. Indexed by the * string representations of literals. Used to * avoid creating duplicate objects. */ - unsigned int compileEpoch; /* Holds the current "compilation epoch" for + TCL_HASH_TYPE compileEpoch; /* Holds the current "compilation epoch" for * this interpreter. This is incremented to * invalidate existing ByteCodes when, e.g., a * command with a compile procedure is @@ -2432,7 +2432,7 @@ typedef enum TclEolTranslation { */ typedef struct List { - unsigned int refCount; + TCL_HASH_TYPE refCount; int maxElemCount; /* Total number of element array slots. */ int elemCount; /* Current number of list elements. */ int canonicalFlag; /* Set if the string representation was @@ -2656,7 +2656,7 @@ typedef Tcl_ObjCmdProc *TclObjCmdProcType; *---------------------------------------------------------------- */ -typedef void (TclInitProcessGlobalValueProc)(char **valuePtr, unsigned int *lengthPtr, +typedef void (TclInitProcessGlobalValueProc)(char **valuePtr, TCL_HASH_TYPE *lengthPtr, Tcl_Encoding *encodingPtr); /* @@ -2668,9 +2668,9 @@ typedef void (TclInitProcessGlobalValueProc)(char **valuePtr, unsigned int *leng */ typedef struct ProcessGlobalValue { - unsigned int epoch; /* Epoch counter to detect changes in the + TCL_HASH_TYPE epoch; /* Epoch counter to detect changes in the * global value. */ - unsigned int numBytes; /* Length of the global string. */ + TCL_HASH_TYPE numBytes; /* Length of the global string. */ char *value; /* The global string value. */ Tcl_Encoding encoding; /* system encoding when global string was * initialized. */ @@ -3043,7 +3043,7 @@ MODULE_SCOPE Tcl_Obj * TclGetProcessGlobalValue(ProcessGlobalValue *pgvPtr); MODULE_SCOPE Tcl_Obj * TclGetSourceFromFrame(CmdFrame *cfPtr, int objc, Tcl_Obj *const objv[]); MODULE_SCOPE char * TclGetStringStorage(Tcl_Obj *objPtr, - unsigned int *sizePtr); + TCL_HASH_TYPE *sizePtr); MODULE_SCOPE int TclGetLoadedLibraries(Tcl_Interp *interp, const char *targetName, const char *packageName); @@ -3160,7 +3160,7 @@ MODULE_SCOPE int TclpThreadCreate(Tcl_ThreadId *idPtr, int stackSize, int flags); MODULE_SCOPE int TclpFindVariable(const char *name, int *lengthPtr); MODULE_SCOPE void TclpInitLibraryPath(char **valuePtr, - unsigned int *lengthPtr, Tcl_Encoding *encodingPtr); + TCL_HASH_TYPE *lengthPtr, Tcl_Encoding *encodingPtr); MODULE_SCOPE void TclpInitLock(void); MODULE_SCOPE ClientData TclpInitNotifier(void); MODULE_SCOPE void TclpInitPlatform(void); @@ -4541,7 +4541,7 @@ MODULE_SCOPE void TclDbInitNewObj(Tcl_Obj *objPtr, const char *file, (objPtr)->bytes = &tclEmptyString; \ (objPtr)->length = 0; \ } else { \ - (objPtr)->bytes = (char *)ckalloc((unsigned int)(len) + 1U); \ + (objPtr)->bytes = (char *)ckalloc((len) + 1U); \ memcpy((objPtr)->bytes, (bytePtr) ? (bytePtr) : &tclEmptyString, (len)); \ (objPtr)->bytes[len] = '\0'; \ (objPtr)->length = (len); \ -- cgit v0.12 From 5bad06a9a453a043661695e582ef7c9f7f3647fc Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 24 Jun 2022 07:11:17 +0000 Subject: Don't use (unsigned)-1 -> TCL_INDEX_NONE --- generic/tclInt.h | 4 ++-- generic/tclLiteral.c | 8 ++++---- 2 files changed, 6 insertions(+), 6 deletions(-) diff --git a/generic/tclInt.h b/generic/tclInt.h index 7425123..f5628f7 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -1529,11 +1529,11 @@ typedef struct LiteralEntry { * NULL if end of chain. */ Tcl_Obj *objPtr; /* Points to Tcl object that holds the * literal's bytes and length. */ - TCL_HASH_TYPE refCount; /* If in an interpreter's global literal + int refCount; /* If in an interpreter's global literal * table, the number of ByteCode structures * that share the literal object; the literal * entry can be freed when refCount drops to - * 0. If in a local literal table, (unsigned)-1. */ + * 0. If in a local literal table, TCL_INDEX_NONE. */ Namespace *nsPtr; /* Namespace in which this literal is used. We * try to avoid sharing literal non-FQ command * names among different namespaces to reduce diff --git a/generic/tclLiteral.c b/generic/tclLiteral.c index e1943a1..0c2c545 100644 --- a/generic/tclLiteral.c +++ b/generic/tclLiteral.c @@ -229,7 +229,7 @@ TclCreateLiteral( if (flags & LITERAL_ON_HEAP) { ckfree(bytes); } - if (globalPtr->refCount != (unsigned) -1) { + if (globalPtr->refCount != TCL_INDEX_NONE) { globalPtr->refCount++; } return objPtr; @@ -630,7 +630,7 @@ TclAddLiteralObj( lPtr = &envPtr->literalArrayPtr[objIndex]; lPtr->objPtr = objPtr; Tcl_IncrRefCount(objPtr); - lPtr->refCount = (unsigned) -1; /* i.e., unused */ + lPtr->refCount = TCL_INDEX_NONE; /* i.e., unused */ lPtr->nextPtr = NULL; if (litPtrPtr) { @@ -854,7 +854,7 @@ TclReleaseLiteral( * literal table entry (decrement the ref count of the object). */ - if ((entryPtr->refCount != (unsigned)-1) && (entryPtr->refCount-- <= 1)) { + if ((entryPtr->refCount != TCL_INDEX_NONE) && (entryPtr->refCount-- <= 1)) { if (prevPtr == NULL) { globalTablePtr->buckets[index] = entryPtr->nextPtr; } else { @@ -1183,7 +1183,7 @@ TclVerifyLocalLiteralTable( for (localPtr=localTablePtr->buckets[i] ; localPtr!=NULL; localPtr=localPtr->nextPtr) { count++; - if (localPtr->refCount != (unsigned)-1) { + if (localPtr->refCount != TCL_INDEX_NONE) { bytes = TclGetStringFromObj(localPtr->objPtr, &length); Tcl_Panic("%s: local literal \"%.*s\" had bad refCount %u", "TclVerifyLocalLiteralTable", -- cgit v0.12 From a769ee494cca67958b20b1472a4d61b8d5e8a0fb Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 24 Jun 2022 07:12:32 +0000 Subject: Put back seemingly useless typedefs (yes, there are picky compilers) --- generic/tcl.h | 8 ++++++++ 1 file changed, 8 insertions(+) diff --git a/generic/tcl.h b/generic/tcl.h index 94c236a..3b9d483 100644 --- a/generic/tcl.h +++ b/generic/tcl.h @@ -578,6 +578,14 @@ typedef struct Tcl_RegExpInfo { } Tcl_RegExpInfo; /* + * Picky compilers complain if this typdef doesn't appear before the struct's + * reference in tclDecls.h. + */ + +typedef Tcl_StatBuf *Tcl_Stat_; +typedef struct stat *Tcl_OldStat_; + +/* *---------------------------------------------------------------------------- * When a TCL command returns, the interpreter contains a result from the * command. Programmers are strongly encouraged to use one of the functions -- cgit v0.12 From 9c5e4541411287c33ae6727b22ec18fec6cd04fa Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 24 Jun 2022 10:41:14 +0000 Subject: Don't use TCL_HASH_TYPE for epoch/refCount type variables, keep it the same as it was in Tcl 8.6 --- generic/tclBasic.c | 2 +- generic/tclCompile.h | 6 +++--- generic/tclEnsemble.c | 2 +- generic/tclInt.h | 36 ++++++++++++++++++------------------ generic/tclObj.c | 4 ++-- generic/tclUtil.c | 2 +- generic/tclVar.c | 6 ++---- 7 files changed, 28 insertions(+), 30 deletions(-) diff --git a/generic/tclBasic.c b/generic/tclBasic.c index a78a768..5f32e7d 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -5274,7 +5274,7 @@ TEOV_RunEnterTraces( { Interp *iPtr = (Interp *) interp; Command *cmdPtr = *cmdPtrPtr; - unsigned int newEpoch, cmdEpoch = cmdPtr->cmdEpoch; + int newEpoch, cmdEpoch = cmdPtr->cmdEpoch; int length, traceCode = TCL_OK; const char *command = TclGetStringFromObj(commandPtr, &length); diff --git a/generic/tclCompile.h b/generic/tclCompile.h index 1f40d46..c7c17f3 100644 --- a/generic/tclCompile.h +++ b/generic/tclCompile.h @@ -417,7 +417,7 @@ typedef struct ByteCode { * procs are specific to an interpreter so the * code emitted will depend on the * interpreter. */ - TCL_HASH_TYPE compileEpoch; /* Value of iPtr->compileEpoch when this + int compileEpoch; /* Value of iPtr->compileEpoch when this * ByteCode was compiled. Used to invalidate * code when, e.g., commands with compile * procs are redefined. */ @@ -425,11 +425,11 @@ typedef struct ByteCode { * compiled. If the code is executed if a * different namespace, it must be * recompiled. */ - TCL_HASH_TYPE nsEpoch; /* Value of nsPtr->resolverEpoch when this + int nsEpoch; /* Value of nsPtr->resolverEpoch when this * ByteCode was compiled. Used to invalidate * code when new namespace resolution rules * are put into effect. */ - TCL_HASH_TYPE refCount; /* Reference count: set 1 when created plus 1 + int refCount; /* Reference count: set 1 when created plus 1 * for each execution of the code currently * active. This structure can be freed when * refCount becomes zero. */ diff --git a/generic/tclEnsemble.c b/generic/tclEnsemble.c index 6c82c6a..5c30a0b 100644 --- a/generic/tclEnsemble.c +++ b/generic/tclEnsemble.c @@ -105,7 +105,7 @@ static const Tcl_ObjType ensembleCmdType = { */ typedef struct { - unsigned int epoch; /* Used to confirm when the data in this + int epoch; /* Used to confirm when the data in this * really structure matches up with the * ensemble. */ Command *token; /* Reference to the command for which this diff --git a/generic/tclInt.h b/generic/tclInt.h index f5628f7..1a504f4 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -298,7 +298,7 @@ typedef struct Namespace { * frames for this namespace that are on the * Tcl call stack. The namespace won't be * freed until activationCount becomes zero. */ - TCL_HASH_TYPE refCount; /* Count of references by namespaceName + int refCount; /* Count of references by namespaceName * objects. The namespace can't be freed until * refCount becomes zero. */ Tcl_HashTable cmdTable; /* Contains all the commands currently @@ -323,12 +323,12 @@ typedef struct Namespace { * registered using "namespace export". */ int maxExportPatterns; /* Mumber of export patterns for which space * is currently allocated. */ - TCL_HASH_TYPE cmdRefEpoch; /* Incremented if a newly added command + int cmdRefEpoch; /* Incremented if a newly added command * shadows a command for which this namespace * has already cached a Command* pointer; this * causes all its cached Command* pointers to * be invalidated. */ - TCL_HASH_TYPE resolverEpoch; /* Incremented whenever (a) the name + int resolverEpoch; /* Incremented whenever (a) the name * resolution rules change for this namespace * or (b) a newly added command shadows a * command that is compiled to bytecodes. This @@ -355,7 +355,7 @@ typedef struct Namespace { * LookupCompiledLocal to resolve variable * references within the namespace at compile * time. */ - TCL_HASH_TYPE exportLookupEpoch; /* Incremented whenever a command is added to + int exportLookupEpoch; /* Incremented whenever a command is added to * a namespace, removed from a namespace or * the exports of a namespace are changed. * Allows TIP#112-driven command lists to be @@ -455,7 +455,7 @@ typedef struct EnsembleConfig { * if the command has been deleted (or never * existed; the global namespace never has an * ensemble command.) */ - TCL_HASH_TYPE epoch; /* The epoch at which this ensemble's table of + int epoch; /* The epoch at which this ensemble's table of * exported commands is valid. */ char **subcommandArrayPtr; /* Array of ensemble subcommand names. At all * consistent points, this will have the same @@ -568,7 +568,7 @@ typedef struct CommandTrace { struct CommandTrace *nextPtr; /* Next in list of traces associated with a * particular command. */ - TCL_HASH_TYPE refCount; /* Used to ensure this structure is not + int refCount; /* Used to ensure this structure is not * deleted too early. Keeps track of how many * pieces of code have a pointer to this * structure. */ @@ -641,7 +641,7 @@ typedef struct Var { typedef struct VarInHash { Var var; - TCL_HASH_TYPE refCount; /* Counts number of active uses of this + int refCount; /* Counts number of active uses of this * variable: 1 for the entry in the hash * table, 1 for each additional variable whose * linkPtr points here, 1 for each nested @@ -978,7 +978,7 @@ typedef struct CompiledLocal { typedef struct Proc { struct Interp *iPtr; /* Interpreter for which this command is * defined. */ - TCL_HASH_TYPE refCount; /* Reference count: 1 if still present in + int refCount; /* Reference count: 1 if still present in * command table plus 1 for each call to the * procedure that is currently active. This * structure can be freed when refCount @@ -1095,7 +1095,7 @@ typedef struct AssocData { */ typedef struct LocalCache { - TCL_HASH_TYPE refCount; + int refCount; int numVars; Tcl_Obj *varName0; } LocalCache; @@ -1261,7 +1261,7 @@ typedef struct CmdFrame { typedef struct CFWord { CmdFrame *framePtr; /* CmdFrame to access. */ int word; /* Index of the word in the command. */ - TCL_HASH_TYPE refCount; /* Number of times the word is on the + int refCount; /* Number of times the word is on the * stack. */ } CFWord; @@ -1529,7 +1529,7 @@ typedef struct LiteralEntry { * NULL if end of chain. */ Tcl_Obj *objPtr; /* Points to Tcl object that holds the * literal's bytes and length. */ - int refCount; /* If in an interpreter's global literal + int refCount; /* If in an interpreter's global literal * table, the number of ByteCode structures * that share the literal object; the literal * entry can be freed when refCount drops to @@ -1671,12 +1671,12 @@ typedef struct Command { * recreated). */ Namespace *nsPtr; /* Points to the namespace containing this * command. */ - TCL_HASH_TYPE refCount; /* 1 if in command hashtable plus 1 for each + int refCount; /* 1 if in command hashtable plus 1 for each * reference from a CmdName Tcl object * representing a command's name in a ByteCode * instruction sequence. This structure can be * freed when refCount becomes zero. */ - TCL_HASH_TYPE cmdEpoch; /* Incremented to invalidate any references + int cmdEpoch; /* Incremented to invalidate any references * that point to this command when it is * renamed, deleted, hidden, or exposed. */ CompileProc *compileProc; /* Procedure called to compile command. NULL @@ -1728,6 +1728,7 @@ typedef struct Command { */ #define CMD_DYING 0x01 +#define CMD_IS_DELETED 0x01 /* Same as CMD_DYING (Deprecated) */ #define CMD_TRACE_ACTIVE 0x02 #define CMD_HAS_EXEC_TRACES 0x04 #define CMD_COMPILES_EXPANDED 0x08 @@ -1942,7 +1943,7 @@ typedef struct Interp { * compiled by the interpreter. Indexed by the * string representations of literals. Used to * avoid creating duplicate objects. */ - TCL_HASH_TYPE compileEpoch; /* Holds the current "compilation epoch" for + int compileEpoch; /* Holds the current "compilation epoch" for * this interpreter. This is incremented to * invalidate existing ByteCodes when, e.g., a * command with a compile procedure is @@ -2432,7 +2433,7 @@ typedef enum TclEolTranslation { */ typedef struct List { - TCL_HASH_TYPE refCount; + int refCount; int maxElemCount; /* Total number of element array slots. */ int elemCount; /* Current number of list elements. */ int canonicalFlag; /* Set if the string representation was @@ -2668,7 +2669,7 @@ typedef void (TclInitProcessGlobalValueProc)(char **valuePtr, TCL_HASH_TYPE *len */ typedef struct ProcessGlobalValue { - TCL_HASH_TYPE epoch; /* Epoch counter to detect changes in the + int epoch; /* Epoch counter to detect changes in the * global value. */ TCL_HASH_TYPE numBytes; /* Length of the global string. */ char *value; /* The global string value. */ @@ -3018,8 +3019,7 @@ MODULE_SCOPE int TclFSFileAttrIndex(Tcl_Obj *pathPtr, MODULE_SCOPE Tcl_Command TclNRCreateCommandInNs(Tcl_Interp *interp, const char *cmdName, Tcl_Namespace *nsPtr, Tcl_ObjCmdProc *proc, Tcl_ObjCmdProc *nreProc, - ClientData clientData, - Tcl_CmdDeleteProc *deleteProc); + void *clientData, Tcl_CmdDeleteProc *deleteProc); MODULE_SCOPE int TclNREvalFile(Tcl_Interp *interp, Tcl_Obj *pathPtr, const char *encodingName); MODULE_SCOPE void TclFSUnloadTempFile(Tcl_LoadHandle loadHandle); diff --git a/generic/tclObj.c b/generic/tclObj.c index 8849992..5726596 100644 --- a/generic/tclObj.c +++ b/generic/tclObj.c @@ -341,12 +341,12 @@ typedef struct ResolvedCmdName { * it's possible that the cmd's containing * namespace was deleted and a new one created * at the same address). */ - unsigned int refNsCmdEpoch; /* Value of the referencing namespace's + int refNsCmdEpoch; /* Value of the referencing namespace's * cmdRefEpoch when the pointer was cached. * Before using the cached pointer, we check * if the namespace's epoch was incremented; * if so, this cached pointer is invalid. */ - unsigned int cmdEpoch; /* Value of the command's cmdEpoch when this + int cmdEpoch; /* Value of the command's cmdEpoch when this * pointer was cached. Before using the cached * pointer, we check if the cmd's epoch was * incremented; if so, the cmd was renamed, diff --git a/generic/tclUtil.c b/generic/tclUtil.c index 2a2f72d..7ab6eae 100644 --- a/generic/tclUtil.c +++ b/generic/tclUtil.c @@ -4366,7 +4366,7 @@ TclGetProcessGlobalValue( Tcl_Obj *value = NULL; Tcl_HashTable *cacheMap; Tcl_HashEntry *hPtr; - unsigned int epoch = pgvPtr->epoch; + int epoch = pgvPtr->epoch; if (pgvPtr->encoding) { Tcl_Encoding current = Tcl_GetEncoding(NULL, NULL); diff --git a/generic/tclVar.c b/generic/tclVar.c index 0ab2c55..2ef51b2 100644 --- a/generic/tclVar.c +++ b/generic/tclVar.c @@ -381,8 +381,7 @@ CleanupVar( { if (TclIsVarUndefined(varPtr) && TclIsVarInHash(varPtr) && !TclIsVarTraced(varPtr) - && (VarHashRefCount(varPtr) == (unsigned) - !TclIsVarDeadHash(varPtr))) { + && (VarHashRefCount(varPtr) == !TclIsVarDeadHash(varPtr))) { if (VarHashRefCount(varPtr) == 0) { ckfree(varPtr); } else { @@ -391,8 +390,7 @@ CleanupVar( } if (arrayPtr != NULL && TclIsVarUndefined(arrayPtr) && TclIsVarInHash(arrayPtr) && !TclIsVarTraced(arrayPtr) && - (VarHashRefCount(arrayPtr) == (unsigned) - !TclIsVarDeadHash(arrayPtr))) { + (VarHashRefCount(arrayPtr) == !TclIsVarDeadHash(arrayPtr))) { if (VarHashRefCount(arrayPtr) == 0) { ckfree(arrayPtr); } else { -- cgit v0.12 From 1a619a80d9b1d41d4530a41f827a51d04c37f1ad Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 24 Jun 2022 11:40:47 +0000 Subject: Fix for commit [c8bd577a119f2259], which is (slightly) wrong: allowed space should be between '#' and 'define' --- 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 b3433cc..e6d9375 100755 --- a/tools/tcltk-man2html.tcl +++ b/tools/tcltk-man2html.tcl @@ -43,7 +43,7 @@ proc getversion {tclh {name {}}} { # highlighting straight in some editors if {[regexp -lineanchor \ [string map [list @name@ $name] \ - {^\s*#define\s+@name@_VERSION\s+\"([^.])+\.([^.\"]+)}] \ + {^#\s*define\s+@name@_VERSION\s+\"([^.])+\.([^.\"]+)}] \ $data -> major minor]} { return [list $major $minor] } -- cgit v0.12 From 9ed525256bd289a96f4960aa566f811a5d529ae9 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 24 Jun 2022 13:48:19 +0000 Subject: Resolve the TODO: What's going on here? Document or eliminate. Eliminate usage of TCL_MAJOR_VERSION. Allow tcl.h to be used when compiling with -DTCL_MAJOR_VERSION=8 --- generic/tcl.h | 5 +++++ generic/tclBinary.c | 6 +----- generic/tclInt.h | 16 +++++++--------- 3 files changed, 13 insertions(+), 14 deletions(-) diff --git a/generic/tcl.h b/generic/tcl.h index 3b9d483..285c1f5 100644 --- a/generic/tcl.h +++ b/generic/tcl.h @@ -47,7 +47,12 @@ extern "C" { * unix/tcl.spec (1 LOC patch) */ +#if !defined(TCL_MAJOR_VERSION) #define TCL_MAJOR_VERSION 8 +#endif +#if TCL_MAJOR_VERSION != 8 +#error "This header-file is for Tcl 8 only" +#endif #define TCL_MINOR_VERSION 7 #define TCL_RELEASE_LEVEL TCL_ALPHA_RELEASE #define TCL_RELEASE_SERIAL 6 diff --git a/generic/tclBinary.c b/generic/tclBinary.c index 5678a66..bf40924 100644 --- a/generic/tclBinary.c +++ b/generic/tclBinary.c @@ -556,12 +556,8 @@ TclGetByteArrayFromObj( baPtr = GET_BYTEARRAY(irPtr); if (numBytesPtr != NULL) { -#if TCL_MAJOR_VERSION > 8 - *numBytesPtr = baPtr->used; -#else - /* TODO: What's going on here? Document or eliminate. */ + /* Make sure we return a value between 0 and UINT_MAX-1, or (size_t)-1 */ *numBytesPtr = ((size_t)(unsigned int)(baPtr->used + 1)) - 1; -#endif } return baPtr->bytes; } diff --git a/generic/tclInt.h b/generic/tclInt.h index 1a504f4..ee3dbf8 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -1901,7 +1901,7 @@ typedef struct Interp { * See Tcl_AppendResult code for details. */ -#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9 +#if !defined(TCL_NO_DEPRECATED) char *appendResult; /* Storage space for results generated by * Tcl_AppendResult. Ckalloc-ed. NULL means * not yet allocated. */ @@ -1975,13 +1975,11 @@ typedef struct Interp { * string. Returned by Tcl_ObjSetVar2 when * variable traces change a variable in a * gross way. */ -#if TCL_MAJOR_VERSION < 9 -# if !defined(TCL_NO_DEPRECATED) +#if !defined(TCL_NO_DEPRECATED) char resultSpace[TCL_DSTRING_STATIC_SIZE+1]; /* Static space holding small results. */ -# else +#else char resultSpaceDontUse[TCL_DSTRING_STATIC_SIZE+1]; -# endif #endif Tcl_Obj *objResultPtr; /* If the last command returned an object * result, this points to it. Should not be @@ -2646,7 +2644,7 @@ typedef Tcl_Channel (TclOpenFileChannelProc_)(Tcl_Interp *interp, *---------------------------------------------------------------- */ -#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9 +#if !defined(TCL_NO_DEPRECATED) typedef Tcl_CmdProc *TclCmdProcType; typedef Tcl_ObjCmdProc *TclObjCmdProcType; #endif @@ -2717,7 +2715,7 @@ typedef struct ProcessGlobalValue { */ #define TCL_NUMBER_INT 2 -#if (TCL_MAJOR_VERSION < 9) && !defined(TCL_NO_DEPRECATED) +#if !defined(TCL_NO_DEPRECATED) # define TCL_NUMBER_LONG 1 /* deprecated, not used any more */ # define TCL_NUMBER_WIDE TCL_NUMBER_INT /* deprecated */ #endif @@ -3380,7 +3378,7 @@ MODULE_SCOPE Tcl_Command TclInitBinaryCmd(Tcl_Interp *interp); MODULE_SCOPE int Tcl_BreakObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); -#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9 +#if !defined(TCL_NO_DEPRECATED) MODULE_SCOPE int Tcl_CaseObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); @@ -4586,7 +4584,7 @@ MODULE_SCOPE void TclDbInitNewObj(Tcl_Obj *objPtr, const char *file, (objPtr)->typePtr = NULL; \ } -#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 8 +#if !defined(TCL_NO_DEPRECATED) # define TclFreeIntRep(objPtr) TclFreeInternalRep(objPtr) #endif -- cgit v0.12 From 0ea8daaec8aab6fdebacaf71b35869d1e810bffa Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 24 Jun 2022 14:26:14 +0000 Subject: slightly stricter checking for TCL_MAJOR_VERSION in rules.vc --- win/rules.vc | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/win/rules.vc b/win/rules.vc index 47c0742..db65ce7 100644 --- a/win/rules.vc +++ b/win/rules.vc @@ -693,7 +693,7 @@ LINKERFLAGS = $(LINKERFLAGS) -ltcg !if [echo REM = This file is generated from rules.vc > versions.vc] !endif !if [echo TCL_MAJOR_VERSION = \>> versions.vc] \ - && [nmakehlp -V "$(_TCL_H)" TCL_MAJOR_VERSION >> versions.vc] + && [nmakehlp -V "$(_TCL_H)" "define TCL_MAJOR_VERSION" >> versions.vc] !endif !if [echo TCL_MINOR_VERSION = \>> versions.vc] \ && [nmakehlp -V "$(_TCL_H)" TCL_MINOR_VERSION >> versions.vc] -- cgit v0.12 From 17e23452bfe9efb1a43b841b47af20b29e53d788 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 24 Jun 2022 20:02:06 +0000 Subject: typo's --- generic/tclExecute.c | 2 +- generic/tclOO.h | 4 ++-- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/generic/tclExecute.c b/generic/tclExecute.c index 739641b..25b9409 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -73,7 +73,7 @@ int tclTraceExec = 0; * expression opcodes (e.g., INST_LOR) in tclCompile.h. * * Does not include the string for INST_EXPON (and beyond), as that is - * disjoint for backward-compatability reasons. + * disjoint for backward-compatibility reasons. */ static const char *const operatorStrings[] = { diff --git a/generic/tclOO.h b/generic/tclOO.h index 32afbf1..a5c67b3 100644 --- a/generic/tclOO.h +++ b/generic/tclOO.h @@ -95,7 +95,7 @@ typedef struct { /* * The correct value for the version field of the Tcl_MethodType structure. * This allows new versions of the structure to be introduced without breaking - * binary compatability. + * binary compatibility. */ #define TCL_OO_METHOD_VERSION_CURRENT 1 @@ -122,7 +122,7 @@ typedef struct { /* * The correct value for the version field of the Tcl_ObjectMetadataType * structure. This allows new versions of the structure to be introduced - * without breaking binary compatability. + * without breaking binary compatibility. */ #define TCL_OO_METADATA_VERSION_CURRENT 1 -- cgit v0.12 From 59571d7b3fc9705ea9f18a0cff6cc2f37ebfa0f9 Mon Sep 17 00:00:00 2001 From: apnadkarni Date: Mon, 27 Jun 2022 16:02:37 +0000 Subject: Ticket #21280817 - Windows console rewrite to only create one thread per stdio channel. Functional, but not complete. --- win/tclWinConsole.c | 1961 +++++++++++++++++++++++++++++++++------------------ 1 file changed, 1294 insertions(+), 667 deletions(-) diff --git a/win/tclWinConsole.c b/win/tclWinConsole.c index c3ba814..14cc6e5 100644 --- a/win/tclWinConsole.c +++ b/win/tclWinConsole.c @@ -2,15 +2,51 @@ * tclWinConsole.c -- * * This file implements the Windows-specific console functions, and the - * "console" channel driver. + * "console" channel driver. Windows 7 or later required. * - * Copyright © 1999 Scriptics Corp. + * Copyright © 2022 Ashok P. Nadkarni * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ +#define TCL_CONSOLE_DEBUG +#ifdef TCL_CONSOLE_DEBUG +#undef NDEBUG /* Enable asserts */ +#endif + #include "tclWinInt.h" +#include +#include + +/* + * A general note on the design: The console channel driver differs from most + * other drivers in the following respects: + * + * - There can be at most 3 console handles at any time since Windows does + * support allocation of more than one console (with three handles + * corresponding to stdin, stdout, stderr) + * + * - Consoles are created / inherited at process startup. There is currently + * no way in Tcl to programmatically create a console. Even if there were + * added the above Windows limitation would still apply. + * + * - Unlike files, sockets etc. where there is a one-to-one + * correspondence between Tcl channels and operating system handles, + * std* channels are shared amongst threads which means there can be + * multiple Tcl channels corresponding to a single console handle. + * + * - Even with multiple threads, more than one file event handler is unlikely. + * It does not make sense for multiple threads to register handlers for + * stdin because the input would be randomly fragmented amongst the threads + * (not even on a per line basis). + * + * Various design factors are driven by the above, e.g. use of lists instead + * of hash tables (at most 3 console handles) and use of global instead of + * per thread queues which simplifies lock management particularly because + * thread-console relation is not one-one and is likely more performant as + * well with fewer locks needing to be obtained. + */ /* * The following variable is used to tell whether this module has been @@ -19,106 +55,119 @@ static int initialized = 0; -/* - * The consoleMutex locks around access to the initialized variable, and it is - * used to protect background threads from being terminated while they are - * using APIs that hold locks. - */ - -TCL_DECLARE_MUTEX(consoleMutex) +#define CONSOLE_BUFFER_SIZE 8000 // TODO - must be at least 2 :-) /* - * Bit masks used in the flags field of the ConsoleInfo structure below. + * Ring buffer for storing data. Actual data is from bufPtr[start]:bufPtr[size-1] + * and bufPtr[0]:bufPtr[length - (size-start)]. */ - -#define CONSOLE_PENDING (1<<0) /* Message is pending in the queue. */ -#define CONSOLE_ASYNC (1<<1) /* Channel is non-blocking. */ -#define CONSOLE_READ_OPS (1<<4) /* Channel supports read-related ops. */ -#define CONSOLE_RESET (1<<5) /* Console mode needs to be reset. */ +#if TCL_MAJOR_VERSION > 8 +typedef ptrdiff_t RingSizeT; /* Tcl9 TODO */ +#define RingSizeT_MAX PTRDIFF_MAX +#else +typedef int RingSizeT; +#define RingSizeT_MAX INT_MAX +#endif +typedef struct RingBuffer { + char *bufPtr; /* Pointer to buffer storage */ + RingSizeT capacity; /* Size of the buffer in RingBufferChar */ + RingSizeT start; /* Start of the data within the buffer. */ + RingSizeT length; /* Number of RingBufferChar*/ +} RingBuffer; +#define RingBufferLength(ringPtr_) ((ringPtr_)->length) +#define RingBufferFreeSpace(ringPtr_) ((ringPtr_)->capacity - (ringPtr_)->length) +#define RINGBUFFER_ASSERT(ringPtr_) assert(RingBufferCheck(ringPtr_)) /* - * Bit masks used in the sharedFlags field of the ConsoleInfo structure below. + * The Win32 console API does not support non-blocking I/O in any form. Thus + * the actual calls are made on a separate thread. Moreover, separate + * threads are needed for each handle because (for example) blocking on user + * input on stdin should not prevent output to stdout when non-blocking i/o + * is configured at the script level. + * + * In the input (e.g. stdin) case, the console stdin thread is the producer + * writing to the buffer ring buffer. The Tcl interpreter threads are the + * consumer. For the output (e.g. stdout/stderr) case, the Tcl interpreter + * are the producers while the console stdout/stderr threads are the + * consumers. + * + * Consoles are identified purely by handles and multiple threads may open + * them (as stdin/stdout/stderr are shared). + * + * Note on reference counting - a ConsoleHandleInfo instance has multiple + * references to it - one each from every channel that is attached to it + * plus one from the console thread itself which also serves as the reference + * from gConsoleHandleInfoList. */ - -#define CONSOLE_EOF (1<<2) /* Console has reached EOF. */ -#define CONSOLE_BUFFERED (1<<3) /* Data was read into a buffer by the reader - * thread. */ - -#define CONSOLE_BUFFER_SIZE (8*1024) - -/* - * Structure containing handles associated with one of the special console - * threads. - */ - -typedef struct { - HANDLE thread; /* Handle to reader or writer thread. */ - HANDLE readyEvent; /* Manual-reset event to signal _to_ the main - * thread when the worker thread has finished - * waiting for its normal work to happen. */ - TclPipeThreadInfo *TI; /* Thread info structure of writer and reader. */ -} ConsoleThreadInfo; +typedef struct ConsoleHandleInfo { + struct ConsoleHandleInfo *nextPtr; /* Process-global list of consoles */ + HANDLE console; /* Console handle */ + HANDLE consoleThread; /* Handle to thread doing actual i/o on the console */ + SRWLOCK lock; /* Controls access to this structure. + * Cheaper than CRITICAL_SECTION but note does not + * support recursive locks or Try* style attempts.*/ + CONDITION_VARIABLE consoleThreadCV;/* For awakening console thread */ + CONDITION_VARIABLE interpThreadCV; /* For awakening interpthread(s) */ + RingBuffer buffer; /* Buffer for data transferred between console + * threads and Tcl threads. For input consoles, + * written by the console thread and read by Tcl + * threads. The converse for output threads */ + DWORD initMode; /* Initial console mode. */ + DWORD lastError; /* An error caused by the last background + * operation. Set to 0 if no error has been + * detected. */ + int numRefs; /* See comments above */ + int permissions; /* TCL_READABLE for input consoles, TCL_WRITABLE + * for output. Only one or the other can be set. */ +} ConsoleHandleInfo; /* * This structure describes per-instance data for a console based channel. + * + * Note on locking - this structure has no locks because it is accessed + * only from the thread owning channel EXCEPT when a console traverses it + * looking for a channel that is watching for events on the console. Even + * in that case, no locking is required because that access is only under + * the consoleLock lock which prevents the channel from being removed from + * the gWatchingChannelList which in turn means it will not be deallocated + * from under the console thread. Access to individual fields does not need + * to be controlled because + * - the console thread does not write to any fields + * - changes to the nextWatchingChannelPtr field and CONSOLE_EVENT_QUEUE + * bit flags are under the gConsoleLock lock + * - changes to other fields do not matter because after being read for + * queueing events, they are verified again when the event is received + * in the interpreter thread (since they could have changed anyways while + * the event was in-flight on the event queue) + * + * Note on reference counting - a structure instance may be referenced from + * three places: + * - the Tcl channel subsystem. This reference is created when on channel + * opening and dropped on channel close. This also covers the reference + * from gWatchingChannelList since queueing / dequeuing from that list + * happens in conjunction with channel operations. + * - the Tcl event queue entries. This reference is added when the event + * is queued and dropped on receipt. */ - -typedef struct ConsoleInfo { - HANDLE handle; - int type; - struct ConsoleInfo *nextPtr;/* Pointer to next registered console. */ +typedef struct ConsoleChannelInfo { + HANDLE handle; /* Console handle */ + Tcl_ThreadId threadId; /* Id of owning thread */ + struct ConsoleChannelInfo + *nextWatchingChannelPtr; /* Pointer to next channel watching events. */ Tcl_Channel channel; /* Pointer to channel structure. */ - int validMask; /* OR'ed combination of TCL_READABLE, + DWORD initMode; /* Initial console mode. */ + int numRefs; /* See comments above */ + int permissions; /* OR'ed combination of TCL_READABLE, * TCL_WRITABLE, or TCL_EXCEPTION: indicates * which operations are valid on the file. */ int watchMask; /* OR'ed combination of TCL_READABLE, * TCL_WRITABLE, or TCL_EXCEPTION: indicates * which events should be reported. */ - int flags; /* State flags, see above for a list. */ - Tcl_ThreadId threadId; /* Thread to which events should be reported. - * This value is used by the reader/writer - * threads. */ - ConsoleThreadInfo writer; /* A specialized thread for handling - * asynchronous writes to the console; the - * waiting starts when a control event is sent, - * and a reset event is sent back to the main - * thread when the write is done. */ - ConsoleThreadInfo reader; /* A specialized thread for handling - * asynchronous reads from the console; the - * waiting starts when a control event is sent, - * and a reset event is sent back to the main - * thread when input is available. */ - DWORD writeError; /* An error caused by the last background - * write. Set to 0 if no error has been - * detected. This word is shared with the - * writer thread so access must be - * synchronized with the writable object. */ - char *writeBuf; /* Current background output buffer. Access is - * synchronized with the writable object. */ - int writeBufLen; /* Size of write buffer. Access is - * synchronized with the writable object. */ - int toWrite; /* Current amount to be written. Access is - * synchronized with the writable object. */ - int readFlags; /* Flags that are shared with the reader - * thread. Access is synchronized with the - * readable object. */ - int bytesRead; /* Number of bytes in the buffer. */ - int offset; /* Number of bytes read out of the buffer. */ - DWORD initMode; /* Initial console mode. */ - char buffer[CONSOLE_BUFFER_SIZE]; - /* Data consumed by reader thread. */ -} ConsoleInfo; - -typedef struct { - /* - * The following pointer refers to the head of the list of consoles that - * are being watched for file events. - */ - - ConsoleInfo *firstConsolePtr; -} ThreadSpecificData; - -static Tcl_ThreadDataKey dataKey; + int flags; /* State flags */ +#define CONSOLE_EVENT_QUEUED (1 << 0) /* Notification event already queued */ +#define CONSOLE_ASYNC (1 << 1) /* Channel is non-blocking. */ +#define CONSOLE_READ_OPS (1 << 2) /* Channel supports read-related ops. */ +} ConsoleChannelInfo; /* * The following structure is what is added to the Tcl event queue when @@ -126,51 +175,101 @@ static Tcl_ThreadDataKey dataKey; */ typedef struct { - Tcl_Event header; /* Information that is standard for all - * events. */ - ConsoleInfo *infoPtr; /* Pointer to console info structure. Note - * that we still have to verify that the - * console exists before dereferencing this - * pointer. */ + Tcl_Event header; /* Information that is standard for all events. */ + ConsoleChannelInfo *chanInfoPtr; /* Pointer to console info structure. Note + * that we still have to verify that the + * console exists before dereferencing this + * pointer. */ } ConsoleEvent; /* * Declarations for functions used only in this file. */ -static int ConsoleBlockModeProc(ClientData instanceData, - int mode); -static void ConsoleCheckProc(ClientData clientData, int flags); -static int ConsoleCloseProc(ClientData instanceData, - Tcl_Interp *interp, int flags); -static int ConsoleEventProc(Tcl_Event *evPtr, int flags); -static void ConsoleExitHandler(ClientData clientData); -static int ConsoleGetHandleProc(ClientData instanceData, - int direction, ClientData *handlePtr); -static int ConsoleGetOptionProc(ClientData instanceData, - Tcl_Interp *interp, const char *optionName, - Tcl_DString *dsPtr); -static void ConsoleInit(void); -static int ConsoleInputProc(ClientData instanceData, char *buf, - int toRead, int *errorCode); -static int ConsoleOutputProc(ClientData instanceData, - const char *buf, int toWrite, int *errorCode); +static int ConsoleBlockModeProc(ClientData instanceData, int mode); +static void ConsoleCheckProc(ClientData clientData, int flags); +static int ConsoleCloseProc(ClientData instanceData, + Tcl_Interp *interp, int flags); +static int ConsoleEventProc(Tcl_Event *evPtr, int flags); +static void ConsoleExitHandler(ClientData clientData); +static int ConsoleGetHandleProc(ClientData instanceData, + int direction, ClientData *handlePtr); +static int ConsoleGetOptionProc(ClientData instanceData, + Tcl_Interp *interp, const char *optionName, + Tcl_DString *dsPtr); +static void ConsoleInit(void); +static int ConsoleInputProc(ClientData instanceData, char *buf, + int toRead, int *errorCode); +static int ConsoleOutputProc(ClientData instanceData, + const char *buf, int toWrite, int *errorCode); +static int ConsoleSetOptionProc(ClientData instanceData, + Tcl_Interp *interp, const char *optionName, + const char *value); +static void ConsoleSetupProc(ClientData clientData, int flags); +static void ConsoleWatchProc(ClientData instanceData, int mask); +static void ProcExitHandler(ClientData clientData); +static void ConsoleThreadActionProc(ClientData instanceData, int action); +static DWORD ReadConsoleChars(HANDLE hConsole, WCHAR *lpBuffer, + RingSizeT nChars, RingSizeT *nCharsReadPtr); +static DWORD WriteConsoleChars(HANDLE hConsole, + const WCHAR *lpBuffer, RingSizeT nChars, + RingSizeT *nCharsWritten); +static void RingBufferInit(RingBuffer *ringPtr, RingSizeT capacity); +static void RingBufferClear(RingBuffer *ringPtr); +static char * RingBufferSegment(const RingBuffer *ringPtr, RingSizeT *lenPtr); +static int RingBufferCheck(const RingBuffer *ringPtr); +static RingSizeT RingBufferIn(RingBuffer *ringPtr, const char *srcPtr, + RingSizeT srcLen, int partialCopyOk); +static RingSizeT RingBufferOut(RingBuffer *ringPtr, char *dstPtr, + RingSizeT dstCapacity, int partialCopyOk); +static ConsoleHandleInfo *AllocateConsoleHandleInfo(HANDLE consoleHandle, + int permissions); +static ConsoleHandleInfo *FindConsoleInfo(const ConsoleChannelInfo *); static DWORD WINAPI ConsoleReaderThread(LPVOID arg); -static int ConsoleSetOptionProc(ClientData instanceData, - Tcl_Interp *interp, const char *optionName, - const char *value); -static void ConsoleSetupProc(ClientData clientData, int flags); -static void ConsoleWatchProc(ClientData instanceData, int mask); static DWORD WINAPI ConsoleWriterThread(LPVOID arg); -static void ProcExitHandler(ClientData clientData); -static int WaitForRead(ConsoleInfo *infoPtr, int blocking); -static void ConsoleThreadActionProc(ClientData instanceData, - int action); -static BOOL ReadConsoleBytes(HANDLE hConsole, LPVOID lpBuffer, - DWORD nbytes, LPDWORD nbytesread); -static BOOL WriteConsoleBytes(HANDLE hConsole, - const void *lpBuffer, DWORD nbytes, - LPDWORD nbyteswritten); +#ifdef OBSOLETE +static int WaitForRead(ConsoleChannelInfo *infoPtr, int blocking); +#endif + +/* + * Static data. + */ + +typedef struct { + /* Currently this struct is only used to detect thread initialization */ + int notUsed; /* Dummy field */ +} ThreadSpecificData; +static Tcl_ThreadDataKey dataKey; + +/* + * All access to static data is controlled through a single process-wide + * lock. A process can have only a single console at a time, with three + * handles for stdin, stdout and stderr. Creation/destruction of consoles is + * a relatively rare event (currently only possible during process start), + * the number of consoles (as opposed to channels) is small (only stdin, + * stdout and stderr), and contention low. More finer-grained locking would + * likely not only complicate implementation but be slower due to multiple + * locks being held. Note console channels also differ from other Tcl + * channel types in that the channel<->OS descriptor mapping is not one-to-one. + * + * The gConsoleLock locks around access to the initialized variable, and it + * is used to protect background threads from being terminated while they + * are using APIs that hold locks. TBD - is this still true? + */ +SRWLOCK gConsoleLock; + + +/* Process-wide list of console handles. Access control through gConsoleLock */ +static ConsoleHandleInfo *gConsoleHandleInfoList; + +/* + * Process-wide list of channels that are listening for events. Again access + * control through gConsoleLock. Common list for all threads is simplifies + * locking and bookkeeping and is workable because in practice multiple + * threads are very unlikely to be all waiting on stdin (not workable + * because input would be randomly distributed to threads) + */ +static ConsoleChannelInfo *gWatchingChannelList; /* * This structure describes the channel type structure for command console @@ -178,82 +277,350 @@ static BOOL WriteConsoleBytes(HANDLE hConsole, */ static const Tcl_ChannelType consoleChannelType = { - "console", /* Type name. */ - TCL_CHANNEL_VERSION_5, /* v5 channel */ - TCL_CLOSE2PROC, /* Close proc. */ - ConsoleInputProc, /* Input proc. */ - ConsoleOutputProc, /* Output proc. */ - NULL, /* Seek proc. */ - ConsoleSetOptionProc, /* Set option proc. */ - ConsoleGetOptionProc, /* Get option proc. */ - ConsoleWatchProc, /* Set up notifier to watch the channel. */ - ConsoleGetHandleProc, /* Get an OS handle from channel. */ - ConsoleCloseProc, /* close2proc. */ - ConsoleBlockModeProc, /* Set blocking or non-blocking mode. */ - NULL, /* Flush proc. */ - NULL, /* Handler proc. */ - NULL, /* Wide seek proc. */ - ConsoleThreadActionProc, /* Thread action proc. */ - NULL /* Truncation proc. */ + "console", /* Type name. */ + TCL_CHANNEL_VERSION_5, /* v5 channel */ + TCL_CLOSE2PROC, /* Close proc. */ + ConsoleInputProc, /* Input proc. */ + ConsoleOutputProc, /* Output proc. */ + NULL, /* Seek proc. */ + ConsoleSetOptionProc, /* Set option proc. */ + ConsoleGetOptionProc, /* Get option proc. */ + ConsoleWatchProc, /* Set up notifier to watch the channel. */ + ConsoleGetHandleProc, /* Get an OS handle from channel. */ + ConsoleCloseProc, /* close2proc. */ + ConsoleBlockModeProc, /* Set blocking or non-blocking mode. */ + NULL, /* Flush proc. */ + NULL, /* Handler proc. */ + NULL, /* Wide seek proc. */ + ConsoleThreadActionProc, /* Thread action proc. */ + NULL /* Truncation proc. */ }; + +/* + *------------------------------------------------------------------------ + * + * RingBufferInit -- + * + * Initializes the ring buffer to a given size. + * + * Results: + * None. + * + * Side effects: + * Panics on allocation failure. + * + *------------------------------------------------------------------------ + */ +static void +RingBufferInit(RingBuffer *ringPtr, RingSizeT capacity) +{ + if (capacity <= 0 || capacity > RingSizeT_MAX) { + Tcl_Panic("Internal error: invalid ring buffer capacity requested."); + } + ringPtr->bufPtr = (char *)ckalloc(capacity); + ringPtr->capacity = capacity; + ringPtr->start = 0; + ringPtr->length = 0; +} /* - *---------------------------------------------------------------------- + *------------------------------------------------------------------------ * - * ReadConsoleBytes, WriteConsoleBytes -- + * RingBufferClear * - * Wrapper for ReadConsoleW, that takes and returns number of bytes - * instead of number of WCHARS. + * Clears the contents of a ring buffer. * - *---------------------------------------------------------------------- + * Results: + * None. + * + * Side effects: + * The allocated internal buffer is freed. + * + *------------------------------------------------------------------------ + */ +static void +RingBufferClear(RingBuffer *ringPtr) +{ + if (ringPtr->bufPtr) { + ckfree(ringPtr->bufPtr); + ringPtr->bufPtr = NULL; + } + ringPtr->capacity = 0; + ringPtr->start = 0; + ringPtr->length = 0; +} + +/* + *------------------------------------------------------------------------ + * + * RingBufferIn -- + * + * Appends data to the ring buffer. + * + * Results: + * Returns number of bytes copied. + * + * Side effects: + * Internal buffer is updated. + * + *------------------------------------------------------------------------ + */ +static RingSizeT +RingBufferIn( + RingBuffer *ringPtr, + const char *srcPtr, /* Source to be copied */ + RingSizeT srcLen, /* Length of source */ + int partialCopyOk /* If true, partial copy is permitted */ + ) +{ + RingSizeT freeSpace; + RingSizeT endSpace; + + RINGBUFFER_ASSERT(ringPtr); + + freeSpace = ringPtr->capacity - ringPtr->length; + if (freeSpace < srcLen) { + if (!partialCopyOk) { + return 0; + } + /* Copy only as much as free space allows */ + srcLen = freeSpace; + } + + /* Copy as much as possible to the tail */ + if (ringPtr->capacity - ringPtr->start > ringPtr->length) { + /* There is room at the back */ + RingSizeT endSpaceStart = ringPtr->start + ringPtr->length; + endSpace = ringPtr->capacity - endSpaceStart; + if (endSpace > srcLen) { + endSpace = srcLen; + } + memmove(endSpaceStart + ringPtr->bufPtr, srcPtr, endSpace); + } + else { + endSpace = 0; + } + + /* Wrap around any left over data. Have already copied endSpace bytes */ + if (srcLen > endSpace) { + memmove(ringPtr->bufPtr, endSpace + srcPtr, srcLen - endSpace); + } + + ringPtr->length += srcLen; + + RINGBUFFER_ASSERT(ringPtr); + + return srcLen; +} + +/* + *------------------------------------------------------------------------ + * + * RingBufferOut -- + * + * Moves data out of the ring buffer. If dstPtr is NULL, the data + * is simply removed. + * + * Results: + * Returns number of bytes copied or removed. + * + * Side effects: + * Internal buffer is updated. + * + *------------------------------------------------------------------------ + */ +static RingSizeT +RingBufferOut(RingBuffer *ringPtr, + char *dstPtr, /* Buffer for output data. May be NULL */ + RingSizeT dstCapacity, /* Size of buffer */ + int partialCopyOk) /* If true, return what's available */ +{ + RingSizeT leadLen; + + RINGBUFFER_ASSERT(ringPtr); + + if (dstCapacity > ringPtr->length) { + if (dstPtr && !partialCopyOk) { + return 0; + } + dstCapacity = ringPtr->length; + } + + if (ringPtr->start <= (ringPtr->capacity - ringPtr->length)) { + /* No content wrap around. So leadLen is entire content */ + leadLen = ringPtr->length; + } + else { + /* Content wraps around so lead segment stretches to end of buffer */ + leadLen = ringPtr->capacity - ringPtr->start; + } + if (leadLen >= dstCapacity) { + if (dstPtr) { + memmove(dstPtr, ringPtr->start + ringPtr->bufPtr, dstCapacity); + } + ringPtr->start += dstCapacity; + } + else { + RingSizeT wrapLen = dstCapacity - leadLen; + if (dstPtr) { + memmove(dstPtr, + ringPtr->start + ringPtr->bufPtr, + leadLen); + memmove( + leadLen + dstPtr, ringPtr->bufPtr, wrapLen); + } + ringPtr->start = wrapLen; + } + + ringPtr->length -= dstCapacity; + if (ringPtr->start == ringPtr->capacity || ringPtr->length == 0) { + ringPtr->start = 0; + } + + RINGBUFFER_ASSERT(ringPtr); + + return dstCapacity; +} + +/* + *------------------------------------------------------------------------ + * + * RingBufferSegment -- + * + * Returns a pointer to the leading data segment in the ring buffer. + * + * Results: + * Pointer to start of segment. + * + * Side effects: + * None. + * + *------------------------------------------------------------------------ */ + static char * + RingBufferSegment(const RingBuffer *ringPtr, RingSizeT *lengthPtr) +{ + RINGBUFFER_ASSERT(ringPtr); + if (ringPtr->length <= (ringPtr->capacity - ringPtr->start)) { + /* No content wrap around. */ + *lengthPtr = ringPtr->length; + } + else { + /* Content wraps around so lead segment stretches to end of buffer */ + *lengthPtr = ringPtr->capacity - ringPtr->start; + } + return *lengthPtr == 0 ? NULL : ringPtr->start + ringPtr->bufPtr; +} + +static int +RingBufferCheck(const RingBuffer *ringPtr) +{ + return (ringPtr->bufPtr != NULL && ringPtr->capacity == CONSOLE_BUFFER_SIZE + && ringPtr->start < ringPtr->capacity + && ringPtr->length <= ringPtr->capacity); +} -static BOOL -ReadConsoleBytes( +/* + *------------------------------------------------------------------------ + * + * ReadConsoleChars -- + * + * Wrapper for ReadConsoleW. + * + * Results: + * Returns 0 on success, else Windows error code. + * + * Side effects: + * On success the number of characters (not bytes) read is stored in + * *nCharsReadPtr. This will be 0 if the operation was interrupted by + * a Ctrl-C or a CancelIo call. + * + *------------------------------------------------------------------------ + */ +static DWORD +ReadConsoleChars( HANDLE hConsole, - LPVOID lpBuffer, - DWORD nbytes, - LPDWORD nbytesread) + WCHAR *lpBuffer, + RingSizeT nChars, + RingSizeT *nCharsReadPtr) { - DWORD ntchars; + DWORD nRead; BOOL result; /* - * If user types a Ctrl-Break or Ctrl-C, ReadConsole will return - * success with ntchars == 0 and GetLastError() will be - * ERROR_OPERATION_ABORTED. We do not want to treat this case - * as EOF so we will loop around again. If no Ctrl signal handlers - * have been established, the default signal OS handler in a separate - * thread will terminate the program. If a Ctrl signal handler - * has been established (through an extension for example), it - * will run and take whatever action it deems appropriate. + * If user types a Ctrl-Break or Ctrl-C, ReadConsole will return success + * with ntchars == 0 and GetLastError() will be ERROR_OPERATION_ABORTED. + * If no Ctrl signal handlers have been established, the default signal + * OS handler in a separate thread will terminate the program. If a Ctrl + * signal handler has been established (through an extension for + * example), it will run and take whatever action it deems appropriate. + * + * If one thread closes its channel, it calls CancelSynchronousIo on the + * console handle which results again in success being returned and + * GetLastError() being ERROR_OPERATION_ABORTED but ntchars in + * unmodified. + * + * In both cases above we will return success but with nbytesread as 0. + * This allows caller to check for thread termination etc. + * + * See https://bugs.python.org/issue30237 + * or https://github.com/microsoft/terminal/issues/12143 */ - do { - result = ReadConsoleW(hConsole, lpBuffer, nbytes / sizeof(WCHAR), &ntchars, - NULL); - } while (result && ntchars == 0 && GetLastError() == ERROR_OPERATION_ABORTED); - if (nbytesread != NULL) { - *nbytesread = ntchars * sizeof(WCHAR); - } - return result; + nRead = (DWORD)-1; + result = ReadConsoleW(hConsole, lpBuffer, nChars, &nRead, NULL); + if (result) { + if ((nRead == 0 || nRead == (DWORD)-1) + && GetLastError() == ERROR_OPERATION_ABORTED) { + nRead = 0; + } + *nCharsReadPtr = nRead; + return 0; + } + else + return GetLastError(); } + +/* + *------------------------------------------------------------------------ + * + * WriteConsoleChars -- + * + * Wrapper for WriteConsoleW. + * + * Results: + * Returns 0 on success, Windows error code on failure. + * + * Side effects: + * On success the number of characters (not bytes) written is stored in + * *nCharsWrittenPtr. This will be 0 if the operation was interrupted by + * a Ctrl-C or a CancelIo call. + * + *------------------------------------------------------------------------ + */ -static BOOL -WriteConsoleBytes( +static DWORD +WriteConsoleChars( HANDLE hConsole, - const void *lpBuffer, - DWORD nbytes, - LPDWORD nbyteswritten) + const WCHAR *lpBuffer, + RingSizeT nChars, + RingSizeT *nCharsWrittenPtr) { - DWORD ntchars; + DWORD nCharsWritten; BOOL result; - result = WriteConsoleW(hConsole, lpBuffer, nbytes / sizeof(WCHAR), &ntchars, - NULL); - if (nbyteswritten != NULL) { - *nbyteswritten = ntchars * sizeof(WCHAR); + /* See comments in ReadConsoleChars, not sure that applies here */ + nCharsWritten = (DWORD)-1; + result = WriteConsoleW(hConsole, lpBuffer, nChars, &nCharsWritten, NULL); + if (result) { + if (nCharsWritten == (DWORD) -1) { + nCharsWritten = 0; + } + *nCharsWrittenPtr = nCharsWritten; + return 0; + } + else { + return GetLastError(); } - return result; } /* @@ -281,18 +648,18 @@ ConsoleInit(void) */ if (!initialized) { - Tcl_MutexLock(&consoleMutex); + AcquireSRWLockExclusive(&gConsoleLock); if (!initialized) { initialized = 1; Tcl_CreateExitHandler(ProcExitHandler, NULL); } - Tcl_MutexUnlock(&consoleMutex); + ReleaseSRWLockExclusive(&gConsoleLock); } if (TclThreadDataKeyGet(&dataKey) == NULL) { ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); - tsdPtr->firstConsolePtr = NULL; + tsdPtr->notUsed = 0; Tcl_CreateEventSource(ConsoleSetupProc, ConsoleCheckProc, NULL); Tcl_CreateThreadExitHandler(ConsoleExitHandler, NULL); } @@ -343,9 +710,9 @@ static void ProcExitHandler( TCL_UNUSED(ClientData)) { - Tcl_MutexLock(&consoleMutex); + AcquireSRWLockExclusive(&gConsoleLock); initialized = 0; - Tcl_MutexUnlock(&consoleMutex); + ReleaseSRWLockExclusive(&gConsoleLock); } /* @@ -354,7 +721,9 @@ ProcExitHandler( * ConsoleSetupProc -- * * This procedure is invoked before Tcl_DoOneEvent blocks waiting for an - * event. + * event. It walks the channel list and if any input channel has data + * available or output channel has space for data, sets the event loop + * blocking time to 0 so that it will poll immediately. * * Results: * None. @@ -370,34 +739,40 @@ ConsoleSetupProc( TCL_UNUSED(ClientData), int flags) /* Event flags as passed to Tcl_DoOneEvent. */ { - ConsoleInfo *infoPtr; + ConsoleChannelInfo *chanInfoPtr; Tcl_Time blockTime = { 0, 0 }; int block = 1; - ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); if (!(flags & TCL_FILE_EVENTS)) { return; } /* - * Look to see if any events are already pending. If they are, poll. + * Walk the list of channels. See general comments for struct + * ConsoleChannelInfo with regard to locking and field access. */ - - for (infoPtr = tsdPtr->firstConsolePtr; infoPtr != NULL; - infoPtr = infoPtr->nextPtr) { - if (infoPtr->watchMask & TCL_WRITABLE) { - if (WaitForSingleObject(infoPtr->writer.readyEvent, - 0) != WAIT_TIMEOUT) { - block = 0; + AcquireSRWLockShared(&gConsoleLock); /* READ lock - no data modification */ + + for (chanInfoPtr = gWatchingChannelList; block && chanInfoPtr != NULL; + chanInfoPtr = chanInfoPtr->nextWatchingChannelPtr) { + ConsoleHandleInfo *handleInfoPtr; + handleInfoPtr = FindConsoleInfo(chanInfoPtr); + if (handleInfoPtr != NULL) { + AcquireSRWLockShared(&handleInfoPtr->lock); + if ((chanInfoPtr->watchMask & TCL_READABLE) + && RingBufferLength(&handleInfoPtr->buffer) > 0) { + block = 0; /* Input data available */ } - } - if (infoPtr->watchMask & TCL_READABLE) { - if (WaitForRead(infoPtr, 0) >= 0) { - block = 0; + else if (RingBufferFreeSpace(&handleInfoPtr->buffer) > 0) { + block = 0; /* Output space available */ } + ReleaseSRWLockShared(&handleInfoPtr->lock); } } + ReleaseSRWLockShared(&gConsoleLock); + if (!block) { + /* At least one channel is readable/writable. Set block time to 0 */ Tcl_SetMaxBlockTime(&blockTime); } } @@ -424,54 +799,69 @@ ConsoleCheckProc( TCL_UNUSED(ClientData), int flags) /* Event flags as passed to Tcl_DoOneEvent. */ { - ConsoleInfo *infoPtr; + ConsoleChannelInfo *chanInfoPtr; + Tcl_ThreadId me; int needEvent; - ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); if (!(flags & TCL_FILE_EVENTS)) { return; } + me = Tcl_GetCurrentThread(); + /* - * Queue events for any ready consoles that don't already have events - * queued. + * Acquire a shared lock. Note this is ok even though we potentially + * modify the chanInfoPtr->flags because chanInfoPtr is only modified + * when it belongs to this thread and no other thread will write to it. + * THe shared lock is intended to protect the global gWatchingChannelList + * as we traverse it. */ + AcquireSRWLockShared(&gConsoleLock); + + for (chanInfoPtr = gWatchingChannelList; chanInfoPtr != NULL; + chanInfoPtr = chanInfoPtr->nextWatchingChannelPtr) { + ConsoleHandleInfo *handleInfoPtr; - for (infoPtr = tsdPtr->firstConsolePtr; infoPtr != NULL; - infoPtr = infoPtr->nextPtr) { - if (infoPtr->flags & CONSOLE_PENDING) { + if (chanInfoPtr->threadId != me) { + /* Some other thread owns the channel */ + continue; + } + if (chanInfoPtr->flags & CONSOLE_EVENT_QUEUED) { + /* A notification event already queued. No point in another. */ continue; } - /* - * Queue an event if the console is signaled for reading or writing. - */ + handleInfoPtr = FindConsoleInfo(chanInfoPtr); + /* Pointer is safe to access as we are holding gConsoleLock */ - needEvent = 0; - if (infoPtr->watchMask & TCL_WRITABLE) { - if (WaitForSingleObject(infoPtr->writer.readyEvent, - 0) != WAIT_TIMEOUT) { - needEvent = 1; + if (handleInfoPtr != NULL) { + AcquireSRWLockShared(&handleInfoPtr->lock); + if ((chanInfoPtr->watchMask & TCL_READABLE) + && RingBufferLength(&handleInfoPtr->buffer) > 0) { + needEvent = 1; /* Input data available */ } - } - - if (infoPtr->watchMask & TCL_READABLE) { - if (WaitForRead(infoPtr, 0) >= 0) { - needEvent = 1; + else if (RingBufferFreeSpace(&handleInfoPtr->buffer) > 0) { + needEvent = 1; /* Output space available */ } + ReleaseSRWLockShared(&handleInfoPtr->lock); } if (needEvent) { ConsoleEvent *evPtr = (ConsoleEvent *)ckalloc(sizeof(ConsoleEvent)); - infoPtr->flags |= CONSOLE_PENDING; + /* See note above loop why this can be accessed without locks */ + chanInfoPtr->flags |= CONSOLE_EVENT_QUEUED; + chanInfoPtr->numRefs += 1; /* So it does not go away while event + is in queue */ evPtr->header.proc = ConsoleEventProc; - evPtr->infoPtr = infoPtr; + evPtr->chanInfoPtr = chanInfoPtr; Tcl_QueueEvent((Tcl_Event *) evPtr, TCL_QUEUE_TAIL); } } + + ReleaseSRWLockShared(&gConsoleLock); } - + /* *---------------------------------------------------------------------- * @@ -494,7 +884,7 @@ ConsoleBlockModeProc( int mode) /* TCL_MODE_BLOCKING or * TCL_MODE_NONBLOCKING. */ { - ConsoleInfo *infoPtr = (ConsoleInfo *)instanceData; + ConsoleChannelInfo *chanInfoPtr = (ConsoleChannelInfo *)instanceData; /* * Consoles on Windows can not be switched between blocking and @@ -505,9 +895,9 @@ ConsoleBlockModeProc( */ if (mode == TCL_MODE_NONBLOCKING) { - infoPtr->flags |= CONSOLE_ASYNC; + chanInfoPtr->flags |= CONSOLE_ASYNC; } else { - infoPtr->flags &= ~CONSOLE_ASYNC; + chanInfoPtr->flags &= ~CONSOLE_ASYNC; } return 0; } @@ -530,102 +920,86 @@ ConsoleBlockModeProc( static int ConsoleCloseProc( - ClientData instanceData, /* Pointer to ConsoleInfo structure. */ + ClientData instanceData, /* Pointer to ConsoleChannelInfo structure. */ TCL_UNUSED(Tcl_Interp *), int flags) { - ConsoleInfo *consolePtr = (ConsoleInfo *)instanceData; + ConsoleChannelInfo *chanInfoPtr = (ConsoleChannelInfo *)instanceData; + ConsoleHandleInfo *handleInfoPtr; int errorCode = 0; - ConsoleInfo *infoPtr, **nextPtrPtr; - ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); + ConsoleChannelInfo **nextPtrPtr; if ((flags & (TCL_CLOSE_READ | TCL_CLOSE_WRITE)) != 0) { return EINVAL; } - /* - * Clean up the background thread if necessary. Note that this must be - * done before we can close the file, since the thread may be blocking - * trying to read from the console. - */ + AcquireSRWLockExclusive(&gConsoleLock); - if (consolePtr->reader.thread) { - TclPipeThreadStop(&consolePtr->reader.TI, consolePtr->reader.thread); - CloseHandle(consolePtr->reader.thread); - CloseHandle(consolePtr->reader.readyEvent); - consolePtr->reader.thread = NULL; + /* Remove channel from watchers' list */ + for (nextPtrPtr = &gWatchingChannelList; *nextPtrPtr != NULL; + nextPtrPtr = &(*nextPtrPtr)->nextWatchingChannelPtr) { + if (*nextPtrPtr == (ConsoleChannelInfo *) chanInfoPtr) { + *nextPtrPtr = (*nextPtrPtr)->nextWatchingChannelPtr; + break; + } } - consolePtr->validMask &= ~TCL_READABLE; - /* - * Wait for the writer thread to finish the current buffer, then terminate - * the thread and close the handles. If the channel is nonblocking, there - * should be no pending write operations. - */ - - if (consolePtr->writer.thread) { - if (consolePtr->toWrite) { - /* - * We only need to wait if there is something to write. This may - * prevent infinite wait on exit. [Python Bug 216289] - */ + handleInfoPtr = FindConsoleInfo(chanInfoPtr); + if (handleInfoPtr) { + /* + * Console thread may be blocked either waiting for console i/o + * or waiting on the condition variable for buffer empty/full + */ + AcquireSRWLockShared(&handleInfoPtr->lock); - WaitForSingleObject(consolePtr->writer.readyEvent, 5000); - } + handleInfoPtr->numRefs -= 1; /* Remove reference from this channel */ - TclPipeThreadStop(&consolePtr->writer.TI, consolePtr->writer.thread); - CloseHandle(consolePtr->writer.thread); - CloseHandle(consolePtr->writer.readyEvent); - consolePtr->writer.thread = NULL; - } - consolePtr->validMask &= ~TCL_WRITABLE; + /* Break the thread out of blocking console i/o */ + CancelSynchronousIo(handleInfoPtr->consoleThread); - /* - * If the user has been tinkering with the mode, reset it now. We ignore - * any errors from this; we're quite possibly about to close or exit - * anyway. - */ + /* Wake up the console handling thread */ + WakeConditionVariable(&handleInfoPtr->consoleThreadCV); - if ((consolePtr->flags & CONSOLE_READ_OPS) && - (consolePtr->flags & CONSOLE_RESET)) { - SetConsoleMode(consolePtr->handle, consolePtr->initMode); + ReleaseSRWLockShared(&handleInfoPtr->lock); } - /* - * Don't close the Win32 handle if the handle is a standard channel during - * the thread exit process. Otherwise, one thread may kill the stdio of - * another. - */ + ReleaseSRWLockExclusive(&gConsoleLock); - if (!TclInThreadExit() - || ((GetStdHandle(STD_INPUT_HANDLE) != consolePtr->handle) - && (GetStdHandle(STD_OUTPUT_HANDLE) != consolePtr->handle) - && (GetStdHandle(STD_ERROR_HANDLE) != consolePtr->handle))) { - if (CloseHandle(consolePtr->handle) == FALSE) { - Tcl_WinConvertError(GetLastError()); - errorCode = errno; + chanInfoPtr->channel = NULL; + chanInfoPtr->watchMask = 0; + chanInfoPtr->permissions = 0; + + if (chanInfoPtr->handle) { + /* + * Don't close the Win32 handle if the handle is a standard channel + * during the thread exit process. Otherwise, one thread may kill the + * stdio of another. TODO - an explicit close in script will still close + * it. + */ + if (!TclInThreadExit() + || ((GetStdHandle(STD_INPUT_HANDLE) != chanInfoPtr->handle) + && (GetStdHandle(STD_OUTPUT_HANDLE) != chanInfoPtr->handle) + && (GetStdHandle(STD_ERROR_HANDLE) != chanInfoPtr->handle))) { + if (CloseHandle(chanInfoPtr->handle) == FALSE) { + Tcl_WinConvertError(GetLastError()); + errorCode = errno; + } } + chanInfoPtr->handle = NULL; } - consolePtr->watchMask &= consolePtr->validMask; - /* - * Remove the file from the list of watched files. + * Note, we can check and manipulate numRefs without a lock because + * we have removed it from the watch queue so the console thread cannot + * get at it. */ - - for (nextPtrPtr = &tsdPtr->firstConsolePtr, infoPtr = *nextPtrPtr; - infoPtr != NULL; - nextPtrPtr = &infoPtr->nextPtr, infoPtr = *nextPtrPtr) { - if (infoPtr == (ConsoleInfo *) consolePtr) { - *nextPtrPtr = infoPtr->nextPtr; - break; - } + if (chanInfoPtr->numRefs > 1) { + /* There may be references already on the event queue */ + chanInfoPtr->numRefs -= 1; } - if (consolePtr->writeBuf != NULL) { - ckfree(consolePtr->writeBuf); - consolePtr->writeBuf = 0; + else { + ckfree(chanInfoPtr); } - ckfree(consolePtr); return errorCode; } @@ -647,80 +1021,85 @@ ConsoleCloseProc( * *---------------------------------------------------------------------- */ - static int ConsoleInputProc( ClientData instanceData, /* Console state. */ - char *buf, /* Where to store data read. */ + char *bufPtr, /* Where to store data read. */ int bufSize, /* How much space is available in the * buffer? */ int *errorCode) /* Where to store error code. */ { - ConsoleInfo *infoPtr = (ConsoleInfo *)instanceData; - DWORD count, bytesRead = 0; - int result; + ConsoleChannelInfo *chanInfoPtr = (ConsoleChannelInfo *)instanceData; + ConsoleHandleInfo *handleInfoPtr; + RingSizeT numRead; *errorCode = 0; - /* - * Synchronize with the reader thread. - */ - - result = WaitForRead(infoPtr, (infoPtr->flags & CONSOLE_ASYNC) ? 0 : 1); - - /* - * If an error occurred, return immediately. - */ - - if (result == -1) { - *errorCode = errno; - return -1; + AcquireSRWLockShared(&gConsoleLock); + handleInfoPtr = FindConsoleInfo(chanInfoPtr); + if (handleInfoPtr == NULL) { + /* Really shouldn't happen since channel is holding a reference */ + ReleaseSRWLockShared(&gConsoleLock); + return 0; /* EOF */ } + AcquireSRWLockExclusive(&handleInfoPtr->lock); + ReleaseSRWLockShared(&gConsoleLock); /* AFTER acquiring handleInfoPtr->lock */ - if (infoPtr->readFlags & CONSOLE_BUFFERED) { + numRead = RingBufferOut(&handleInfoPtr->buffer, bufPtr, bufSize, 1); + while (numRead == 0) { /* - * Data is stored in the buffer. + * No data available. + * - If an error was recorded, generate that and reset it. + * - If EOF, indicate as much. TODO - can console thread still be + * running in that case? + * - Otherwise, if non-blocking return EAGAIN or wait for more data. */ - - if (bufSize < (infoPtr->bytesRead - infoPtr->offset)) { - memcpy(buf, &infoPtr->buffer[infoPtr->offset], bufSize); - bytesRead = bufSize; - infoPtr->offset += bufSize; - } else { - memcpy(buf, &infoPtr->buffer[infoPtr->offset], bufSize); - bytesRead = infoPtr->bytesRead - infoPtr->offset; - - /* - * Reset the buffer. - */ - - infoPtr->readFlags &= ~CONSOLE_BUFFERED; - infoPtr->offset = 0; + if (handleInfoPtr->lastError != 0) { + Tcl_WinConvertError(handleInfoPtr->lastError); + handleInfoPtr->lastError = 0; + *errorCode = Tcl_GetErrno(); + numRead = -1; + } + else if (handleInfoPtr->console == NULL) { + /* EOF - break with numRead == 0 */ + break; + } + else { + if (chanInfoPtr->flags & CONSOLE_ASYNC) { + *errorCode = EAGAIN; + numRead = -1; + } + else { + /* + * Release the lock and sleep. Note that because the channel + * holds a reference count on handleInfoPtr, it will not + * be deallocated while the lock is released. + */ + WakeConditionVariable(&handleInfoPtr->consoleThreadCV); + if (SleepConditionVariableSRW(&handleInfoPtr->interpThreadCV, + &handleInfoPtr->lock, + INFINITE, + 0)) { + /* + * Lock is reacquired. However, in the meanwhile another + * thread could have consumed data. So loop continues + * with check of numRead value. + */ + numRead = RingBufferOut( + &handleInfoPtr->buffer, bufPtr, bufSize, 1); + } + else { + /* Report the error */ + Tcl_WinConvertError(GetLastError()); + *errorCode = Tcl_GetErrno(); + numRead = -1; + } + } } - - return bytesRead; - } - - /* - * Attempt to read bufSize bytes. The read will return immediately if - * there is any data available. Otherwise it will block until at least one - * byte is available or an EOF occurs. - */ - - if (ReadConsoleBytes(infoPtr->handle, (LPVOID) buf, (DWORD) bufSize, - &count) == TRUE) { - /* - * TODO: This potentially writes beyond the limits specified - * by the caller. In practice this is harmless, since all writes - * are into ChannelBuffers, and those have padding, but still - * ought to remove this, unless some Windows wizard can give - * a reason not to. - */ - buf[count] = '\0'; - return count; } - return -1; + ReleaseSRWLockExclusive(&handleInfoPtr->lock); + return numRead; } /* @@ -740,7 +1119,6 @@ ConsoleInputProc( * *---------------------------------------------------------------------- */ - static int ConsoleOutputProc( ClientData instanceData, /* Console state. */ @@ -748,74 +1126,70 @@ ConsoleOutputProc( int toWrite, /* How many bytes to write? */ int *errorCode) /* Where to store error code. */ { - ConsoleInfo *infoPtr = (ConsoleInfo *)instanceData; - ConsoleThreadInfo *threadInfo = &infoPtr->writer; - DWORD bytesWritten, timeout; + ConsoleChannelInfo *chanInfoPtr = (ConsoleChannelInfo *)instanceData; + ConsoleHandleInfo *handleInfoPtr; + RingSizeT numWritten; *errorCode = 0; - /* avoid blocking if pipe-thread exited */ - timeout = (infoPtr->flags & CONSOLE_ASYNC) || !TclPipeThreadIsAlive(&threadInfo->TI) - || TclInExit() || TclInThreadExit() ? 0 : INFINITE; - if (WaitForSingleObject(threadInfo->readyEvent, timeout) == WAIT_TIMEOUT) { - /* - * The writer thread is blocked waiting for a write to complete and - * the channel is in non-blocking mode. - */ - - errno = EWOULDBLOCK; - goto error; - } - - /* - * Check for a background error on the last write. - */ - - if (infoPtr->writeError) { - Tcl_WinConvertError(infoPtr->writeError); - infoPtr->writeError = 0; - goto error; + AcquireSRWLockShared(&gConsoleLock); + handleInfoPtr = FindConsoleInfo(chanInfoPtr); + if (handleInfoPtr == NULL) { + /* Really shouldn't happen since channel is holding a reference */ + *errorCode = EPIPE; + ReleaseSRWLockShared(&gConsoleLock); + return -1; } - - if (infoPtr->flags & CONSOLE_ASYNC) { - /* - * The console is non-blocking, so copy the data into the output - * buffer and restart the writer thread. - */ - - if (toWrite > infoPtr->writeBufLen) { + AcquireSRWLockExclusive(&handleInfoPtr->lock); + ReleaseSRWLockShared(&gConsoleLock); /* AFTER acquiring handleInfoPtr->lock */ + + numWritten = RingBufferIn(&handleInfoPtr->buffer, buf, toWrite, 1); + while (numWritten < toWrite) { + if (handleInfoPtr->lastError != 0) { + Tcl_WinConvertError(handleInfoPtr->lastError); + *errorCode = Tcl_GetErrno(); + numWritten = -1; + break; + } + if (handleInfoPtr->console == NULL) { + *errorCode = EPIPE; + numWritten = -1; + break; + } + if (chanInfoPtr->flags & CONSOLE_ASYNC) { + /* Async, just accept whatever was written */ + break; + } + else { /* - * Reallocate the buffer to be large enough to hold the data. + * Release the lock and sleep. Note that because the channel + * holds a reference count on handleInfoPtr, it will not + * be deallocated while the lock is released. */ - - if (infoPtr->writeBuf) { - ckfree(infoPtr->writeBuf); + WakeConditionVariable(&handleInfoPtr->consoleThreadCV); + if (SleepConditionVariableSRW(&handleInfoPtr->interpThreadCV, + &handleInfoPtr->lock, + INFINITE, + 0)) { + /* Lock is reacquired. Continue loop */ + numWritten += RingBufferIn(&handleInfoPtr->buffer, + numWritten + buf, + toWrite - numWritten, + 1); + } + else { + /* Report the error */ + Tcl_WinConvertError(GetLastError()); + *errorCode = Tcl_GetErrno(); + numWritten = -1; + break; } - infoPtr->writeBufLen = toWrite; - infoPtr->writeBuf = (char *)ckalloc(toWrite); - } - memcpy(infoPtr->writeBuf, buf, toWrite); - infoPtr->toWrite = toWrite; - ResetEvent(threadInfo->readyEvent); - TclPipeThreadSignal(&threadInfo->TI); - bytesWritten = toWrite; - } else { - /* - * In the blocking case, just try to write the buffer directly. This - * avoids an unnecessary copy. - */ - - if (WriteConsoleBytes(infoPtr->handle, buf, (DWORD) toWrite, - &bytesWritten) == FALSE) { - Tcl_WinConvertError(GetLastError()); - goto error; } } - return bytesWritten; - error: - *errorCode = errno; - return -1; + ReleaseSRWLockExclusive(&handleInfoPtr->lock); + WakeConditionVariable(&handleInfoPtr->consoleThreadCV); + return numWritten; } /* @@ -846,66 +1220,69 @@ ConsoleEventProc( * such as TCL_FILE_EVENTS. */ { ConsoleEvent *consoleEvPtr = (ConsoleEvent *) evPtr; - ConsoleInfo *infoPtr; - int mask; - ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); + ConsoleChannelInfo *chanInfoPtr; + int freeChannel; if (!(flags & TCL_FILE_EVENTS)) { return 0; } + chanInfoPtr = consoleEvPtr->chanInfoPtr; /* - * Search through the list of watched consoles for the one whose handle - * matches the event. We do this rather than simply dereferencing the - * handle in the event so that consoles can be deleted while the event is - * in the queue. - */ - - for (infoPtr = tsdPtr->firstConsolePtr; infoPtr != NULL; - infoPtr = infoPtr->nextPtr) { - if (consoleEvPtr->infoPtr == infoPtr) { - infoPtr->flags &= ~CONSOLE_PENDING; - break; - } - } - - /* - * Remove stale events. + * We know chanInfoPtr is valid because its reference count would have + * been incremented when the event was queued. The corresponding release + * happens in this function. */ - if (!infoPtr) { - return 1; - } + AcquireSRWLockShared(&gConsoleLock); + chanInfoPtr->flags &= ~CONSOLE_EVENT_QUEUED; /* - * Check to see if the console is readable. Note that we can't tell if a - * console is writable, so we always report it as being writable unless we - * have detected EOF. + * Only handle the event if the Tcl channel has not gone away AND is + * still owned by this thread AND is still watching events. */ - - mask = 0; - if (infoPtr->watchMask & TCL_WRITABLE) { - if (WaitForSingleObject(infoPtr->writer.readyEvent, - 0) != WAIT_TIMEOUT) { - mask = TCL_WRITABLE; + if (chanInfoPtr->channel && chanInfoPtr->threadId == Tcl_GetCurrentThread() + && (chanInfoPtr->watchMask & (TCL_READABLE|TCL_WRITABLE))) { + ConsoleHandleInfo *handleInfoPtr; + int mask = 0; + handleInfoPtr = FindConsoleInfo(chanInfoPtr); + if (handleInfoPtr == NULL) { + /* Console was closed. EOF->read event only (not write) */ + if (chanInfoPtr->watchMask & TCL_READABLE) { + mask = TCL_READABLE; + } } - } - - if (infoPtr->watchMask & TCL_READABLE) { - if (WaitForRead(infoPtr, 0) >= 0) { - if (infoPtr->readFlags & CONSOLE_EOF) { + else { + AcquireSRWLockShared(&handleInfoPtr->lock); + if (chanInfoPtr->watchMask & TCL_READABLE + && RingBufferLength(&handleInfoPtr->buffer)) { mask = TCL_READABLE; - } else { - mask |= TCL_READABLE; } + else if (RingBufferFreeSpace(&handleInfoPtr->buffer)) { + /* Generate write event space available */ + mask = TCL_WRITABLE; + } + ReleaseSRWLockShared(&handleInfoPtr->lock); + } + if (mask) { + Tcl_NotifyChannel(chanInfoPtr->channel, mask); } } + /* Remove the reference to the channel from event record */ + if (chanInfoPtr->numRefs > 1) { + chanInfoPtr->numRefs -= 1; + freeChannel = 0; + } + else { + assert(chanInfoPtr->channel == NULL); + freeChannel = 1; + ckfree(chanInfoPtr); + } + ReleaseSRWLockShared(&gConsoleLock); - /* - * Inform the channel of the events. - */ + if (freeChannel) + ckfree(chanInfoPtr); - Tcl_NotifyChannel(infoPtr->channel, infoPtr->watchMask & mask); return 1; } @@ -928,39 +1305,39 @@ ConsoleEventProc( static void ConsoleWatchProc( ClientData instanceData, /* Console state. */ - int mask) /* What events to watch for, OR-ed combination + int permissions) /* What events to watch for, OR-ed combination * of TCL_READABLE, TCL_WRITABLE and * TCL_EXCEPTION. */ { - ConsoleInfo **nextPtrPtr, *ptr; - ConsoleInfo *infoPtr = (ConsoleInfo *)instanceData; - int oldMask = infoPtr->watchMask; - ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); + ConsoleChannelInfo **nextPtrPtr, *ptr; + ConsoleChannelInfo *chanInfoPtr = (ConsoleChannelInfo *)instanceData; + int oldMask = chanInfoPtr->watchMask; /* * Since most of the work is handled by the background threads, we just * need to update the watchMask and then force the notifier to poll once. */ - infoPtr->watchMask = mask & infoPtr->validMask; - if (infoPtr->watchMask) { + chanInfoPtr->watchMask = permissions & chanInfoPtr->permissions; + if (chanInfoPtr->watchMask) { Tcl_Time blockTime = { 0, 0 }; if (!oldMask) { - infoPtr->nextPtr = tsdPtr->firstConsolePtr; - tsdPtr->firstConsolePtr = infoPtr; + /* Add to list of watched channels */ + AcquireSRWLockExclusive(&gConsoleLock); + chanInfoPtr->nextWatchingChannelPtr = gWatchingChannelList; + gWatchingChannelList = chanInfoPtr; + ReleaseSRWLockExclusive(&gConsoleLock); } Tcl_SetMaxBlockTime(&blockTime); } else if (oldMask) { - /* - * Remove the console from the list of watched consoles. - */ + /* Remove from list of watched channels */ - for (nextPtrPtr = &(tsdPtr->firstConsolePtr), ptr = *nextPtrPtr; + for (nextPtrPtr = &gWatchingChannelList, ptr = *nextPtrPtr; ptr != NULL; - nextPtrPtr = &ptr->nextPtr, ptr = *nextPtrPtr) { - if (infoPtr == ptr) { - *nextPtrPtr = ptr->nextPtr; + nextPtrPtr = &ptr->nextWatchingChannelPtr, ptr = *nextPtrPtr) { + if (chanInfoPtr == ptr) { + *nextPtrPtr = ptr->nextWatchingChannelPtr; break; } } @@ -991,12 +1368,13 @@ ConsoleGetHandleProc( TCL_UNUSED(int) /*direction*/, ClientData *handlePtr) /* Where to store the handle. */ { - ConsoleInfo *infoPtr = (ConsoleInfo *)instanceData; + ConsoleChannelInfo *chanInfoPtr = (ConsoleChannelInfo *)instanceData; - *handlePtr = infoPtr->handle; + *handlePtr = chanInfoPtr->handle; return TCL_OK; } +#ifdef OBSOLETE /* *---------------------------------------------------------------------- * @@ -1020,7 +1398,7 @@ ConsoleGetHandleProc( static int WaitForRead( - ConsoleInfo *infoPtr, /* Console state. */ + ConsoleChannelInfo *infoPtr, /* Console state. */ int blocking) /* Indicates whether call should be blocking * or not. */ { @@ -1100,6 +1478,7 @@ WaitForRead( TclPipeThreadSignal(&threadInfo->TI); } } +#endif /* *---------------------------------------------------------------------- @@ -1110,12 +1489,10 @@ WaitForRead( * available on a console. * * Results: - * None. + * Always 0. * * Side effects: - * Signals the main thread when input become available. May cause the - * main thread to wake up by posting a message. May one line from the - * console for each wait operation. + * Signals the main thread when input become available. * *---------------------------------------------------------------------- */ @@ -1124,76 +1501,147 @@ static DWORD WINAPI ConsoleReaderThread( LPVOID arg) { - TclPipeThreadInfo *pipeTI = (TclPipeThreadInfo *)arg; - ConsoleInfo *infoPtr = NULL; /* access info only after success init/wait */ - HANDLE *handle = NULL; - ConsoleThreadInfo *threadInfo = NULL; - int done = 0; + ConsoleHandleInfo *handleInfoPtr = (ConsoleHandleInfo *) arg; + ConsoleHandleInfo **iterator; + BOOL success; + char inputChars[200]; /* Temporary buffer */ + RingSizeT inputLen = 0; + RingSizeT inputOffset = 0; - while (!done) { - /* - * Wait for the main thread to signal before attempting to read. - */ + /* + * Keep looping until one of the following happens. + * + * - there are not more channels listening on the console + * - the console handle has been closed + * + * On each iteration, + * - if the channel buffer is full, wait for some channel reader to read + * - if there is data in our input buffer copy it to the channel buffer + * - get more data from the console + */ + + /* This thread is holding a reference so pointer is safe */ + AcquireSRWLockExclusive(&handleInfoPtr->lock); - if (!TclPipeThreadWaitForSignal(&pipeTI)) { - /* exit */ + while (1) { + + if (handleInfoPtr->numRefs == 1) { + /* Sole reference. That's this thread. Exit since no one clients */ break; } - if (!infoPtr) { - infoPtr = (ConsoleInfo *)pipeTI->clientData; - handle = (HANDLE *)infoPtr->handle; - threadInfo = &infoPtr->reader; - } + if (RingBufferFreeSpace(&handleInfoPtr->buffer) == 0) { + /* No room in buffer. Awaken any reader channels */ + WakeConditionVariable(&handleInfoPtr->interpThreadCV); + /* XXX - does not wake up fileevent channels! */ + + /* Release lock and wait for room */ + success = SleepConditionVariableSRW(&handleInfoPtr->consoleThreadCV, + &handleInfoPtr->lock, + INFINITE, + 0); + /* Note: lock has been acquired again! */ + + if (!success && GetLastError() != ERROR_TIMEOUT) { + /* TODO - what can be done? Should not happen */ + /* For now keep going */ + } + continue; /* Restart loop so we can check for exit conditions */ + } /* - * Look for data on the console, but first ignore any events that are - * not KEY_EVENTs. + * The shared buffer now has room. If we had any leftover from last + * read, store that. */ + if (inputLen > 0) { + RingSizeT nStored; + HANDLE consoleHandle; + ConsoleChannelInfo *chanInfoPtr; + + nStored = RingBufferIn(&handleInfoPtr->buffer, + inputOffset + inputChars, + inputLen - inputOffset, + 1); + inputOffset += nStored; + if (inputOffset == inputLen) { + /* Temp buffer now empty */ + inputOffset = 0; + inputLen = 0; + } + /* Wake up any threads waiting synchronously. */ + WakeConditionVariable(&handleInfoPtr->interpThreadCV); - if (ReadConsoleBytes(handle, infoPtr->buffer, CONSOLE_BUFFER_SIZE, - (LPDWORD) &infoPtr->bytesRead) != FALSE) { /* - * Data was stored in the buffer. + * Wake up all channels registered for file events. Note in + * order to follow the locking hierarchy, we need to release + * handleInfoPtr->lock before acquiring gConsoleLock and + * relock it. */ - - infoPtr->readFlags |= CONSOLE_BUFFERED; - } else { - DWORD err = GetLastError(); - - if (err == (DWORD) EOF) { - infoPtr->readFlags = CONSOLE_EOF; + consoleHandle = handleInfoPtr->console; + ReleaseSRWLockExclusive(&handleInfoPtr->lock); + AcquireSRWLockShared(&gConsoleLock); /* Shared-read lock */ + for (chanInfoPtr = gWatchingChannelList; chanInfoPtr; + chanInfoPtr = chanInfoPtr->nextWatchingChannelPtr) { + /* + * Notify channels interested in our handle AND that have + * a thread attached. + * No lock needed for chanInfoPtr. See ConsoleChannelInfo. + */ + if (chanInfoPtr->handle == consoleHandle + && chanInfoPtr->threadId != NULL) { + Tcl_ThreadAlert(chanInfoPtr->threadId); + } } - done = 1; + ReleaseSRWLockShared(&gConsoleLock); + AcquireSRWLockExclusive(&handleInfoPtr->lock); + continue; /* Restart loop */ } /* - * Signal the main thread by signalling the readable event and then - * waking up the notifier thread. + * Need to go get more data from console. We only store the last + * error. It is up to channel handlers to decide whether to close or + * what to do. */ + ReleaseSRWLockExclusive(&handleInfoPtr->lock); + handleInfoPtr->lastError = + ReadConsoleChars(handleInfoPtr->console, + (WCHAR *)inputChars, + sizeof(inputChars) / sizeof(WCHAR), + &inputLen); + inputLen *= sizeof(WCHAR); + AcquireSRWLockExclusive(&handleInfoPtr->lock); + } - SetEvent(threadInfo->readyEvent); - - /* - * Alert the foreground thread. Note that we need to treat this like a - * critical section so the foreground thread does not terminate this - * thread while we are holding a mutex in the notifier code. - */ + /* + * Exiting: + * - remove the console from global list + * - close the handle if still valid + * - release the structure + */ + ReleaseSRWLockExclusive(&handleInfoPtr->lock); + AcquireSRWLockExclusive(&gConsoleLock); /* Modifying - exclusive lock */ + for (iterator = &gConsoleHandleInfoList; *iterator; + iterator = &(*iterator)->nextPtr) { + if (*iterator == handleInfoPtr) { + *iterator = handleInfoPtr->nextPtr; + break; + } + } + ReleaseSRWLockExclusive(&gConsoleLock); - Tcl_MutexLock(&consoleMutex); - if (infoPtr->threadId != NULL) { - /* - * TIP #218. When in flight ignore the event, no one will receive - * it anyway. - */ + /* No need for relocking - no other thread should have access to it now */ + RingBufferClear(&handleInfoPtr->buffer); - Tcl_ThreadAlert(infoPtr->threadId); - } - Tcl_MutexUnlock(&consoleMutex); + if (handleInfoPtr->console) { + SetConsoleMode(handleInfoPtr->console, handleInfoPtr->initMode); } + /* + * NOTE: we do not call CloseHandle(handleInfoPtr->console) + * As per the GetStdHandle documentation, it need not be closed. + * TODO - what about when application closes and re-opens? - Test + */ - /* Worker exit, so inform the main thread or free TI-structure (if owned) */ - TclPipeThreadExit(&pipeTI); + ckfree(handleInfoPtr); return 0; } @@ -1210,89 +1658,262 @@ ConsoleReaderThread( * Always returns 0. * * Side effects: - - * Signals the main thread when an output operation is completed. May - * cause the main thread to wake up by posting a message. + * Signals the main thread when an output operation is completed. * *---------------------------------------------------------------------- */ - static DWORD WINAPI -ConsoleWriterThread( - LPVOID arg) +ConsoleWriterThread(LPVOID arg) { - TclPipeThreadInfo *pipeTI = (TclPipeThreadInfo *)arg; - ConsoleInfo *infoPtr = NULL; /* access info only after success init/wait */ - HANDLE *handle = NULL; - ConsoleThreadInfo *threadInfo = NULL; - DWORD count, toWrite; - char *buf; - int done = 0; - - while (!done) { - /* - * Wait for the main thread to signal before attempting to write. - */ - if (!TclPipeThreadWaitForSignal(&pipeTI)) { - /* exit */ - break; - } - if (!infoPtr) { - infoPtr = (ConsoleInfo *)pipeTI->clientData; - handle = (HANDLE *)infoPtr->handle; - threadInfo = &infoPtr->writer; - } + ConsoleHandleInfo *handleInfoPtr = (ConsoleHandleInfo *) arg; + ConsoleHandleInfo **iterator; + ConsoleChannelInfo *chanInfoPtr = NULL; + BOOL success; + char buffer[4000]; + RingSizeT length; + + /* + * Keep looping until one of the following happens. + * + * - there are not more channels listening on the console + * - the console handle has been closed + * + * On each iteration, + * - if the channel buffer is empty, wait for some channel writer to write + * - if there is data in our buffer, write it to the console + */ - buf = infoPtr->writeBuf; - toWrite = infoPtr->toWrite; + /* This thread is holding a reference so pointer is safe */ + AcquireSRWLockExclusive(&handleInfoPtr->lock); + while (1) { + /* handleInfoPtr->lock must be held on entry to loop */ + + int offset; + HANDLE consoleHandle; /* - * Loop until all of the bytes are written or an error occurs. + * Sadly, we need to do another copy because do not want to hold + * a lock on handleInfoPtr->buffer while calling WriteConsole as that + * might block. Also, we only want to copy an integral number of + * WCHAR's, i.e. even number of chars so do some length checks up + * front. */ - - while (toWrite > 0) { - if (WriteConsoleBytes(handle, buf, (DWORD) toWrite, - &count) == FALSE) { - infoPtr->writeError = GetLastError(); - done = 1; + length = RingBufferLength(&handleInfoPtr->buffer); + length &= ~1; /* Copy integral number of WCHARs -> even number of bytes */ + if (length == 0) { + /* No data to write */ + if (handleInfoPtr->numRefs == 1) { + /* + * Sole reference. That's this thread. Exit since no clients + * and no buffered output. + */ break; } - toWrite -= count; - buf += count; + /* Wake up any threads waiting synchronously. */ + WakeConditionVariable(&handleInfoPtr->interpThreadCV); + success = SleepConditionVariableSRW(&handleInfoPtr->consoleThreadCV, + &handleInfoPtr->lock, + INFINITE, + 0); + /* Note: lock has been acquired again! */ + if (!success && GetLastError() != ERROR_TIMEOUT) { + /* TODO - what can be done? Should not happen */ + /* For now keep going */ + } + continue; } - /* - * Signal the main thread by signalling the writable event and then - * waking up the notifier thread. - */ - - SetEvent(threadInfo->readyEvent); + /* We have data to write */ + if (length > (sizeof(buffer) / sizeof(buffer[0]))) { + length = sizeof(buffer); + } + /* No need to check result, we already checked length bytes available */ + RingBufferOut(&handleInfoPtr->buffer, buffer, length, 0); + + WakeConditionVariable(&handleInfoPtr->interpThreadCV); + ReleaseSRWLockExclusive(&handleInfoPtr->lock); + offset = 0; + while (length > 0) { + RingSizeT numWChars = length / sizeof(WCHAR); + DWORD status; + status = WriteConsoleChars( + handleInfoPtr->console, (WCHAR *) (offset + buffer) , numWChars, &numWChars); + if (status != 0) { + /* Only overwrite if no previous error */ + if (handleInfoPtr->lastError == 0) { + handleInfoPtr->lastError = status; + } + /* Assume this write is done but keep looping in case + * it is a transient error. Not sure just closing handle + * and exiting thread is a good idea. + */ + break; + } + length -= numWChars * sizeof(WCHAR); + offset += numWChars * sizeof(WCHAR); + } /* - * Alert the foreground thread. Note that we need to treat this like a - * critical section so the foreground thread does not terminate this - * thread while we are holding a mutex in the notifier code. + * Wake up all channels registered for file events. Note in + * order to follow the locking hierarchy, we need to release + * handleInfoPtr->lock before acquiring gConsoleLock and + * relock it. */ - - Tcl_MutexLock(&consoleMutex); - if (infoPtr->threadId != NULL) { + /* Wake up any threads waiting synchronously. */ + WakeConditionVariable(&handleInfoPtr->interpThreadCV); + AcquireSRWLockShared(&gConsoleLock); /* Shared-read lock */ + consoleHandle = handleInfoPtr->console; + for (chanInfoPtr = gWatchingChannelList; chanInfoPtr; + chanInfoPtr = chanInfoPtr->nextWatchingChannelPtr) { /* - * TIP #218. When in flight ignore the event, no one will receive - * it anyway. + * Notify channels interested in our handle AND that have + * a thread attached. + * No lock needed for chanInfoPtr. See ConsoleChannelInfo. */ + if (chanInfoPtr->handle == consoleHandle + && chanInfoPtr->threadId != NULL) { + Tcl_ThreadAlert(chanInfoPtr->threadId); + } + } + ReleaseSRWLockShared(&gConsoleLock); + AcquireSRWLockExclusive(&handleInfoPtr->lock); + } - Tcl_ThreadAlert(infoPtr->threadId); + /* + * Exiting: + * - remove the console from global list + * - close the handle if still valid + * - release the structure + */ + ReleaseSRWLockExclusive(&handleInfoPtr->lock); + AcquireSRWLockExclusive(&gConsoleLock); /* Modifying - exclusive lock */ + for (iterator = &gConsoleHandleInfoList; *iterator; + iterator = &(*iterator)->nextPtr) { + if (*iterator == handleInfoPtr) { + *iterator = handleInfoPtr->nextPtr; + break; } - Tcl_MutexUnlock(&consoleMutex); } + ReleaseSRWLockExclusive(&gConsoleLock); + + RingBufferClear(&handleInfoPtr->buffer); + + /* + * NOTE: we do not call CloseHandle(handleInfoPtr->console) + * As per the GetStdHandle documentation, it need not be closed. + * TODO - what about when application closes and re-opens? - Test + */ - /* Worker exit, so inform the main thread or free TI-structure (if owned) */ - TclPipeThreadExit(&pipeTI); + ckfree(handleInfoPtr); return 0; } /* + *------------------------------------------------------------------------ + * + * AllocateConsoleHandleInfo -- + * + * Allocates a ConsoleHandleInfo for the passed console handle. As + * a side effect starts a console thread to handle i/o on the handle. + * + * Important: Caller must be holding an EXCLUSIVE lock on gConsoleLock + * when calling this function. The lock continues to be held on return. + * + * Results: + * Pointer to an unlocked ConsoleHandleInfo structure. The reference + * count on the structure is 1. This corresponds to the common reference + * from the console thread and the gConsoleHandleInfoList. Returns NULL + * on error. + * + * Side effects: + * A console reader or writer thread is started. The returned structure + * is placed on the active console handler list gConsoleHandleInfoList. + * + *------------------------------------------------------------------------ + */ +static ConsoleHandleInfo * +AllocateConsoleHandleInfo( + HANDLE consoleHandle, + int permissions) /* TCL_READABLE or TCL_WRITABLE */ +{ + ConsoleHandleInfo *handleInfoPtr; + DWORD consoleMode; + + + handleInfoPtr = (ConsoleHandleInfo *)ckalloc(sizeof(*handleInfoPtr)); + handleInfoPtr->console = consoleHandle; + InitializeSRWLock(&handleInfoPtr->lock); + InitializeConditionVariable(&handleInfoPtr->consoleThreadCV); + InitializeConditionVariable(&handleInfoPtr->interpThreadCV); + RingBufferInit(&handleInfoPtr->buffer, CONSOLE_BUFFER_SIZE); + handleInfoPtr->lastError = 0; + handleInfoPtr->permissions = permissions; + handleInfoPtr->numRefs = 1; /* See function header */ + if (permissions == TCL_READABLE) { + GetConsoleMode(consoleHandle, &handleInfoPtr->initMode); + consoleMode = handleInfoPtr->initMode; + consoleMode &= ~(ENABLE_WINDOW_INPUT | ENABLE_MOUSE_INPUT); + consoleMode |= ENABLE_LINE_INPUT; + SetConsoleMode(consoleHandle, consoleMode); + } + handleInfoPtr->consoleThread = CreateThread( + NULL, /* default security descriptor */ + 8192, /* Stack size - will get rounded up to allocation granularity */ + permissions == TCL_READABLE ? ConsoleReaderThread : ConsoleWriterThread, + handleInfoPtr, /* Pass to thread */ + 0, /* Flags - no special cases */ + NULL); /* Don't care about thread id */ + if (handleInfoPtr->consoleThread == NULL) { + /* Note - SRWLock and condition variables do not need finalization */ + RingBufferClear(&handleInfoPtr->buffer); + ckfree(handleInfoPtr); + return NULL; + } + + /* Chain onto global list */ + handleInfoPtr->nextPtr = gConsoleHandleInfoList; + gConsoleHandleInfoList = handleInfoPtr; + + return handleInfoPtr; +} + +/* + *------------------------------------------------------------------------ + * + * FindConsoleInfo -- + * + * Finds the ConsoleHandleInfo record for a given ConsoleChannelInfo. + * The found record must match the console handle. It is the caller's + * responsibility to check the permissions (read/write) in the returned + * ConsoleHandleInfo match permissions in chanInfoPtr. This function does + * not check that. + * + * Important: Caller must be holding an shared or exclusive lock on + * gConsoleMutex. That ensures the returned pointer stays valid on + * return without risk of deallocation by other threads. + * + * Results: + * Pointer to the found ConsoleHandleInfo or NULL if not found + * + * Side effects: + * None. + * + *------------------------------------------------------------------------ + */ +static ConsoleHandleInfo * +FindConsoleInfo(const ConsoleChannelInfo *chanInfoPtr) +{ + ConsoleHandleInfo *handleInfoPtr; + for (handleInfoPtr = gConsoleHandleInfoList; handleInfoPtr; handleInfoPtr = handleInfoPtr->nextPtr) { + if (handleInfoPtr->console == chanInfoPtr->handle) { + return handleInfoPtr; + } + } + return NULL; +} + +/* *---------------------------------------------------------------------- * * TclWinOpenConsoleChannel -- @@ -1309,33 +1930,30 @@ ConsoleWriterThread( * *---------------------------------------------------------------------- */ - Tcl_Channel TclWinOpenConsoleChannel( HANDLE handle, char *channelName, int permissions) { - char encoding[4 + TCL_INTEGER_SPACE]; - ConsoleInfo *infoPtr; - DWORD modes; + ConsoleChannelInfo *chanInfoPtr; + ConsoleHandleInfo *handleInfoPtr; - ConsoleInit(); - - /* - * See if a channel with this handle already exists. - */ + /* A console handle can either be input or output, not both */ + if (permissions != TCL_READABLE && permissions != TCL_WRITABLE) { + return NULL; + } - infoPtr = (ConsoleInfo *)ckalloc(sizeof(ConsoleInfo)); - memset(infoPtr, 0, sizeof(ConsoleInfo)); + ConsoleInit(); - infoPtr->validMask = permissions; - infoPtr->handle = handle; - infoPtr->channel = (Tcl_Channel) NULL; + chanInfoPtr = (ConsoleChannelInfo *)ckalloc(sizeof(*chanInfoPtr)); + memset(chanInfoPtr, 0, sizeof(*chanInfoPtr)); - wsprintfA(encoding, "cp%d", GetConsoleCP()); + chanInfoPtr->permissions = permissions; + chanInfoPtr->handle = handle; + chanInfoPtr->channel = (Tcl_Channel) NULL; - infoPtr->threadId = Tcl_GetCurrentThread(); + chanInfoPtr->threadId = Tcl_GetCurrentThread(); /* * Use the pointer for the name of the result channel. This keeps the @@ -1343,10 +1961,7 @@ TclWinOpenConsoleChannel( * for instance). */ - sprintf(channelName, "file%" TCL_Z_MODIFIER "x", (size_t) infoPtr); - - infoPtr->channel = Tcl_CreateChannel(&consoleChannelType, channelName, - infoPtr, permissions); + sprintf(channelName, "file%" TCL_Z_MODIFIER "x", (size_t) chanInfoPtr); if (permissions & TCL_READABLE) { /* @@ -1355,38 +1970,78 @@ TclWinOpenConsoleChannel( * we only want to catch when complete lines are ready for reading. */ - infoPtr->flags |= CONSOLE_READ_OPS; - GetConsoleMode(infoPtr->handle, &infoPtr->initMode); - modes = infoPtr->initMode; - modes &= ~(ENABLE_WINDOW_INPUT | ENABLE_MOUSE_INPUT); - modes |= ENABLE_LINE_INPUT; - SetConsoleMode(infoPtr->handle, modes); - - infoPtr->reader.readyEvent = CreateEventW(NULL, TRUE, TRUE, NULL); - infoPtr->reader.thread = CreateThread(NULL, 256, ConsoleReaderThread, - TclPipeThreadCreateTI(&infoPtr->reader.TI, infoPtr, - infoPtr->reader.readyEvent), 0, NULL); + chanInfoPtr->flags |= CONSOLE_READ_OPS; + GetConsoleMode(handle, &chanInfoPtr->initMode); + +#ifdef OBSOLETE + /* Why was priority being set on console input? Code smell */ SetThreadPriority(infoPtr->reader.thread, THREAD_PRIORITY_HIGHEST); +#endif + } + else { + /* Already checked permissions is WRITABLE if not READABLE */ + /* TODO - enable ansi escape processing? */ } - if (permissions & TCL_WRITABLE) { + /* + * Global lock but that's ok. See comments top of file. Allocations + * will happen only a few times in the life of a process and that too + * generally at start up where only one thread is active. + */ + AcquireSRWLockExclusive(&gConsoleLock); /*Allocate needs exclusive lock */ - infoPtr->writer.readyEvent = CreateEventW(NULL, TRUE, TRUE, NULL); - infoPtr->writer.thread = CreateThread(NULL, 256, ConsoleWriterThread, - TclPipeThreadCreateTI(&infoPtr->writer.TI, infoPtr, - infoPtr->writer.readyEvent), 0, NULL); - SetThreadPriority(infoPtr->writer.thread, THREAD_PRIORITY_HIGHEST); + handleInfoPtr = FindConsoleInfo(chanInfoPtr); + if (handleInfoPtr == NULL) { + /* Not found. Allocate one */ + handleInfoPtr = AllocateConsoleHandleInfo(handle, permissions); + } + else { + /* Found. Its direction (read/write) better be the same */ + if (handleInfoPtr->permissions != permissions) { + handleInfoPtr = NULL; + } + } + + if (handleInfoPtr == NULL) { + ReleaseSRWLockExclusive(&gConsoleLock); + if (permissions == TCL_READABLE) { + SetConsoleMode(handle, chanInfoPtr->initMode); + } + ckfree(chanInfoPtr); + return NULL; } /* + * There is effectively a reference to this structure from the Tcl + * channel subsystem. So record that. This reference will be dropped + * when the Tcl channel is closed. + */ + chanInfoPtr->numRefs = 1; + + /* + * Need to keep track of number of referencing channels for closing. + * The pointer is safe since there is a reference held to it from + * gConsoleHandleInfoList but still need to lock the structure itself + */ + AcquireSRWLockExclusive(&handleInfoPtr->lock); + handleInfoPtr->numRefs += 1; + ReleaseSRWLockExclusive(&handleInfoPtr->lock); + + ReleaseSRWLockExclusive(&gConsoleLock); + + /* Note Tcl_CreateChannel never fails other than panic on error */ + chanInfoPtr->channel = Tcl_CreateChannel(&consoleChannelType, channelName, + chanInfoPtr, permissions); + + /* * Files have default translation of AUTO and ^Z eof char, which means * that a ^Z will be accepted as EOF when reading. */ - Tcl_SetChannelOption(NULL, infoPtr->channel, "-translation", "auto"); - Tcl_SetChannelOption(NULL, infoPtr->channel, "-eofchar", "\032 {}"); - Tcl_SetChannelOption(NULL, infoPtr->channel, "-encoding", "utf-16"); - return infoPtr->channel; + Tcl_SetChannelOption(NULL, chanInfoPtr->channel, "-translation", "auto"); + Tcl_SetChannelOption(NULL, chanInfoPtr->channel, "-eofchar", "\032 {}"); + Tcl_SetChannelOption(NULL, chanInfoPtr->channel, "-encoding", "utf-16"); + return chanInfoPtr->channel; } /* @@ -1410,33 +2065,16 @@ ConsoleThreadActionProc( ClientData instanceData, int action) { - ConsoleInfo *infoPtr = (ConsoleInfo *)instanceData; - - /* - * We do not access firstConsolePtr in the thread structures. This is not - * for all serials managed by the thread, but only those we are watching. - * Removal of the filevent handlers before transfer thus takes care of - * this structure. - */ + ConsoleChannelInfo *chanInfoPtr = (ConsoleChannelInfo *)instanceData; - Tcl_MutexLock(&consoleMutex); + /* No need for any locks as no other thread will be writing to it */ if (action == TCL_CHANNEL_THREAD_INSERT) { - /* - * We can't copy the thread information from the channel when the - * channel is created. At this time the channel back pointer has not - * been set yet. However in that case the threadId has already been - * set by TclpCreateCommandChannel itself, so the structure is still - * good. - */ - - ConsoleInit(); - if (infoPtr->channel != NULL) { - infoPtr->threadId = Tcl_GetChannelThread(infoPtr->channel); - } - } else { - infoPtr->threadId = NULL; + ConsoleInit(); /* Needed to set up event source handlers for this thread */ + chanInfoPtr->threadId = Tcl_GetCurrentThread(); + } + else { + chanInfoPtr->threadId = NULL; } - Tcl_MutexUnlock(&consoleMutex); } /* @@ -1456,7 +2094,6 @@ ConsoleThreadActionProc( * *---------------------------------------------------------------------- */ - static int ConsoleSetOptionProc( ClientData instanceData, /* File state. */ @@ -1464,7 +2101,7 @@ ConsoleSetOptionProc( const char *optionName, /* Which option to set? */ const char *value) /* New value for option. */ { - ConsoleInfo *infoPtr = (ConsoleInfo *)instanceData; + ConsoleChannelInfo *chanInfoPtr = (ConsoleChannelInfo *)instanceData; int len = strlen(optionName); int vlen = strlen(value); @@ -1472,11 +2109,11 @@ ConsoleSetOptionProc( * Option -inputmode normal|password|raw */ - if ((infoPtr->flags & CONSOLE_READ_OPS) && (len > 1) && + if ((chanInfoPtr->flags & CONSOLE_READ_OPS) && (len > 1) && (strncmp(optionName, "-inputmode", len) == 0)) { DWORD mode; - if (GetConsoleMode(infoPtr->handle, &mode) == 0) { + if (GetConsoleMode(chanInfoPtr->handle, &mode) == 0) { Tcl_WinConvertError(GetLastError()); if (interp != NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( @@ -1496,8 +2133,7 @@ ConsoleSetOptionProc( /* * Reset to the initial mode, whatever that is. */ - - mode = infoPtr->initMode; + mode = chanInfoPtr->initMode; } else { if (interp) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( @@ -1508,7 +2144,7 @@ ConsoleSetOptionProc( } return TCL_ERROR; } - if (SetConsoleMode(infoPtr->handle, mode) == 0) { + if (SetConsoleMode(chanInfoPtr->handle, mode) == 0) { Tcl_WinConvertError(GetLastError()); if (interp != NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( @@ -1518,19 +2154,10 @@ ConsoleSetOptionProc( return TCL_ERROR; } - /* - * If we've changed the mode from default, schedule a reset later. - */ - - if (mode == infoPtr->initMode) { - infoPtr->flags &= ~CONSOLE_RESET; - } else { - infoPtr->flags |= CONSOLE_RESET; - } return TCL_OK; } - if (infoPtr->flags & CONSOLE_READ_OPS) { + if (chanInfoPtr->flags & CONSOLE_READ_OPS) { return Tcl_BadChannelOption(interp, optionName, "inputmode"); } else { return Tcl_BadChannelOption(interp, optionName, ""); @@ -1562,7 +2189,7 @@ ConsoleGetOptionProc( const char *optionName, /* Option to get. */ Tcl_DString *dsPtr) /* Where to store value(s). */ { - ConsoleInfo *infoPtr = (ConsoleInfo *)instanceData; + ConsoleChannelInfo *chanInfoPtr = (ConsoleChannelInfo *)instanceData; int valid = 0; /* Flag if valid option parsed. */ unsigned int len; char buf[TCL_INTEGER_SPACE]; @@ -1580,7 +2207,7 @@ ConsoleGetOptionProc( * represents what almost all scripts really want to know. */ - if (infoPtr->flags & CONSOLE_READ_OPS) { + if (chanInfoPtr->flags & CONSOLE_READ_OPS) { if (len == 0) { Tcl_DStringAppendElement(dsPtr, "-inputmode"); } @@ -1588,7 +2215,7 @@ ConsoleGetOptionProc( DWORD mode; valid = 1; - if (GetConsoleMode(infoPtr->handle, &mode) == 0) { + if (GetConsoleMode(chanInfoPtr->handle, &mode) == 0) { Tcl_WinConvertError(GetLastError()); if (interp != NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( @@ -1619,7 +2246,7 @@ ConsoleGetOptionProc( CONSOLE_SCREEN_BUFFER_INFO consoleInfo; valid = 1; - if (!GetConsoleScreenBufferInfo(infoPtr->handle, &consoleInfo)) { + if (!GetConsoleScreenBufferInfo(chanInfoPtr->handle, &consoleInfo)) { Tcl_WinConvertError(GetLastError()); if (interp != NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( @@ -1639,7 +2266,7 @@ ConsoleGetOptionProc( if (valid) { return TCL_OK; } - if (infoPtr->flags & CONSOLE_READ_OPS) { + if (chanInfoPtr->flags & CONSOLE_READ_OPS) { return Tcl_BadChannelOption(interp, optionName, "inputmode winsize"); } else { return Tcl_BadChannelOption(interp, optionName, ""); -- cgit v0.12 From 0472b619fbc768a10d329b4a3b23ea32370a8d7e Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 28 Jun 2022 09:38:00 +0000 Subject: typo's --- unix/dltest/pkgooa.c | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/unix/dltest/pkgooa.c b/unix/dltest/pkgooa.c index 8dea0aa..9f78da8 100644 --- a/unix/dltest/pkgooa.c +++ b/unix/dltest/pkgooa.c @@ -109,7 +109,7 @@ Pkgooa_Init( return TCL_ERROR; } if (tclStubsPtr == NULL) { - Tcl_AppendResult(interp, "Tcl stubs are not inialized, " + Tcl_AppendResult(interp, "Tcl stubs are not initialized, " "did you compile using -DUSE_TCL_STUBS? "); return TCL_ERROR; } @@ -117,11 +117,11 @@ Pkgooa_Init( return TCL_ERROR; } if (tclOOStubsPtr == NULL) { - Tcl_AppendResult(interp, "TclOO stubs are not inialized"); + Tcl_AppendResult(interp, "TclOO stubs are not initialized"); return TCL_ERROR; } if (tclOOIntStubsPtr == NULL) { - Tcl_AppendResult(interp, "TclOO internal stubs are not inialized"); + Tcl_AppendResult(interp, "TclOO internal stubs are not initialized"); return TCL_ERROR; } -- cgit v0.12 From 5f73d7d78e86e4238433c90d99e0d346c0fc6728 Mon Sep 17 00:00:00 2001 From: apnadkarni Date: Tue, 28 Jun 2022 15:42:14 +0000 Subject: Finishing touches. Remove obsolete code --- win/tclWinConsole.c | 401 +++++++++++++++++++++++----------------------------- 1 file changed, 177 insertions(+), 224 deletions(-) diff --git a/win/tclWinConsole.c b/win/tclWinConsole.c index 14cc6e5..08e7e56 100644 --- a/win/tclWinConsole.c +++ b/win/tclWinConsole.c @@ -10,7 +10,6 @@ * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ -#define TCL_CONSOLE_DEBUG #ifdef TCL_CONSOLE_DEBUG #undef NDEBUG /* Enable asserts */ #endif @@ -55,7 +54,14 @@ static int initialized = 0; -#define CONSOLE_BUFFER_SIZE 8000 // TODO - must be at least 2 :-) +#ifdef TCL_CONSOLE_DEBUG +#ifndef CONSOLE_BUFFER_SIZE +/* Force tiny to stress synchronization. Must be at least sizeof(WCHAR) :-) */ +#define CONSOLE_BUFFER_SIZE 10 +#endif +#else +#define CONSOLE_BUFFER_SIZE 4000 /* In bytes */ +#endif /* * Ring buffer for storing data. Actual data is from bufPtr[start]:bufPtr[size-1] @@ -227,9 +233,7 @@ static ConsoleHandleInfo *AllocateConsoleHandleInfo(HANDLE consoleHandle, static ConsoleHandleInfo *FindConsoleInfo(const ConsoleChannelInfo *); static DWORD WINAPI ConsoleReaderThread(LPVOID arg); static DWORD WINAPI ConsoleWriterThread(LPVOID arg); -#ifdef OBSOLETE -static int WaitForRead(ConsoleChannelInfo *infoPtr, int blocking); -#endif +static void NudgeWatchers(HANDLE consoleHandle); /* * Static data. @@ -251,10 +255,6 @@ static Tcl_ThreadDataKey dataKey; * likely not only complicate implementation but be slower due to multiple * locks being held. Note console channels also differ from other Tcl * channel types in that the channel<->OS descriptor mapping is not one-to-one. - * - * The gConsoleLock locks around access to the initialized variable, and it - * is used to protect background threads from being terminated while they - * are using APIs that hold locks. TBD - is this still true? */ SRWLOCK gConsoleLock; @@ -374,7 +374,6 @@ RingBufferIn( ) { RingSizeT freeSpace; - RingSizeT endSpace; RINGBUFFER_ASSERT(ringPtr); @@ -387,23 +386,25 @@ RingBufferIn( srcLen = freeSpace; } - /* Copy as much as possible to the tail */ if (ringPtr->capacity - ringPtr->start > ringPtr->length) { /* There is room at the back */ RingSizeT endSpaceStart = ringPtr->start + ringPtr->length; - endSpace = ringPtr->capacity - endSpaceStart; - if (endSpace > srcLen) { - endSpace = srcLen; + RingSizeT endSpace = ringPtr->capacity - endSpaceStart; + if (endSpace >= srcLen) { + /* Everything fits at the back */ + memmove(endSpaceStart + ringPtr->bufPtr, srcPtr, srcLen); + } + else { + /* srcLen > endSpace */ + memmove(endSpaceStart + ringPtr->bufPtr, srcPtr, endSpace); + memmove(ringPtr->bufPtr, endSpace + srcPtr, srcLen - endSpace); } - memmove(endSpaceStart + ringPtr->bufPtr, srcPtr, endSpace); } else { - endSpace = 0; - } - - /* Wrap around any left over data. Have already copied endSpace bytes */ - if (srcLen > endSpace) { - memmove(ringPtr->bufPtr, endSpace + srcPtr, srcLen - endSpace); + /* No room at the back. Existing data wrap to front. */ + RingSizeT wrapLen = + ringPtr->start + ringPtr->length - ringPtr->capacity; + memmove(wrapLen + ringPtr->bufPtr, srcPtr, srcLen); } ringPtr->length += srcLen; @@ -716,6 +717,43 @@ ProcExitHandler( } /* + *------------------------------------------------------------------------ + * + * NudgeWatchers -- + * + * Wakes up all threads which have file event watchers on the passed + * console handle. + * + * The function locks and releases gConsoleLock. + * Caller must not be holding locks that will violate lock hierarchy. + * + * Results: + * None. + * + * Side effects: + * As above. + *------------------------------------------------------------------------ + */ +void NudgeWatchers (HANDLE consoleHandle) +{ + ConsoleChannelInfo *chanInfoPtr; + AcquireSRWLockShared(&gConsoleLock); /* Shared-read lock */ + for (chanInfoPtr = gWatchingChannelList; chanInfoPtr; + chanInfoPtr = chanInfoPtr->nextWatchingChannelPtr) { + /* + * Notify channels interested in our handle AND that have + * a thread attached. + * No lock needed for chanInfoPtr. See ConsoleChannelInfo. + */ + if (chanInfoPtr->handle == consoleHandle + && chanInfoPtr->threadId != NULL) { + Tcl_ThreadAlert(chanInfoPtr->threadId); + } + } + ReleaseSRWLockShared(&gConsoleLock); +} + +/* *---------------------------------------------------------------------- * * ConsoleSetupProc -- @@ -760,10 +798,12 @@ ConsoleSetupProc( if (handleInfoPtr != NULL) { AcquireSRWLockShared(&handleInfoPtr->lock); if ((chanInfoPtr->watchMask & TCL_READABLE) - && RingBufferLength(&handleInfoPtr->buffer) > 0) { + && (RingBufferLength(&handleInfoPtr->buffer) > 0 + || handleInfoPtr->lastError != ERROR_SUCCESS)) { block = 0; /* Input data available */ } else if (RingBufferFreeSpace(&handleInfoPtr->buffer) > 0) { + /* TCL_WRITABLE */ block = 0; /* Output space available */ } ReleaseSRWLockShared(&handleInfoPtr->lock); @@ -837,8 +877,9 @@ ConsoleCheckProc( if (handleInfoPtr != NULL) { AcquireSRWLockShared(&handleInfoPtr->lock); if ((chanInfoPtr->watchMask & TCL_READABLE) - && RingBufferLength(&handleInfoPtr->buffer) > 0) { - needEvent = 1; /* Input data available */ + && (RingBufferLength(&handleInfoPtr->buffer) > 0 + || handleInfoPtr->lastError != ERROR_SUCCESS)) { + needEvent = 1; /* Input data available or error/EOF */ } else if (RingBufferFreeSpace(&handleInfoPtr->buffer) > 0) { needEvent = 1; /* Output space available */ @@ -974,7 +1015,7 @@ ConsoleCloseProc( * Don't close the Win32 handle if the handle is a standard channel * during the thread exit process. Otherwise, one thread may kill the * stdio of another. TODO - an explicit close in script will still close - * it. + * it. Is that desired behavior? */ if (!TclInThreadExit() || ((GetStdHandle(STD_INPUT_HANDLE) != chanInfoPtr->handle) @@ -1050,8 +1091,8 @@ ConsoleInputProc( /* * No data available. * - If an error was recorded, generate that and reset it. - * - If EOF, indicate as much. TODO - can console thread still be - * running in that case? + * - If EOF, indicate as much. It is up to application to close + * the channel. * - Otherwise, if non-blocking return EAGAIN or wait for more data. */ if (handleInfoPtr->lastError != 0) { @@ -1374,112 +1415,6 @@ ConsoleGetHandleProc( return TCL_OK; } -#ifdef OBSOLETE -/* - *---------------------------------------------------------------------- - * - * WaitForRead -- - * - * Wait until some data is available, the console is at EOF or the reader - * thread is blocked waiting for data (if the channel is in non-blocking - * mode). - * - * Results: - * Returns 1 if console is readable. Returns 0 if there is no data on the - * console, but there is buffered data. Returns -1 if an error occurred. - * If an error occurred, the threads may not be synchronized. - * - * Side effects: - * Updates the shared state flags. If no error occurred, the reader - * thread is blocked waiting for a signal from the main thread. - * - *---------------------------------------------------------------------- - */ - -static int -WaitForRead( - ConsoleChannelInfo *infoPtr, /* Console state. */ - int blocking) /* Indicates whether call should be blocking - * or not. */ -{ - DWORD timeout, count; - HANDLE *handle = (HANDLE *)infoPtr->handle; - ConsoleThreadInfo *threadInfo = &infoPtr->reader; - INPUT_RECORD input; - - while (1) { - /* - * Synchronize with the reader thread. - */ - - /* avoid blocking if pipe-thread exited */ - timeout = (!blocking || !TclPipeThreadIsAlive(&threadInfo->TI) - || TclInExit() || TclInThreadExit()) ? 0 : INFINITE; - if (WaitForSingleObject(threadInfo->readyEvent, timeout) == WAIT_TIMEOUT) { - /* - * The reader thread is blocked waiting for data and the channel - * is in non-blocking mode. - */ - - errno = EWOULDBLOCK; - return -1; - } - - /* - * At this point, the two threads are synchronized, so it is safe to - * access shared state. - */ - - /* - * If the console has hit EOF, it is always readable. - */ - - if (infoPtr->readFlags & CONSOLE_EOF) { - return 1; - } - - if (PeekConsoleInputW(handle, &input, 1, &count) == FALSE) { - /* - * Check to see if the peek failed because of EOF. - */ - - Tcl_WinConvertError(GetLastError()); - - if (errno == EOF) { - infoPtr->readFlags |= CONSOLE_EOF; - return 1; - } - - /* - * Ignore errors if there is data in the buffer. - */ - - if (infoPtr->readFlags & CONSOLE_BUFFERED) { - return 0; - } else { - return -1; - } - } - - /* - * If there is data in the buffer, the console must be readable (since - * it is a line-oriented device). - */ - - if (infoPtr->readFlags & CONSOLE_BUFFERED) { - return 1; - } - - /* - * There wasn't any data available, so reset the thread and try again. - */ - - ResetEvent(threadInfo->readyEvent); - TclPipeThreadSignal(&threadInfo->TI); - } -} -#endif - /* *---------------------------------------------------------------------- * @@ -1526,48 +1461,74 @@ ConsoleReaderThread( while (1) { if (handleInfoPtr->numRefs == 1) { - /* Sole reference. That's this thread. Exit since no one clients */ + /* + * Sole reference. That's this thread. Exit since no clients + * and no way for a thread to attach to a console after process + * start. + */ break; } + /* + * Cases: + * (1) The shared input buffer is full. Have to wait for an interp + * thread to read from it and make room. + * (2) The shared input buffer has room and the thread private buffer + * has data. Copy into the shared input buffer. + * (3) The channel has previously seen an error. Treat as EOF. Note + * this check is after the above so any data already available + * is passed on. + * (4) Neither buffer has data and no errors. Go get some from console. + * + * There is some duplication of code below but easier to think about + * rather than combining cases. + */ if (RingBufferFreeSpace(&handleInfoPtr->buffer) == 0) { - /* No room in buffer. Awaken any reader channels */ + /* Case (1) No room in buffer.*/ + + /* Awaken any reader channels - TODO - is this really needed? */ WakeConditionVariable(&handleInfoPtr->interpThreadCV); - /* XXX - does not wake up fileevent channels! */ /* Release lock and wait for room */ success = SleepConditionVariableSRW(&handleInfoPtr->consoleThreadCV, &handleInfoPtr->lock, INFINITE, 0); - /* Note: lock has been acquired again! */ + /* Note: lock has been reacquired */ if (!success && GetLastError() != ERROR_TIMEOUT) { /* TODO - what can be done? Should not happen */ /* For now keep going */ } - continue; /* Restart loop so we can check for exit conditions */ - } - - /* - * The shared buffer now has room. If we had any leftover from last - * read, store that. - */ - if (inputLen > 0) { - RingSizeT nStored; + } else if (inputLen > 0 || handleInfoPtr->lastError != 0) { + /* Cases (2) and (3) - require notifications to interpreters */ HANDLE consoleHandle; - ConsoleChannelInfo *chanInfoPtr; - - nStored = RingBufferIn(&handleInfoPtr->buffer, - inputOffset + inputChars, - inputLen - inputOffset, - 1); - inputOffset += nStored; - if (inputOffset == inputLen) { - /* Temp buffer now empty */ - inputOffset = 0; - inputLen = 0; + if (inputLen > 0) { + /* + * Case (2). Private buffer has data. Copy it over. + */ + RingSizeT nStored; + + assert((inputLen - inputOffset) > 0); + + nStored = RingBufferIn(&handleInfoPtr->buffer, + inputOffset + inputChars, + inputLen - inputOffset, + 1); + inputOffset += nStored; + if (inputOffset == inputLen) { + /* Temp buffer now empty */ + inputOffset = 0; + inputLen = 0; + } } + else { + /* + * Case (3). On error, nothing but inform caller and wait + * We do not want to exit until there are no client interps. + */ + } + /* Wake up any threads waiting synchronously. */ WakeConditionVariable(&handleInfoPtr->interpThreadCV); @@ -1578,38 +1539,33 @@ ConsoleReaderThread( * relock it. */ consoleHandle = handleInfoPtr->console; + /* + * Wake up all channels registered for file events. Note in + * order to follow the locking hierarchy, we cannot hold any locks + * when calling NudgeWatchers. + */ ReleaseSRWLockExclusive(&handleInfoPtr->lock); - AcquireSRWLockShared(&gConsoleLock); /* Shared-read lock */ - for (chanInfoPtr = gWatchingChannelList; chanInfoPtr; - chanInfoPtr = chanInfoPtr->nextWatchingChannelPtr) { - /* - * Notify channels interested in our handle AND that have - * a thread attached. - * No lock needed for chanInfoPtr. See ConsoleChannelInfo. - */ - if (chanInfoPtr->handle == consoleHandle - && chanInfoPtr->threadId != NULL) { - Tcl_ThreadAlert(chanInfoPtr->threadId); - } + NudgeWatchers(consoleHandle); + + AcquireSRWLockExclusive(&handleInfoPtr->lock); + } + else { + /* + * Case (4). Need to go get more data from console. We only + * store the last error. It is up to channel handlers to decide + * whether to close or what to do. + */ + ReleaseSRWLockExclusive(&handleInfoPtr->lock); + handleInfoPtr->lastError = + ReadConsoleChars(handleInfoPtr->console, + (WCHAR *)inputChars, + sizeof(inputChars) / sizeof(WCHAR), + &inputLen); + if (handleInfoPtr->lastError == 0) { + inputLen *= sizeof(WCHAR); } - ReleaseSRWLockShared(&gConsoleLock); AcquireSRWLockExclusive(&handleInfoPtr->lock); - continue; /* Restart loop */ } - - /* - * Need to go get more data from console. We only store the last - * error. It is up to channel handlers to decide whether to close or - * what to do. - */ - ReleaseSRWLockExclusive(&handleInfoPtr->lock); - handleInfoPtr->lastError = - ReadConsoleChars(handleInfoPtr->console, - (WCHAR *)inputChars, - sizeof(inputChars) / sizeof(WCHAR), - &inputLen); - inputLen *= sizeof(WCHAR); - AcquireSRWLockExclusive(&handleInfoPtr->lock); } /* @@ -1617,6 +1573,8 @@ ConsoleReaderThread( * - remove the console from global list * - close the handle if still valid * - release the structure + * Note there is not need to check for any watchers because we only + * exit when there are no channels open to this console. */ ReleaseSRWLockExclusive(&handleInfoPtr->lock); AcquireSRWLockExclusive(&gConsoleLock); /* Modifying - exclusive lock */ @@ -1632,14 +1590,15 @@ ConsoleReaderThread( /* No need for relocking - no other thread should have access to it now */ RingBufferClear(&handleInfoPtr->buffer); - if (handleInfoPtr->console) { + if (handleInfoPtr->console + && handleInfoPtr->lastError != ERROR_INVALID_HANDLE) { SetConsoleMode(handleInfoPtr->console, handleInfoPtr->initMode); + /* + * NOTE: we do not call CloseHandle(handleInfoPtr->console) + * As per the GetStdHandle documentation, it need not be closed. + * TODO - what about when application closes and re-opens? - Test + */ } - /* - * NOTE: we do not call CloseHandle(handleInfoPtr->console) - * As per the GetStdHandle documentation, it need not be closed. - * TODO - what about when application closes and re-opens? - Test - */ ckfree(handleInfoPtr); @@ -1669,8 +1628,13 @@ ConsoleWriterThread(LPVOID arg) ConsoleHandleInfo **iterator; ConsoleChannelInfo *chanInfoPtr = NULL; BOOL success; - char buffer[4000]; - RingSizeT length; + RingSizeT numBytes; + /* + * This buffer size has no relation really with the size of the shared + * buffer. Could be bigger or smaller. Make larger as multiple threads + * could potentially be writing to it. + */ + char buffer[2*CONSOLE_BUFFER_SIZE]; /* * Keep looping until one of the following happens. @@ -1698,9 +1662,9 @@ ConsoleWriterThread(LPVOID arg) * WCHAR's, i.e. even number of chars so do some length checks up * front. */ - length = RingBufferLength(&handleInfoPtr->buffer); - length &= ~1; /* Copy integral number of WCHARs -> even number of bytes */ - if (length == 0) { + numBytes = RingBufferLength(&handleInfoPtr->buffer); + numBytes &= ~1; /* Copy integral number of WCHARs -> even number of bytes */ + if (numBytes == 0) { /* No data to write */ if (handleInfoPtr->numRefs == 1) { /* @@ -1724,20 +1688,23 @@ ConsoleWriterThread(LPVOID arg) } /* We have data to write */ - if (length > (sizeof(buffer) / sizeof(buffer[0]))) { - length = sizeof(buffer); + if (numBytes > (sizeof(buffer) / sizeof(buffer[0]))) { + numBytes = sizeof(buffer); } /* No need to check result, we already checked length bytes available */ - RingBufferOut(&handleInfoPtr->buffer, buffer, length, 0); + RingBufferOut(&handleInfoPtr->buffer, buffer, numBytes, 0); + consoleHandle = handleInfoPtr->console; WakeConditionVariable(&handleInfoPtr->interpThreadCV); ReleaseSRWLockExclusive(&handleInfoPtr->lock); offset = 0; - while (length > 0) { - RingSizeT numWChars = length / sizeof(WCHAR); + while (numBytes > 0) { + RingSizeT numWChars = numBytes / sizeof(WCHAR); DWORD status; - status = WriteConsoleChars( - handleInfoPtr->console, (WCHAR *) (offset + buffer) , numWChars, &numWChars); + status = WriteConsoleChars(handleInfoPtr->console, + (WCHAR *)(offset + buffer), + numWChars, + &numWChars); if (status != 0) { /* Only overwrite if no previous error */ if (handleInfoPtr->lastError == 0) { @@ -1749,33 +1716,19 @@ ConsoleWriterThread(LPVOID arg) */ break; } - length -= numWChars * sizeof(WCHAR); + numBytes -= numWChars * sizeof(WCHAR); offset += numWChars * sizeof(WCHAR); } + /* Wake up any threads waiting synchronously. */ + WakeConditionVariable(&handleInfoPtr->interpThreadCV); /* * Wake up all channels registered for file events. Note in - * order to follow the locking hierarchy, we need to release - * handleInfoPtr->lock before acquiring gConsoleLock and - * relock it. + * order to follow the locking hierarchy, we cannot hold any locks + * when calling NudgeWatchers. */ - /* Wake up any threads waiting synchronously. */ - WakeConditionVariable(&handleInfoPtr->interpThreadCV); - AcquireSRWLockShared(&gConsoleLock); /* Shared-read lock */ - consoleHandle = handleInfoPtr->console; - for (chanInfoPtr = gWatchingChannelList; chanInfoPtr; - chanInfoPtr = chanInfoPtr->nextWatchingChannelPtr) { - /* - * Notify channels interested in our handle AND that have - * a thread attached. - * No lock needed for chanInfoPtr. See ConsoleChannelInfo. - */ - if (chanInfoPtr->handle == consoleHandle - && chanInfoPtr->threadId != NULL) { - Tcl_ThreadAlert(chanInfoPtr->threadId); - } - } - ReleaseSRWLockShared(&gConsoleLock); + NudgeWatchers(consoleHandle); + AcquireSRWLockExclusive(&handleInfoPtr->lock); } -- cgit v0.12 From 71bdb52035482906a19b37a648b085fe8ab2fd24 Mon Sep 17 00:00:00 2001 From: apnadkarni Date: Wed, 29 Jun 2022 15:56:06 +0000 Subject: Notify other threads if one thread closes a Windows console channel --- win/tclWinConsole.c | 251 ++++++++++++++++++++++++++++++---------------------- 1 file changed, 143 insertions(+), 108 deletions(-) diff --git a/win/tclWinConsole.c b/win/tclWinConsole.c index 08e7e56..b360a17 100644 --- a/win/tclWinConsole.c +++ b/win/tclWinConsole.c @@ -60,7 +60,7 @@ static int initialized = 0; #define CONSOLE_BUFFER_SIZE 10 #endif #else -#define CONSOLE_BUFFER_SIZE 4000 /* In bytes */ +#define CONSOLE_BUFFER_SIZE 8000 /* In bytes */ #endif /* @@ -969,10 +969,26 @@ ConsoleCloseProc( ConsoleHandleInfo *handleInfoPtr; int errorCode = 0; ConsoleChannelInfo **nextPtrPtr; + int closeHandle; if ((flags & (TCL_CLOSE_READ | TCL_CLOSE_WRITE)) != 0) { return EINVAL; } + /* + * Don't close the Win32 handle if the handle is a standard channel + * during the thread exit process. Otherwise, one thread may kill the + * stdio of another while exiting. Note an explicit close in script will + * still close the handle. That's historical behavior on all platforms. + */ + if (!TclInThreadExit() + || ((GetStdHandle(STD_INPUT_HANDLE) != chanInfoPtr->handle) + && (GetStdHandle(STD_OUTPUT_HANDLE) != chanInfoPtr->handle) + && (GetStdHandle(STD_ERROR_HANDLE) != chanInfoPtr->handle))) { + closeHandle = 1; + } + else { + closeHandle = 0; + } AcquireSRWLockExclusive(&gConsoleLock); @@ -994,11 +1010,15 @@ ConsoleCloseProc( AcquireSRWLockShared(&handleInfoPtr->lock); handleInfoPtr->numRefs -= 1; /* Remove reference from this channel */ + handleInfoPtr->console = INVALID_HANDLE_VALUE; /* Break the thread out of blocking console i/o */ CancelSynchronousIo(handleInfoPtr->consoleThread); - /* Wake up the console handling thread */ + /* + * Wake up the console handling thread. Note we do not explicitly + * tell it handle is closed (below). It will find out on next access + */ WakeConditionVariable(&handleInfoPtr->consoleThreadCV); ReleaseSRWLockShared(&handleInfoPtr->lock); @@ -1006,27 +1026,16 @@ ConsoleCloseProc( ReleaseSRWLockExclusive(&gConsoleLock); - chanInfoPtr->channel = NULL; + chanInfoPtr->channel = NULL; chanInfoPtr->watchMask = 0; chanInfoPtr->permissions = 0; - if (chanInfoPtr->handle) { - /* - * Don't close the Win32 handle if the handle is a standard channel - * during the thread exit process. Otherwise, one thread may kill the - * stdio of another. TODO - an explicit close in script will still close - * it. Is that desired behavior? - */ - if (!TclInThreadExit() - || ((GetStdHandle(STD_INPUT_HANDLE) != chanInfoPtr->handle) - && (GetStdHandle(STD_OUTPUT_HANDLE) != chanInfoPtr->handle) - && (GetStdHandle(STD_ERROR_HANDLE) != chanInfoPtr->handle))) { - if (CloseHandle(chanInfoPtr->handle) == FALSE) { - Tcl_WinConvertError(GetLastError()); - errorCode = errno; - } + if (closeHandle && chanInfoPtr->handle != INVALID_HANDLE_VALUE) { + if (CloseHandle(chanInfoPtr->handle) == FALSE) { + Tcl_WinConvertError(GetLastError()); + errorCode = errno; } - chanInfoPtr->handle = NULL; + chanInfoPtr->handle = INVALID_HANDLE_VALUE; } /* @@ -1074,6 +1083,10 @@ ConsoleInputProc( ConsoleHandleInfo *handleInfoPtr; RingSizeT numRead; + if (chanInfoPtr->handle == INVALID_HANDLE_VALUE) { + return 0; /* EOF */ + } + *errorCode = 0; AcquireSRWLockShared(&gConsoleLock); @@ -1086,8 +1099,15 @@ ConsoleInputProc( AcquireSRWLockExclusive(&handleInfoPtr->lock); ReleaseSRWLockShared(&gConsoleLock); /* AFTER acquiring handleInfoPtr->lock */ - numRead = RingBufferOut(&handleInfoPtr->buffer, bufPtr, bufSize, 1); - while (numRead == 0) { + while (1) { + numRead = RingBufferOut(&handleInfoPtr->buffer, bufPtr, bufSize, 1); + /* + * Note: even if channel is closed or has an error, as long there is + * buffered data, we will pass it up. + */ + if (numRead != 0) { + break; + } /* * No data available. * - If an error was recorded, generate that and reset it. @@ -1096,47 +1116,43 @@ ConsoleInputProc( * - Otherwise, if non-blocking return EAGAIN or wait for more data. */ if (handleInfoPtr->lastError != 0) { - Tcl_WinConvertError(handleInfoPtr->lastError); - handleInfoPtr->lastError = 0; - *errorCode = Tcl_GetErrno(); - numRead = -1; + if (handleInfoPtr->lastError == ERROR_INVALID_HANDLE) { + numRead = 0; /* Treat as EOF */ + } + else { + Tcl_WinConvertError(handleInfoPtr->lastError); + handleInfoPtr->lastError = 0; + *errorCode = Tcl_GetErrno(); + numRead = -1; + } + break; } - else if (handleInfoPtr->console == NULL) { + if (handleInfoPtr->console == INVALID_HANDLE_VALUE) { /* EOF - break with numRead == 0 */ + chanInfoPtr->handle = INVALID_HANDLE_VALUE; break; } - else { - if (chanInfoPtr->flags & CONSOLE_ASYNC) { - *errorCode = EAGAIN; - numRead = -1; - } - else { - /* - * Release the lock and sleep. Note that because the channel - * holds a reference count on handleInfoPtr, it will not - * be deallocated while the lock is released. - */ - WakeConditionVariable(&handleInfoPtr->consoleThreadCV); - if (SleepConditionVariableSRW(&handleInfoPtr->interpThreadCV, - &handleInfoPtr->lock, - INFINITE, - 0)) { - /* - * Lock is reacquired. However, in the meanwhile another - * thread could have consumed data. So loop continues - * with check of numRead value. - */ - numRead = RingBufferOut( - &handleInfoPtr->buffer, bufPtr, bufSize, 1); - } - else { - /* Report the error */ - Tcl_WinConvertError(GetLastError()); - *errorCode = Tcl_GetErrno(); - numRead = -1; - } - } + if (chanInfoPtr->flags & CONSOLE_ASYNC) { + *errorCode = EAGAIN; + numRead = -1; + break; } + /* + * Release the lock and sleep. Note that because the channel + * holds a reference count on handleInfoPtr, it will not + * be deallocated while the lock is released. + */ + WakeConditionVariable(&handleInfoPtr->consoleThreadCV); + if (!SleepConditionVariableSRW(&handleInfoPtr->interpThreadCV, + &handleInfoPtr->lock, + INFINITE, + 0)) { + Tcl_WinConvertError(GetLastError()); + *errorCode = Tcl_GetErrno(); + numRead = -1; + break; + } + /* Lock is reacquired, loop back to try again */ } ReleaseSRWLockExclusive(&handleInfoPtr->lock); @@ -1173,6 +1189,12 @@ ConsoleOutputProc( *errorCode = 0; + if (chanInfoPtr->handle == INVALID_HANDLE_VALUE) { + /* Some other thread would have *previously* closed the stdio handle */ + *errorCode = EPIPE; + return -1; + } + AcquireSRWLockShared(&gConsoleLock); handleInfoPtr = FindConsoleInfo(chanInfoPtr); if (handleInfoPtr == NULL) { @@ -1184,52 +1206,50 @@ ConsoleOutputProc( AcquireSRWLockExclusive(&handleInfoPtr->lock); ReleaseSRWLockShared(&gConsoleLock); /* AFTER acquiring handleInfoPtr->lock */ - numWritten = RingBufferIn(&handleInfoPtr->buffer, buf, toWrite, 1); - while (numWritten < toWrite) { + /* Keep looping if until all written. Break out for async and errors */ + numWritten = 0; + while (1) { + /* Check for error and close on every loop. */ if (handleInfoPtr->lastError != 0) { Tcl_WinConvertError(handleInfoPtr->lastError); *errorCode = Tcl_GetErrno(); numWritten = -1; break; } - if (handleInfoPtr->console == NULL) { + if (handleInfoPtr->console == INVALID_HANDLE_VALUE) { *errorCode = EPIPE; + chanInfoPtr->handle = INVALID_HANDLE_VALUE; numWritten = -1; break; } - if (chanInfoPtr->flags & CONSOLE_ASYNC) { - /* Async, just accept whatever was written */ + + numWritten += RingBufferIn( + &handleInfoPtr->buffer, numWritten + buf, toWrite - numWritten, 1); + if (numWritten == toWrite || chanInfoPtr->flags & CONSOLE_ASYNC) { + /* All done or async, just accept whatever was written */ break; } - else { - /* - * Release the lock and sleep. Note that because the channel - * holds a reference count on handleInfoPtr, it will not - * be deallocated while the lock is released. - */ - WakeConditionVariable(&handleInfoPtr->consoleThreadCV); - if (SleepConditionVariableSRW(&handleInfoPtr->interpThreadCV, - &handleInfoPtr->lock, - INFINITE, - 0)) { - /* Lock is reacquired. Continue loop */ - numWritten += RingBufferIn(&handleInfoPtr->buffer, - numWritten + buf, - toWrite - numWritten, - 1); - } - else { - /* Report the error */ - Tcl_WinConvertError(GetLastError()); - *errorCode = Tcl_GetErrno(); - numWritten = -1; - break; - } + /* + * Release the lock and sleep. Note that because the channel + * holds a reference count on handleInfoPtr, it will not + * be deallocated while the lock is released. + */ + WakeConditionVariable(&handleInfoPtr->consoleThreadCV); + if (!SleepConditionVariableSRW(&handleInfoPtr->interpThreadCV, + &handleInfoPtr->lock, + INFINITE, + 0)) { + /* Report the error */ + Tcl_WinConvertError(GetLastError()); + *errorCode = Tcl_GetErrno(); + numWritten = -1; + break; } + /* Lock is reacquired. Continue loop */ } - ReleaseSRWLockExclusive(&handleInfoPtr->lock); WakeConditionVariable(&handleInfoPtr->consoleThreadCV); + ReleaseSRWLockExclusive(&handleInfoPtr->lock); return numWritten; } @@ -1317,7 +1337,6 @@ ConsoleEventProc( else { assert(chanInfoPtr->channel == NULL); freeChannel = 1; - ckfree(chanInfoPtr); } ReleaseSRWLockShared(&gConsoleLock); @@ -1411,8 +1430,13 @@ ConsoleGetHandleProc( { ConsoleChannelInfo *chanInfoPtr = (ConsoleChannelInfo *)instanceData; - *handlePtr = chanInfoPtr->handle; - return TCL_OK; + if (chanInfoPtr->handle == INVALID_HANDLE_VALUE) { + return TCL_ERROR; + } + else { + *handlePtr = chanInfoPtr->handle; + return TCL_OK; + } } /* @@ -1555,16 +1579,22 @@ ConsoleReaderThread( * store the last error. It is up to channel handlers to decide * whether to close or what to do. */ + DWORD error; ReleaseSRWLockExclusive(&handleInfoPtr->lock); - handleInfoPtr->lastError = - ReadConsoleChars(handleInfoPtr->console, - (WCHAR *)inputChars, - sizeof(inputChars) / sizeof(WCHAR), - &inputLen); - if (handleInfoPtr->lastError == 0) { + error = ReadConsoleChars(handleInfoPtr->console, + (WCHAR *)inputChars, + sizeof(inputChars) / sizeof(WCHAR), + &inputLen); + AcquireSRWLockExclusive(&handleInfoPtr->lock); + if (error == 0) { inputLen *= sizeof(WCHAR); } - AcquireSRWLockExclusive(&handleInfoPtr->lock); + else { + handleInfoPtr->lastError = error; + if (handleInfoPtr->lastError == ERROR_INVALID_HANDLE) { + handleInfoPtr->console = INVALID_HANDLE_VALUE; + } + } } } @@ -1590,13 +1620,15 @@ ConsoleReaderThread( /* No need for relocking - no other thread should have access to it now */ RingBufferClear(&handleInfoPtr->buffer); - if (handleInfoPtr->console + if (handleInfoPtr->console != INVALID_HANDLE_VALUE && handleInfoPtr->lastError != ERROR_INVALID_HANDLE) { SetConsoleMode(handleInfoPtr->console, handleInfoPtr->initMode); /* - * NOTE: we do not call CloseHandle(handleInfoPtr->console) + * NOTE: we do not call CloseHandle(handleInfoPtr->console) here. * As per the GetStdHandle documentation, it need not be closed. - * TODO - what about when application closes and re-opens? - Test + * Other components may be directly using it. Note however that + * an explicit chan close script command does close the handle + * for all threads. */ } @@ -1710,9 +1742,13 @@ ConsoleWriterThread(LPVOID arg) if (handleInfoPtr->lastError == 0) { handleInfoPtr->lastError = status; } + if (status == ERROR_INVALID_HANDLE) { + handleInfoPtr->console = INVALID_HANDLE_VALUE; + } /* Assume this write is done but keep looping in case * it is a transient error. Not sure just closing handle - * and exiting thread is a good idea. + * and exiting thread is a good idea until all references + * from interp threads are gone. */ break; } @@ -1735,8 +1771,12 @@ ConsoleWriterThread(LPVOID arg) /* * Exiting: * - remove the console from global list - * - close the handle if still valid * - release the structure + * NOTE: we do not call CloseHandle(handleInfoPtr->console) here. + * As per the GetStdHandle documentation, it need not be closed. + * Other components may be directly using it. Note however that + * an explicit chan close script command does close the handle + * for all threads. */ ReleaseSRWLockExclusive(&handleInfoPtr->lock); AcquireSRWLockExclusive(&gConsoleLock); /* Modifying - exclusive lock */ @@ -1751,11 +1791,6 @@ ConsoleWriterThread(LPVOID arg) RingBufferClear(&handleInfoPtr->buffer); - /* - * NOTE: we do not call CloseHandle(handleInfoPtr->console) - * As per the GetStdHandle documentation, it need not be closed. - * TODO - what about when application closes and re-opens? - Test - */ ckfree(handleInfoPtr); @@ -1812,7 +1847,7 @@ AllocateConsoleHandleInfo( } handleInfoPtr->consoleThread = CreateThread( NULL, /* default security descriptor */ - 8192, /* Stack size - will get rounded up to allocation granularity */ + 2*CONSOLE_BUFFER_SIZE, /* Stack size - gets rounded up to granularity */ permissions == TCL_READABLE ? ConsoleReaderThread : ConsoleWriterThread, handleInfoPtr, /* Pass to thread */ 0, /* Flags - no special cases */ -- cgit v0.12 From 83253ae734a523f4c548f386cc890d065d6d3d1e Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 30 Jun 2022 11:31:15 +0000 Subject: Fix [b79df322a9]: Tcl_NewUnicodeObj truncates strings --- generic/tclStringObj.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/generic/tclStringObj.c b/generic/tclStringObj.c index 13d91d9..86b3937 100644 --- a/generic/tclStringObj.c +++ b/generic/tclStringObj.c @@ -564,7 +564,7 @@ Tcl_NewUnicodeObj( String *stringPtr = (String *)ckalloc((offsetof(String, unicode) + sizeof(unsigned short)) + numChars * sizeof(unsigned short)); - memcpy(stringPtr->unicode, unicode, numChars); + memcpy(stringPtr->unicode, unicode, numChars * sizeof(unsigned short)); stringPtr->unicode[numChars] = 0; stringPtr->numChars = numChars; -- cgit v0.12 From d51b6f7045d7043fa3ef9c8de6823a3b524ba50e Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 1 Jul 2022 14:55:42 +0000 Subject: TclOO version -> 1.3.0 --- generic/tclOO.c | 2 +- generic/tclOO.h | 6 +++--- tests/oo.test | 2 +- tests/ooNext2.test | 2 +- tests/ooUtil.test | 2 +- unix/tclooConfig.sh | 2 +- win/tclooConfig.sh | 2 +- 7 files changed, 9 insertions(+), 9 deletions(-) diff --git a/generic/tclOO.c b/generic/tclOO.c index 5051659..56423e1 100644 --- a/generic/tclOO.c +++ b/generic/tclOO.c @@ -137,7 +137,7 @@ static const Tcl_MethodType classConstructor = { * file). */ -static const char *initScript = +static const char initScript[] = #ifndef TCL_NO_DEPRECATED "package ifneeded TclOO " TCLOO_PATCHLEVEL " {# Already present, OK?};" #endif diff --git a/generic/tclOO.h b/generic/tclOO.h index dea1467..6f18491 100644 --- a/generic/tclOO.h +++ b/generic/tclOO.h @@ -24,8 +24,8 @@ * win/tclooConfig.sh */ -#define TCLOO_VERSION "1.2.0" -#define TCLOO_PATCHLEVEL TCLOO_VERSION +#define TCLOO_VERSION "1.3" +#define TCLOO_PATCHLEVEL TCLOO_VERSION ".0" #include "tcl.h" @@ -40,7 +40,7 @@ extern "C" { extern const char *TclOOInitializeStubs( Tcl_Interp *, const char *version); #define Tcl_OOInitStubs(interp) \ - TclOOInitializeStubs((interp), TCLOO_VERSION) + TclOOInitializeStubs((interp), TCLOO_PATCHLEVEL) #ifndef USE_TCL_STUBS # define TclOOInitializeStubs(interp, version) (TCLOO_PATCHLEVEL) #endif diff --git a/tests/oo.test b/tests/oo.test index 168baee..ff67cc1 100644 --- a/tests/oo.test +++ b/tests/oo.test @@ -7,7 +7,7 @@ # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. -package require tcl::oo 1.0.3 +package require tcl::oo 1.3.0 if {"::tcltest" ni [namespace children]} { package require tcltest 2.5 namespace import -force ::tcltest::* diff --git a/tests/ooNext2.test b/tests/ooNext2.test index 3d28f3f..746f9a5 100644 --- a/tests/ooNext2.test +++ b/tests/ooNext2.test @@ -7,7 +7,7 @@ # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. -package require tcl::oo 1.0.3 +package require tcl::oo 1.3.0 if {"::tcltest" ni [namespace children]} { package require tcltest 2.5 namespace import -force ::tcltest::* diff --git a/tests/ooUtil.test b/tests/ooUtil.test index 9a28c46..c8be9c8 100644 --- a/tests/ooUtil.test +++ b/tests/ooUtil.test @@ -9,7 +9,7 @@ # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. -package require tcl::oo 1.0.3 +package require tcl::oo 1.3.0 if {"::tcltest" ni [namespace children]} { package require tcltest 2.5 namespace import -force ::tcltest::* diff --git a/unix/tclooConfig.sh b/unix/tclooConfig.sh index 4c2068c..27efbe9 100644 --- a/unix/tclooConfig.sh +++ b/unix/tclooConfig.sh @@ -16,4 +16,4 @@ TCLOO_STUB_LIB_SPEC="" TCLOO_INCLUDE_SPEC="" TCLOO_PRIVATE_INCLUDE_SPEC="" TCLOO_CFLAGS="" -TCLOO_VERSION=1.2.0 +TCLOO_VERSION=1.3.0 diff --git a/win/tclooConfig.sh b/win/tclooConfig.sh index 4c2068c..27efbe9 100644 --- a/win/tclooConfig.sh +++ b/win/tclooConfig.sh @@ -16,4 +16,4 @@ TCLOO_STUB_LIB_SPEC="" TCLOO_INCLUDE_SPEC="" TCLOO_PRIVATE_INCLUDE_SPEC="" TCLOO_CFLAGS="" -TCLOO_VERSION=1.2.0 +TCLOO_VERSION=1.3.0 -- cgit v0.12 From 29ac91cbfe043b243eb5e67530bd1ec5b22b4f40 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 1 Jul 2022 15:14:15 +0000 Subject: Test for TclOO 1.1.0. Remove some useless type-casts --- generic/tclBasic.c | 2 +- generic/tclOO.c | 4 ++-- tests/oo.test | 2 +- tests/ooNext2.test | 2 +- 4 files changed, 5 insertions(+), 5 deletions(-) diff --git a/generic/tclBasic.c b/generic/tclBasic.c index 33a96eb..9243539 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -4577,7 +4577,7 @@ TEOV_PushExceptionHandlers( */ TclNRAddCallback(interp, TEOV_Error, INT2PTR(objc), - (ClientData) objv, NULL, NULL); + objv, NULL, NULL); } if (iPtr->numLevels == 1) { diff --git a/generic/tclOO.c b/generic/tclOO.c index 9a32543..043aa4c 100644 --- a/generic/tclOO.c +++ b/generic/tclOO.c @@ -136,7 +136,7 @@ static const Tcl_MethodType classConstructor = { * file). */ -static const char *initScript = +static const char initScript[] = "package ifneeded TclOO " TCLOO_PATCHLEVEL " {# Already present, OK?};" "namespace eval ::oo { variable version " TCLOO_VERSION " };" "namespace eval ::oo { variable patchlevel " TCLOO_PATCHLEVEL " };"; @@ -276,7 +276,7 @@ TclOOInit( } return Tcl_PkgProvideEx(interp, "TclOO", TCLOO_PATCHLEVEL, - (ClientData) &tclOOStubs); + &tclOOStubs); } /* diff --git a/tests/oo.test b/tests/oo.test index 0f58c5d..abd5d31 100644 --- a/tests/oo.test +++ b/tests/oo.test @@ -7,7 +7,7 @@ # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. -package require TclOO 1.0.3 +package require TclOO 1.1.0 if {"::tcltest" ni [namespace children]} { package require tcltest 2.5 namespace import -force ::tcltest::* diff --git a/tests/ooNext2.test b/tests/ooNext2.test index 0ec7cdd..74ba006 100644 --- a/tests/ooNext2.test +++ b/tests/ooNext2.test @@ -7,7 +7,7 @@ # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. -package require TclOO 1.0.3 +package require TclOO 1.1.0 if {"::tcltest" ni [namespace children]} { package require tcltest 2.5 namespace import -force ::tcltest::* -- cgit v0.12 From 22084be3ce76a5f408138f297d34ac259baf3051 Mon Sep 17 00:00:00 2001 From: apnadkarni Date: Sun, 3 Jul 2022 07:40:45 +0000 Subject: Eliminate unnecessary thread wakeups. --- win/tclWinConsole.c | 87 +++++++++++++++++++++++++++++++++++------------------ 1 file changed, 58 insertions(+), 29 deletions(-) diff --git a/win/tclWinConsole.c b/win/tclWinConsole.c index 5100bc1..d59e677 100644 --- a/win/tclWinConsole.c +++ b/win/tclWinConsole.c @@ -56,8 +56,11 @@ static int initialized = 0; #ifdef TCL_CONSOLE_DEBUG #ifndef CONSOLE_BUFFER_SIZE -/* Force tiny to stress synchronization. Must be at least sizeof(WCHAR) :-) */ -#define CONSOLE_BUFFER_SIZE sizeof(WCHAR) +/* + * Force tiny to stress synchronization. Must be at least 2*sizeof(WCHAR) :-) + * to work around Tcl channel bug https://core.tcl-lang.org/tcl/tktview/b3977d199b08e3979a8da970553d5209b3042e9c + */ +#define CONSOLE_BUFFER_SIZE (2*sizeof(WCHAR)) #endif #else #define CONSOLE_BUFFER_SIZE 8000 /* In bytes */ @@ -139,8 +142,7 @@ typedef struct ConsoleHandleInfo { * from under the console thread. Access to individual fields does not need * to be controlled because * - the console thread does not write to any fields - * - changes to the nextWatchingChannelPtr field and CONSOLE_EVENT_QUEUE - * bit flags are under the gConsoleLock lock + * - changes to the nextWatchingChannelPtr field * - changes to other fields do not matter because after being read for * queueing events, they are verified again when the event is received * in the interpreter thread (since they could have changed anyways while @@ -797,14 +799,18 @@ ConsoleSetupProc( handleInfoPtr = FindConsoleInfo(chanInfoPtr); if (handleInfoPtr != NULL) { AcquireSRWLockShared(&handleInfoPtr->lock); - if ((chanInfoPtr->watchMask & TCL_READABLE) - && (RingBufferLength(&handleInfoPtr->buffer) > 0 - || handleInfoPtr->lastError != ERROR_SUCCESS)) { - block = 0; /* Input data available */ + /* Remember at most one of READABLE, WRITABLE set */ + if (chanInfoPtr->watchMask & TCL_READABLE) { + if (RingBufferLength(&handleInfoPtr->buffer) > 0 + || handleInfoPtr->lastError != ERROR_SUCCESS) { + block = 0; /* Input data available */ + } } - else if (RingBufferFreeSpace(&handleInfoPtr->buffer) > 0) { - /* TCL_WRITABLE */ - block = 0; /* Output space available */ + else if (chanInfoPtr->watchMask & TCL_WRITABLE) { + if (RingBufferFreeSpace(&handleInfoPtr->buffer) > 0) { + /* TCL_WRITABLE */ + block = 0; /* Output space available */ + } } ReleaseSRWLockShared(&handleInfoPtr->lock); } @@ -876,13 +882,17 @@ ConsoleCheckProc( if (handleInfoPtr != NULL) { AcquireSRWLockShared(&handleInfoPtr->lock); - if ((chanInfoPtr->watchMask & TCL_READABLE) - && (RingBufferLength(&handleInfoPtr->buffer) > 0 - || handleInfoPtr->lastError != ERROR_SUCCESS)) { - needEvent = 1; /* Input data available or error/EOF */ + /* Rememebr channel is read or write, never both */ + if (chanInfoPtr->watchMask & TCL_READABLE) { + if (RingBufferLength(&handleInfoPtr->buffer) > 0 + || handleInfoPtr->lastError != ERROR_SUCCESS) { + needEvent = 1; /* Input data available or error/EOF */ + } } - else if (RingBufferFreeSpace(&handleInfoPtr->buffer) > 0) { - needEvent = 1; /* Output space available */ + else if (chanInfoPtr->watchMask & TCL_WRITABLE) { + if (RingBufferFreeSpace(&handleInfoPtr->buffer) > 0) { + needEvent = 1; /* Output space available */ + } } ReleaseSRWLockShared(&handleInfoPtr->lock); } @@ -1108,7 +1118,9 @@ ConsoleInputProc( */ if (numRead != 0) { /* If console thread was blocked, awaken it */ - WakeConditionVariable(&handleInfoPtr->consoleThreadCV); + if (freeSpace == 0) { + WakeConditionVariable(&handleInfoPtr->consoleThreadCV); + } break; } /* @@ -1209,10 +1221,10 @@ ConsoleOutputProc( AcquireSRWLockExclusive(&handleInfoPtr->lock); ReleaseSRWLockShared(&gConsoleLock); /* AFTER acquiring handleInfoPtr->lock */ - /* Keep looping if until all written. Break out for async and errors */ + /* Keep looping until all written. Break out for async and errors */ numWritten = 0; while (1) { - /* Check for error and close on every loop. */ + /* Check for error and closing on every loop. */ if (handleInfoPtr->lastError != 0) { Tcl_WinConvertError(handleInfoPtr->lastError); *errorCode = Tcl_GetErrno(); @@ -1286,6 +1298,7 @@ ConsoleEventProc( ConsoleEvent *consoleEvPtr = (ConsoleEvent *) evPtr; ConsoleChannelInfo *chanInfoPtr; int freeChannel; + int mask = 0; if (!(flags & TCL_FILE_EVENTS)) { return 0; @@ -1298,6 +1311,12 @@ ConsoleEventProc( * happens in this function. */ + /* + * Global lock used for chanInfoPtr. A read (shared) lock suffices + * because all access is within the channel owning thread with the + * exception of watchers which is a read-only access. See comments + * to ConsoleChannelInfo. + */ AcquireSRWLockShared(&gConsoleLock); chanInfoPtr->flags &= ~CONSOLE_EVENT_QUEUED; @@ -1308,7 +1327,6 @@ ConsoleEventProc( if (chanInfoPtr->channel && chanInfoPtr->threadId == Tcl_GetCurrentThread() && (chanInfoPtr->watchMask & (TCL_READABLE|TCL_WRITABLE))) { ConsoleHandleInfo *handleInfoPtr; - int mask = 0; handleInfoPtr = FindConsoleInfo(chanInfoPtr); if (handleInfoPtr == NULL) { /* Console was closed. EOF->read event only (not write) */ @@ -1318,20 +1336,33 @@ ConsoleEventProc( } else { AcquireSRWLockShared(&handleInfoPtr->lock); - if (chanInfoPtr->watchMask & TCL_READABLE + /* Remember at most one of READABLE, WRITABLE set */ + if ((chanInfoPtr->watchMask & TCL_READABLE) && RingBufferLength(&handleInfoPtr->buffer)) { mask = TCL_READABLE; } - else if (RingBufferFreeSpace(&handleInfoPtr->buffer)) { + else if ((chanInfoPtr->watchMask & TCL_WRITABLE) + && RingBufferFreeSpace(&handleInfoPtr->buffer) > 0) { /* Generate write event space available */ mask = TCL_WRITABLE; } ReleaseSRWLockShared(&handleInfoPtr->lock); } - if (mask) { - Tcl_NotifyChannel(chanInfoPtr->channel, mask); - } } + + /* + * Tcl_NotifyChannel can recurse through the file event callback so need + * to release locks first. Our reference still holds so no danger of + * chanInfoPtr being deallocated if the callback closes the channel. + */ + ReleaseSRWLockShared(&gConsoleLock); + if (mask) { + Tcl_NotifyChannel(chanInfoPtr->channel, mask); + /* Note: chanInfoPtr ref count may have changed */ + } + + /* No need to lock - see comments earlier */ + /* Remove the reference to the channel from event record */ if (chanInfoPtr->numRefs > 1) { chanInfoPtr->numRefs -= 1; @@ -1341,7 +1372,6 @@ ConsoleEventProc( assert(chanInfoPtr->channel == NULL); freeChannel = 1; } - ReleaseSRWLockShared(&gConsoleLock); if (freeChannel) ckfree(chanInfoPtr); @@ -1665,7 +1695,6 @@ ConsoleWriterThread(LPVOID arg) { ConsoleHandleInfo *handleInfoPtr = (ConsoleHandleInfo *) arg; ConsoleHandleInfo **iterator; - ConsoleChannelInfo *chanInfoPtr = NULL; BOOL success; RingSizeT numBytes; /* @@ -2029,7 +2058,7 @@ TclWinOpenConsoleChannel( chanInfoPtr, permissions); /* - * Files have default translation of AUTO and ^Z eof char, which means + * Consoles have default translation of auto and ^Z eof char, which means * that a ^Z will be accepted as EOF when reading. */ -- cgit v0.12 From 9f63bab8c7830e435e641fbb591a5d9f514ce3af Mon Sep 17 00:00:00 2001 From: apnadkarni Date: Sun, 3 Jul 2022 08:00:32 +0000 Subject: Fix benign gcc unused code warnings --- win/tclWinConsole.c | 12 ++++++++---- 1 file changed, 8 insertions(+), 4 deletions(-) diff --git a/win/tclWinConsole.c b/win/tclWinConsole.c index d59e677..653d580 100644 --- a/win/tclWinConsole.c +++ b/win/tclWinConsole.c @@ -225,7 +225,6 @@ static DWORD WriteConsoleChars(HANDLE hConsole, static void RingBufferInit(RingBuffer *ringPtr, RingSizeT capacity); static void RingBufferClear(RingBuffer *ringPtr); static char * RingBufferSegment(const RingBuffer *ringPtr, RingSizeT *lenPtr); -static int RingBufferCheck(const RingBuffer *ringPtr); static RingSizeT RingBufferIn(RingBuffer *ringPtr, const char *srcPtr, RingSizeT srcLen, int partialCopyOk); static RingSizeT RingBufferOut(RingBuffer *ringPtr, char *dstPtr, @@ -236,6 +235,9 @@ static ConsoleHandleInfo *FindConsoleInfo(const ConsoleChannelInfo *); static DWORD WINAPI ConsoleReaderThread(LPVOID arg); static DWORD WINAPI ConsoleWriterThread(LPVOID arg); static void NudgeWatchers(HANDLE consoleHandle); +#ifndef NDEBUG +static int RingBufferCheck(const RingBuffer *ringPtr); +#endif /* * Static data. @@ -500,7 +502,7 @@ RingBufferOut(RingBuffer *ringPtr, * *------------------------------------------------------------------------ */ - static char * + static inline char * RingBufferSegment(const RingBuffer *ringPtr, RingSizeT *lengthPtr) { RINGBUFFER_ASSERT(ringPtr); @@ -515,6 +517,7 @@ RingBufferOut(RingBuffer *ringPtr, return *lengthPtr == 0 ? NULL : ringPtr->start + ringPtr->bufPtr; } +#ifndef NDEBUG static int RingBufferCheck(const RingBuffer *ringPtr) { @@ -522,7 +525,8 @@ RingBufferCheck(const RingBuffer *ringPtr) && ringPtr->start < ringPtr->capacity && ringPtr->length <= ringPtr->capacity); } - +#endif + /* *------------------------------------------------------------------------ * @@ -1756,7 +1760,7 @@ ConsoleWriterThread(LPVOID arg) } /* We have data to write */ - if (numBytes > (sizeof(buffer) / sizeof(buffer[0]))) { + if ((size_t)numBytes > (sizeof(buffer) / sizeof(buffer[0]))) { numBytes = sizeof(buffer); } /* No need to check result, we already checked length bytes available */ -- cgit v0.12 From 6f74f207dda447f590c07d19f73d5da1a5796eb6 Mon Sep 17 00:00:00 2001 From: apnadkarni Date: Sun, 3 Jul 2022 15:48:33 +0000 Subject: Fix bug 44bbccdd8c. fconfigure was broken for 8.7 console channel --- tests/winConsole.test | 105 ++++++++++++++++++++++++++++++++++++++++++++------ win/tclWinConsole.c | 74 ++++++++++++++++++++--------------- 2 files changed, 136 insertions(+), 43 deletions(-) diff --git a/tests/winConsole.test b/tests/winConsole.test index 795e16d..ae0d939 100644 --- a/tests/winConsole.test +++ b/tests/winConsole.test @@ -34,25 +34,24 @@ proc yesno {question {default "Y"}} { } proc prompt {prompt} { - set answer "" - # Make sure we are seen but catch because ui and console + # Make sure we are seen but catch because twapi ui and console # packages may not be available catch {twapi::set_foreground_window [twapi::get_console_window]} puts -nonewline stdout "$prompt" - return [gets stdin] + flush stdout } +# Input tests -test winConsole-1.0 {Console blocking gets} -constraints {win interactive xx} -body { - set response [prompt "Type a line of text and press Return\n"] - yesno "Did you type \"$response\"" -} -result 1 +test console-gets-1.0 {Console blocking gets} -constraints {win interactive} -body { + set response [prompt "Type \"xyz\" and hit Enter: "] + gets stdin +} -result xyz -test winConsole-1.1 {Console file channel: non-blocking gets} {win interactive} { +test console-gets-1.1 {Console file channel: non-blocking gets} {win interactive} { set oldmode [fconfigure stdin] - puts stdout "Enter abcdef now: " nonewline - flush stdout + set response [prompt "Type \"abc\" and hit Enter: "] fileevent stdin readable { if {[gets stdin line] >= 0} { set result $line @@ -72,9 +71,93 @@ test winConsole-1.1 {Console file channel: non-blocking gets} {win interactive} set result -} "abcdef" +} abc + +# Output tests + +test console-puts-1.0 {Console blocking puts stdout} -constraints {win interactive} -body { + puts stdout "123" + yesno "Did you see the string \"123\"?" +} -result 1 +test console-puts-1.1 {Console blocking puts stderr} -constraints {win interactive} -body { + puts stderr "456" + yesno "Did you see the string \"456\"?" +} -result 1 +# fconfigure tests + +## stdin + +test console-fconfigure-1.0 { + Console get stdin configuration +} -constraints {win interactive} -body { + lsort [dict keys [fconfigure stdin]] +} -result {-blocking -buffering -buffersize -encoding -eofchar -inputmode -translation} + +set testnum 0 +foreach {opt result} { + -blocking 1 + -buffering line + -buffersize 4096 + -encoding utf-16 + -inputmode normal + -translation auto +} { + test console-fconfigure-1.[incr testnum] "Console get stdin option $opt" \ + -constraints {win interactive} -body { + fconfigure stdin $opt + } -result $result +} +test console-fconfigure-1.[incr testnum] { + Console get stdin option -eofchar +} -constraints {win interactive} -body { + fconfigure stdin -eofchar +} -result \x1a + +test console-fconfigure-1.[incr testnum] { + fconfigure -inputmode password +} -constraints {win interactive} -body { + prompt "Type \"password\" and hit Enter. You should NOT see characters echoed" + fconfigure stdin -inputmode password + gets stdin password + set password_echoed [yesno "Were the characters echoed?"] + prompt "Type \"normal\" and hit Enter. You should see characters echoed" + fconfigure stdin -inputmode normal + gets stdin normal + set normal_echoed [yesno "Were the characters echoed?"] + list $password_echoed $password $normal_echoed $normal + +} -result [list 0 password 1 normal] + +## stdout/stderr +foreach chan {stdout stderr} major {2 3} { + test console-fconfigure-$major.0 "Console get $chan configuration" -constraints { + win interactive + } -body { + lsort [dict keys [fconfigure $chan]] + } -result {-blocking -buffering -buffersize -encoding -eofchar -translation -winsize} + set testnum 0 + foreach {opt result} { + -blocking 1 + -buffersize 4096 + -encoding utf-16 + -translation crlf + } { + test console-fconfigure-$major.[incr testnum] "Console get $chan option $opt" \ + -constraints {win interactive} -body { + fconfigure $chan $opt + } -result $result + } + + test console-fconfigure-$major.[incr testnum] "Console get $chan option -winsize" -constraints {win interactive} -body { + fconfigure $chan -winsize + } -result {\d+ \d+} -match regexp + + test console-fconfigure-$major.[incr testnum] "Console get $chan option -buffering" -constraints {win interactive} -body { + fconfigure $chan -buffering + } -result [expr {$chan eq "stdout" ? "line" : "none"}] +} #cleanup diff --git a/win/tclWinConsole.c b/win/tclWinConsole.c index 653d580..7ca94ce 100644 --- a/win/tclWinConsole.c +++ b/win/tclWinConsole.c @@ -54,15 +54,14 @@ static int initialized = 0; -#ifdef TCL_CONSOLE_DEBUG -#ifndef CONSOLE_BUFFER_SIZE /* - * Force tiny to stress synchronization. Must be at least 2*sizeof(WCHAR) :-) - * to work around Tcl channel bug https://core.tcl-lang.org/tcl/tktview/b3977d199b08e3979a8da970553d5209b3042e9c + * Permit CONSOLE_BUFFER_SIZE to be defined on build command for stress test. + * + * In theory, at least sizeof(WCHAR) but note the Tcl channel bug + * https://core.tcl-lang.org/tcl/tktview/b3977d199b08e3979a8da970553d5209b3042e9c + * will cause failures in test suite if close to max input line in the suite. */ -#define CONSOLE_BUFFER_SIZE (2*sizeof(WCHAR)) -#endif -#else +#ifndef CONSOLE_BUFFER_SIZE #define CONSOLE_BUFFER_SIZE 8000 /* In bytes */ #endif @@ -1161,7 +1160,7 @@ ConsoleInputProc( * holds a reference count on handleInfoPtr, it will not * be deallocated while the lock is released. */ - //WakeConditionVariable(&handleInfoPtr->consoleThreadCV); TODO - Needed? + // WakeConditionVariable(&handleInfoPtr->consoleThreadCV); // TODO - Needed? if (!SleepConditionVariableSRW(&handleInfoPtr->interpThreadCV, &handleInfoPtr->lock, INFINITE, @@ -2263,41 +2262,52 @@ ConsoleGetOptionProc( } } } + else { + /* + * Output channel. Get option -winsize + * Option is readonly and returned by [fconfigure chan -winsize] but not + * returned by [fconfigure chan] without explicit option name. + */ + if (len == 0) { + Tcl_DStringAppendElement(dsPtr, "-winsize"); + } - /* - * Get option -winsize - * Option is readonly and returned by [fconfigure chan -winsize] but not - * returned by [fconfigure chan] without explicit option name. - */ - - if ((len > 1) && (strncmp(optionName, "-winsize", len) == 0)) { - CONSOLE_SCREEN_BUFFER_INFO consoleInfo; + if (len == 0 || (len > 1 && strncmp(optionName, "-winsize", len) == 0)) { + CONSOLE_SCREEN_BUFFER_INFO consoleInfo; - valid = 1; - if (!GetConsoleScreenBufferInfo(chanInfoPtr->handle, &consoleInfo)) { - Tcl_WinConvertError(GetLastError()); - if (interp != NULL) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "couldn't read console size: %s", - Tcl_PosixError(interp))); + valid = 1; + if (!GetConsoleScreenBufferInfo(chanInfoPtr->handle, + &consoleInfo)) { + Tcl_WinConvertError(GetLastError()); + if (interp != NULL) { + Tcl_SetObjResult( + interp, + Tcl_ObjPrintf("couldn't read console size: %s", + Tcl_PosixError(interp))); + } + return TCL_ERROR; } - return TCL_ERROR; + Tcl_DStringStartSublist(dsPtr); + sprintf(buf, + "%d", + consoleInfo.srWindow.Right - consoleInfo.srWindow.Left + 1); + Tcl_DStringAppendElement(dsPtr, buf); + sprintf(buf, + "%d", + consoleInfo.srWindow.Bottom - consoleInfo.srWindow.Top + 1); + Tcl_DStringAppendElement(dsPtr, buf); + Tcl_DStringEndSublist(dsPtr); } - sprintf(buf, "%d", - consoleInfo.srWindow.Right - consoleInfo.srWindow.Left + 1); - Tcl_DStringAppendElement(dsPtr, buf); - sprintf(buf, "%d", - consoleInfo.srWindow.Bottom - consoleInfo.srWindow.Top + 1); - Tcl_DStringAppendElement(dsPtr, buf); } + if (valid) { return TCL_OK; } if (chanInfoPtr->flags & CONSOLE_READ_OPS) { - return Tcl_BadChannelOption(interp, optionName, "inputmode winsize"); + return Tcl_BadChannelOption(interp, optionName, "inputmode"); } else { - return Tcl_BadChannelOption(interp, optionName, ""); + return Tcl_BadChannelOption(interp, optionName, "winsize"); } } -- cgit v0.12 From a303a1324a67c192bcaa76b3e08c81352d2bf534 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Sun, 3 Jul 2022 22:46:17 +0000 Subject: Remove dead code --- win/tclWinConsole.c | 31 ------------------------------- 1 file changed, 31 deletions(-) diff --git a/win/tclWinConsole.c b/win/tclWinConsole.c index 7ca94ce..1b8699c 100644 --- a/win/tclWinConsole.c +++ b/win/tclWinConsole.c @@ -223,7 +223,6 @@ static DWORD WriteConsoleChars(HANDLE hConsole, RingSizeT *nCharsWritten); static void RingBufferInit(RingBuffer *ringPtr, RingSizeT capacity); static void RingBufferClear(RingBuffer *ringPtr); -static char * RingBufferSegment(const RingBuffer *ringPtr, RingSizeT *lenPtr); static RingSizeT RingBufferIn(RingBuffer *ringPtr, const char *srcPtr, RingSizeT srcLen, int partialCopyOk); static RingSizeT RingBufferOut(RingBuffer *ringPtr, char *dstPtr, @@ -486,36 +485,6 @@ RingBufferOut(RingBuffer *ringPtr, return dstCapacity; } -/* - *------------------------------------------------------------------------ - * - * RingBufferSegment -- - * - * Returns a pointer to the leading data segment in the ring buffer. - * - * Results: - * Pointer to start of segment. - * - * Side effects: - * None. - * - *------------------------------------------------------------------------ - */ - static inline char * - RingBufferSegment(const RingBuffer *ringPtr, RingSizeT *lengthPtr) -{ - RINGBUFFER_ASSERT(ringPtr); - if (ringPtr->length <= (ringPtr->capacity - ringPtr->start)) { - /* No content wrap around. */ - *lengthPtr = ringPtr->length; - } - else { - /* Content wraps around so lead segment stretches to end of buffer */ - *lengthPtr = ringPtr->capacity - ringPtr->start; - } - return *lengthPtr == 0 ? NULL : ringPtr->start + ringPtr->bufPtr; -} - #ifndef NDEBUG static int RingBufferCheck(const RingBuffer *ringPtr) -- cgit v0.12 From 4d0bc87fb41014bd1ca72ebc565ac4d6b8230bd4 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 4 Jul 2022 08:31:08 +0000 Subject: Add TCL_COMBINE, just a NOP for now (will get a meaning in 9.0 --- generic/tcl.h | 7 +++++++ 1 file changed, 7 insertions(+) diff --git a/generic/tcl.h b/generic/tcl.h index d53c0f2..d99e9fa 100644 --- a/generic/tcl.h +++ b/generic/tcl.h @@ -993,6 +993,13 @@ typedef struct Tcl_DString { #define TCL_INDEX_TEMP_TABLE 64 /* + * Flags that may be passed to Tcl_UniCharToUtf. + * TCL_COMBINE Combine surrogates (default in Tcl 8.x) + */ + +#define TCL_COMBINE 0 + +/* *---------------------------------------------------------------------------- * Flag values passed to Tcl_RecordAndEval, Tcl_EvalObj, Tcl_EvalObjv. * WARNING: these bit choices must not conflict with the bit choices for -- cgit v0.12 From 62f9be3bc246d8af459066978a4ee75d0ff10d88 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 4 Jul 2022 11:30:20 +0000 Subject: Some -1 -> TCL_INDEX_NONE (Thanks, Gustaf!) --- generic/tclCompile.h | 8 ++++---- generic/tclDecls.h | 8 ++++---- 2 files changed, 8 insertions(+), 8 deletions(-) diff --git a/generic/tclCompile.h b/generic/tclCompile.h index c7c17f3..b3f1c78 100644 --- a/generic/tclCompile.h +++ b/generic/tclCompile.h @@ -97,7 +97,7 @@ typedef struct ExceptionRange { int 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 + int continueOffset; /* If LOOP_EXCEPTION_RANGE and not TCL_INDEX_NONE, the * target PC offset for a continue command in * the code range. Otherwise, ignore this * range when processing a continue @@ -297,9 +297,9 @@ typedef struct CompileEnv { * information provided by ObjInterpProc in * tclProc.c. */ int numCommands; /* Number of commands compiled. */ - int exceptDepth; /* Current exception range nesting level; -1 + int exceptDepth; /* Current exception range nesting level; TCL_INDEX_NONE * if not in any range currently. */ - int maxExceptDepth; /* Max nesting level of exception ranges; -1 + int maxExceptDepth; /* Max nesting level of exception ranges; TCL_INDEX_NONE * if no ranges have been compiled. */ int maxStackDepth; /* Maximum number of stack elements needed to * execute the code. Set by compilation @@ -458,7 +458,7 @@ typedef struct ByteCode { int numCmdLocBytes; /* Number of bytes needed for encoded command * location information. */ int maxExceptDepth; /* Maximum nesting level of ExceptionRanges; - * -1 if no ranges were compiled. */ + * TCL_INDEX_NONE if no ranges were compiled. */ int maxStackDepth; /* Maximum number of stack elements needed to * execute the code. */ unsigned char *codeStart; /* Points to the first byte of the code. This diff --git a/generic/tclDecls.h b/generic/tclDecls.h index bf79fa6..a53f25d 100644 --- a/generic/tclDecls.h +++ b/generic/tclDecls.h @@ -4150,7 +4150,7 @@ extern const TclStubs *tclStubsPtr; Tcl_UpVar2(interp, frameName, varName, NULL, localName, flags) #undef Tcl_AddErrorInfo #define Tcl_AddErrorInfo(interp, message) \ - Tcl_AppendObjToErrorInfo(interp, Tcl_NewStringObj(message, -1)) + Tcl_AppendObjToErrorInfo(interp, Tcl_NewStringObj(message, TCL_INDEX_NONE)) #undef Tcl_AddObjErrorInfo #define Tcl_AddObjErrorInfo(interp, message, length) \ Tcl_AppendObjToErrorInfo(interp, Tcl_NewStringObj(message, length)) @@ -4173,10 +4173,10 @@ extern const TclStubs *tclStubsPtr; #define Tcl_GetStringResult(interp) Tcl_GetString(Tcl_GetObjResult(interp)) #undef Tcl_Eval #define Tcl_Eval(interp, objPtr) \ - Tcl_EvalEx(interp, objPtr, -1, 0) + Tcl_EvalEx(interp, objPtr, TCL_INDEX_NONE, 0) #undef Tcl_GlobalEval #define Tcl_GlobalEval(interp, objPtr) \ - Tcl_EvalEx(interp, objPtr, -1, TCL_EVAL_GLOBAL) + Tcl_EvalEx(interp, objPtr, TCL_INDEX_NONE, TCL_EVAL_GLOBAL) #undef Tcl_SaveResult #define Tcl_SaveResult(interp, statePtr) \ do { \ @@ -4199,7 +4199,7 @@ extern const TclStubs *tclStubsPtr; do { \ const char *__result = result; \ Tcl_FreeProc *__freeProc = freeProc; \ - Tcl_SetObjResult(interp, Tcl_NewStringObj(__result, -1)); \ + Tcl_SetObjResult(interp, Tcl_NewStringObj(__result, TCL_INDEX_NONE)); \ if (__result != NULL && __freeProc != NULL && __freeProc != TCL_VOLATILE) { \ if (__freeProc == TCL_DYNAMIC) { \ ckfree((char *)__result); \ -- cgit v0.12 From b5282f380b7cf0d96a9d9414296ca83b6ac6cc70 Mon Sep 17 00:00:00 2001 From: apnadkarni Date: Mon, 4 Jul 2022 15:32:29 +0000 Subject: Rework reader thread to not do read-ahead as console stdin mode might change --- tests/winConsole.test | 6 +- win/tclWinConsole.c | 192 +++++++++++++++++++++++++++++--------------------- 2 files changed, 114 insertions(+), 84 deletions(-) diff --git a/tests/winConsole.test b/tests/winConsole.test index ae0d939..6d537b2 100644 --- a/tests/winConsole.test +++ b/tests/winConsole.test @@ -118,12 +118,12 @@ test console-fconfigure-1.[incr testnum] { test console-fconfigure-1.[incr testnum] { fconfigure -inputmode password } -constraints {win interactive} -body { - prompt "Type \"password\" and hit Enter. You should NOT see characters echoed" + prompt "Type \"password\" and hit Enter. You should NOT see characters echoed: " fconfigure stdin -inputmode password gets stdin password - set password_echoed [yesno "Were the characters echoed?"] - prompt "Type \"normal\" and hit Enter. You should see characters echoed" fconfigure stdin -inputmode normal + set password_echoed [yesno "\nWere the characters echoed?"] + prompt "Type \"normal\" and hit Enter. You should see characters echoed: " gets stdin normal set normal_echoed [yesno "Were the characters echoed?"] list $password_echoed $password $normal_echoed $normal diff --git a/win/tclWinConsole.c b/win/tclWinConsole.c index 1b8699c..46a7225 100644 --- a/win/tclWinConsole.c +++ b/win/tclWinConsole.c @@ -45,14 +45,32 @@ * per thread queues which simplifies lock management particularly because * thread-console relation is not one-one and is likely more performant as * well with fewer locks needing to be obtained. + * + * Some additional design notes/reminders for the future: + * + * All input is done through the reader thread, even synchronous reads of + * stdin which in theory could be done directly by the interpreter threads. + * This is because I'm not entirely confident about multithreaded access to + * the ReadConsole API (probably ok since Microsoft does not warn against + * this) and also the API requires reading an even number of bytes (WCHAR) + * while the channel callback has no such restriction (in theory). + * Accounting for that in the callbacks is doable but slightly tricky while + * straightforward in the reader thread because of its double buffering. + * + * The reader thread does not read ahead. That is, it will not post a read + * until some interpreter thread is actually requesting a read. This is + * because an interpreter may (for example) turn off echo for passwords and + * the read ahead would come in the way of that. + * + * If multiple threads are reading from stdin, the input is sprayed in random + * fashion. This is not good application design and hence no plan to address + * this (not clear what should be done even in theory) + * + * Locks are never held when calling the ReadConsole/WriteConsole API's + * since they may block. */ -/* - * The following variable is used to tell whether this module has been - * initialized. - */ - -static int initialized = 0; +static int gInitialized = 0; /* * Permit CONSOLE_BUFFER_SIZE to be defined on build command for stress test. @@ -127,6 +145,8 @@ typedef struct ConsoleHandleInfo { int numRefs; /* See comments above */ int permissions; /* TCL_READABLE for input consoles, TCL_WRITABLE * for output. Only one or the other can be set. */ + int flags; +#define CONSOLE_DATA_AWAITED 0x0001 /* An interpreter is awaiting data */ } ConsoleHandleInfo; /* @@ -171,9 +191,9 @@ typedef struct ConsoleChannelInfo { * TCL_WRITABLE, or TCL_EXCEPTION: indicates * which events should be reported. */ int flags; /* State flags */ -#define CONSOLE_EVENT_QUEUED (1 << 0) /* Notification event already queued */ -#define CONSOLE_ASYNC (1 << 1) /* Channel is non-blocking. */ -#define CONSOLE_READ_OPS (1 << 2) /* Channel supports read-related ops. */ +#define CONSOLE_EVENT_QUEUED 0x0001 /* Notification event already queued */ +#define CONSOLE_ASYNC 0x0002 /* Channel is non-blocking. */ +#define CONSOLE_READ_OPS 0x0004 /* Channel supports read-related ops. */ } ConsoleChannelInfo; /* @@ -622,10 +642,10 @@ ConsoleInit(void) * is a speed enhancement. */ - if (!initialized) { + if (!gInitialized) { AcquireSRWLockExclusive(&gConsoleLock); - if (!initialized) { - initialized = 1; + if (!gInitialized) { + gInitialized = 1; Tcl_CreateExitHandler(ProcExitHandler, NULL); } ReleaseSRWLockExclusive(&gConsoleLock); @@ -686,7 +706,7 @@ ProcExitHandler( TCL_UNUSED(ClientData)) { AcquireSRWLockExclusive(&gConsoleLock); - initialized = 0; + gInitialized = 0; ReleaseSRWLockExclusive(&gConsoleLock); } @@ -1090,15 +1110,13 @@ ConsoleInputProc( */ if (numRead != 0) { /* If console thread was blocked, awaken it */ - if (freeSpace == 0) { - WakeConditionVariable(&handleInfoPtr->consoleThreadCV); - } + // XXX WakeConditionVariable(&handleInfoPtr->consoleThreadCV); break; } /* * No data available. * - If an error was recorded, generate that and reset it. - * - If EOF, indicate as much. It is up to application to close + * - If EOF, indicate as much. It is up to the application to close * the channel. * - Otherwise, if non-blocking return EAGAIN or wait for more data. */ @@ -1119,21 +1137,26 @@ ConsoleInputProc( chanInfoPtr->handle = INVALID_HANDLE_VALUE; break; } + /* Request console reader thread for data */ + handleInfoPtr->flags |= CONSOLE_DATA_AWAITED; + WakeConditionVariable(&handleInfoPtr->consoleThreadCV); + + /* For async, tell caller we are blocked */ if (chanInfoPtr->flags & CONSOLE_ASYNC) { *errorCode = EWOULDBLOCK; numRead = -1; break; } + /* * Release the lock and sleep. Note that because the channel * holds a reference count on handleInfoPtr, it will not * be deallocated while the lock is released. */ - // WakeConditionVariable(&handleInfoPtr->consoleThreadCV); // TODO - Needed? if (!SleepConditionVariableSRW(&handleInfoPtr->interpThreadCV, - &handleInfoPtr->lock, - INFINITE, - 0)) { + &handleInfoPtr->lock, + INFINITE, + 0)) { Tcl_WinConvertError(GetLastError()); *errorCode = Tcl_GetErrno(); numRead = -1; @@ -1370,9 +1393,9 @@ ConsoleEventProc( static void ConsoleWatchProc( ClientData instanceData, /* Console state. */ - int permissions) /* What events to watch for, OR-ed combination - * of TCL_READABLE, TCL_WRITABLE and - * TCL_EXCEPTION. */ + int newMask) /* What events to watch for, one of + * of TCL_READABLE, TCL_WRITABLE + */ { ConsoleChannelInfo **nextPtrPtr, *ptr; ConsoleChannelInfo *chanInfoPtr = (ConsoleChannelInfo *)instanceData; @@ -1383,15 +1406,27 @@ ConsoleWatchProc( * need to update the watchMask and then force the notifier to poll once. */ - chanInfoPtr->watchMask = permissions & chanInfoPtr->permissions; + chanInfoPtr->watchMask = newMask & chanInfoPtr->permissions; if (chanInfoPtr->watchMask) { Tcl_Time blockTime = { 0, 0 }; if (!oldMask) { - /* Add to list of watched channels */ AcquireSRWLockExclusive(&gConsoleLock); + /* Add to list of watched channels */ chanInfoPtr->nextWatchingChannelPtr = gWatchingChannelList; gWatchingChannelList = chanInfoPtr; + + /* + * For read channels, need to tell the console reader thread + * that we are looking for data since it will not do reads until + * it knows someone is awaiting. + */ + ConsoleHandleInfo *handleInfoPtr; + handleInfoPtr = FindConsoleInfo(chanInfoPtr); + if (handleInfoPtr) { + handleInfoPtr->flags |= CONSOLE_DATA_AWAITED; + WakeConditionVariable(&handleInfoPtr->consoleThreadCV); + } ReleaseSRWLockExclusive(&gConsoleLock); } Tcl_SetMaxBlockTime(&blockTime); @@ -1475,7 +1510,7 @@ ConsoleReaderThread( /* * Keep looping until one of the following happens. * - * - there are not more channels listening on the console + * - there are no more channels listening on the console * - the console handle has been closed * * On each iteration, @@ -1499,43 +1534,14 @@ ConsoleReaderThread( } /* - * Cases: - * (1) The shared input buffer is full. Have to wait for an interp - * thread to read from it and make room. - * (2) The shared input buffer has room and the thread private buffer - * has data. Copy into the shared input buffer. - * (3) The channel has previously seen an error. Treat as EOF. Note - * this check is after the above so any data already available - * is passed on. - * (4) Neither buffer has data and no errors. Go get some from console. - * - * There is some duplication of code below but easier to think about - * rather than combining cases. + * Shared buffer has no data. If we have some in our private buffer + * copy that. Else check if there has been an error. In both cases + * notify the interp threads. */ - if (RingBufferFreeSpace(&handleInfoPtr->buffer) == 0) { - /* Case (1) No room in buffer.*/ - - /* Awaken any reader channels - TODO - is this needed? */ - // WakeConditionVariable(&handleInfoPtr->interpThreadCV); - - /* Release lock and wait for room */ - success = SleepConditionVariableSRW(&handleInfoPtr->consoleThreadCV, - &handleInfoPtr->lock, - INFINITE, - 0); - /* Note: lock has been reacquired */ - - if (!success && GetLastError() != ERROR_TIMEOUT) { - /* TODO - what can be done? Should not happen */ - /* For now keep going */ - } - } else if (inputLen > 0 || handleInfoPtr->lastError != 0) { - /* Cases (2) and (3) - require notifications to interpreters */ + if (inputLen > 0 || handleInfoPtr->lastError != 0) { HANDLE consoleHandle; if (inputLen > 0) { - /* - * Case (2). Private buffer has data. Copy it over. - */ + /* Private buffer has data. Copy it over. */ RingSizeT nStored; assert((inputLen - inputOffset) > 0); @@ -1553,43 +1559,54 @@ ConsoleReaderThread( } else { /* - * Case (3). On error, nothing but inform caller and wait + * On error, nothing but inform caller and wait * We do not want to exit until there are no client interps. */ } /* - * Wake up any threads waiting synchronously. Really we only - * to do this if buffer was previously empty, blocking readers - * but whatever...don't further complicate things. + * Wake up any threads waiting either synchronously or + * asynchronously. Since we are providing data, turn off the + * AWAITED flag. If the data provided is not sufficient the + * clients will request again. Note we have to wake up ALL + * awaiting threads, not just one, so they can all reissue + * requests if needed. (In a properly designed app, at most one + * thread should be reading standard input but...) */ - WakeConditionVariable(&handleInfoPtr->interpThreadCV); - + handleInfoPtr->flags &= ~CONSOLE_DATA_AWAITED; + /* Wake synchronous channels */ + WakeAllConditionVariable(&handleInfoPtr->interpThreadCV); /* - * Wake up all channels registered for file events. Note in + * Wake up async channels registered for file events. Note in * order to follow the locking hierarchy, we need to release - * handleInfoPtr->lock before acquiring gConsoleLock and - * relock it. + * handleInfoPtr->lock before calling NudgeWatchers. */ consoleHandle = handleInfoPtr->console; - /* - * Wake up all channels registered for file events. Note in - * order to follow the locking hierarchy, we cannot hold any locks - * when calling NudgeWatchers. - */ ReleaseSRWLockExclusive(&handleInfoPtr->lock); NudgeWatchers(consoleHandle); - AcquireSRWLockExclusive(&handleInfoPtr->lock); - } - else { + /* - * Case (4). Need to go get more data from console. We only - * store the last error. It is up to channel handlers to decide - * whether to close or what to do. + * Loop back to recheck for exit conditions changes while the + * the lock was not held. */ + continue; + } + + /* + * Both shared buffer and private buffer are empty. Need to go get + * data from console but do not want to read ahead because the + * interp thread might change the read mode, e.g. turning off echo + * for password input. So only do so if at least one interpreter has + * requested data. + */ + if (handleInfoPtr->flags & CONSOLE_DATA_AWAITED) { DWORD error; + /* Do not hold the lock while blocked in console */ ReleaseSRWLockExclusive(&handleInfoPtr->lock); + /* + * Note - the temporary buffer serves two purposes. It + */ error = ReadConsoleChars(handleInfoPtr->console, (WCHAR *)inputChars, sizeof(inputChars) / sizeof(WCHAR), @@ -1599,12 +1616,25 @@ ConsoleReaderThread( inputLen *= sizeof(WCHAR); } else { + /* + * We only store the last error. It is up to channel + * handlers whether to close or not in case of errors. + */ handleInfoPtr->lastError = error; if (handleInfoPtr->lastError == ERROR_INVALID_HANDLE) { handleInfoPtr->console = INVALID_HANDLE_VALUE; } } } + else { + /* Wait until an interp thread asks for data. */ + success = SleepConditionVariableSRW(&handleInfoPtr->consoleThreadCV, + &handleInfoPtr->lock, + INFINITE, + 0); + } + + /* Loop again to check for exit or wait for readers to wake us */ } /* -- cgit v0.12 From 4ff49ce2f1d1884d64e2652b069483b65234caa2 Mon Sep 17 00:00:00 2001 From: apnadkarni Date: Mon, 4 Jul 2022 15:59:37 +0000 Subject: Merge core-8-branch --- win/tclWinConsole.c | 6 ------ 1 file changed, 6 deletions(-) diff --git a/win/tclWinConsole.c b/win/tclWinConsole.c index 46a7225..f1201ce 100644 --- a/win/tclWinConsole.c +++ b/win/tclWinConsole.c @@ -1509,14 +1509,8 @@ ConsoleReaderThread( /* * Keep looping until one of the following happens. - * * - there are no more channels listening on the console * - the console handle has been closed - * - * On each iteration, - * - if the channel buffer is full, wait for some channel reader to read - * - if there is data in our input buffer copy it to the channel buffer - * - get more data from the console */ /* This thread is holding a reference so pointer is safe */ -- cgit v0.12 From dda0e7f5f62db678465c31383298f07ab102a2d1 Mon Sep 17 00:00:00 2001 From: apnadkarni Date: Mon, 4 Jul 2022 16:54:18 +0000 Subject: Permit direct console writes for synchronous output calls --- win/tclWinConsole.c | 83 ++++++++++++++++++++++++++++++++++++++++------------- 1 file changed, 63 insertions(+), 20 deletions(-) diff --git a/win/tclWinConsole.c b/win/tclWinConsole.c index f1201ce..4f67b64 100644 --- a/win/tclWinConsole.c +++ b/win/tclWinConsole.c @@ -66,6 +66,9 @@ * fashion. This is not good application design and hence no plan to address * this (not clear what should be done even in theory) * + * For output, we do not restrict all output to the console writer threads. + * See ConsoleOutputProc for the conditions. + * * Locks are never held when calling the ReadConsole/WriteConsole API's * since they may block. */ @@ -1233,31 +1236,71 @@ ConsoleOutputProc( break; } - numWritten += RingBufferIn( - &handleInfoPtr->buffer, numWritten + buf, toWrite - numWritten, 1); - if (numWritten == toWrite || chanInfoPtr->flags & CONSOLE_ASYNC) { - /* All done or async, just accept whatever was written */ - break; - } /* - * Release the lock and sleep. Note that because the channel - * holds a reference count on handleInfoPtr, it will not - * be deallocated while the lock is released. + * We can either write directly or through the console thread's + * ring buffer. We have to do the latter when + * (1) the operation is async since WriteConsoleChars is always blocking + * (2) when there is already data in the ring buffer because we don't + * want to reorder output from within a thread + * (3) when there are an odd number of bytes since WriteConsole + * takes whole WCHARs + * (4) when the pointer is not aligned on WCHAR + * The ring buffer deals with cases (3) and (4). It would be harder + * to duplicate that here. */ - WakeConditionVariable(&handleInfoPtr->consoleThreadCV); - if (!SleepConditionVariableSRW(&handleInfoPtr->interpThreadCV, - &handleInfoPtr->lock, - INFINITE, - 0)) { - /* Report the error */ - Tcl_WinConvertError(GetLastError()); - *errorCode = Tcl_GetErrno(); - numWritten = -1; - break; + if ((chanInfoPtr->flags & CONSOLE_ASYNC) /* Case (1) */ + || RingBufferLength(&handleInfoPtr->buffer) != 0 /* Case (2) */ + || (toWrite & 1) != 0 /* Case (3) */ + || (PTR2INT(buf) & 1) != 0 /* Case (4) */ + ) { + numWritten += RingBufferIn(&handleInfoPtr->buffer, + numWritten + buf, + toWrite - numWritten, + 1); + if (numWritten == toWrite || chanInfoPtr->flags & CONSOLE_ASYNC) { + /* All done or async, just accept whatever was written */ + break; + } + /* + * Release the lock and sleep. Note that because the channel + * holds a reference count on handleInfoPtr, it will not + * be deallocated while the lock is released. + */ + WakeConditionVariable(&handleInfoPtr->consoleThreadCV); + if (!SleepConditionVariableSRW(&handleInfoPtr->interpThreadCV, + &handleInfoPtr->lock, + INFINITE, + 0)) { + /* Report the error */ + Tcl_WinConvertError(GetLastError()); + *errorCode = Tcl_GetErrno(); + numWritten = -1; + break; + } + } + else { + /* Direct output */ + DWORD winStatus; + HANDLE consoleHandle = handleInfoPtr->console; + /* Unlock before blocking in WriteConsole */ + ReleaseSRWLockExclusive(&handleInfoPtr->lock); + /* UNLOCKED so return, DON'T break out of loop as it will unlock again! */ + winStatus = WriteConsoleChars(consoleHandle, + (WCHAR *)buf, + toWrite / sizeof(WCHAR), + &numWritten); + if (winStatus == ERROR_SUCCESS) { + return numWritten * sizeof(WCHAR); + } + else { + Tcl_WinConvertError(winStatus); + *errorCode = Tcl_GetErrno(); + return -1; + } } + /* Lock is reacquired. Continue loop */ } - WakeConditionVariable(&handleInfoPtr->consoleThreadCV); ReleaseSRWLockExclusive(&handleInfoPtr->lock); return numWritten; -- cgit v0.12 From 73390782ea84a72d621c6ebbaf2b18ae9308b93b Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 5 Jul 2022 10:20:02 +0000 Subject: Simplify TIP #609 implementation, make TCL_QUEUE_ALERT_IF_EMPTY work for all positions and improve documentation --- doc/Notifier.3 | 2 +- generic/tcl.decls | 4 ++-- generic/tclDecls.h | 8 ++++---- generic/tclNotify.c | 38 +++++++++++++++++--------------------- 4 files changed, 24 insertions(+), 28 deletions(-) diff --git a/doc/Notifier.3 b/doc/Notifier.3 index 3b547ff..7cb02f6 100644 --- a/doc/Notifier.3 +++ b/doc/Notifier.3 @@ -90,7 +90,7 @@ 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 int flags in +.AP int position in Where to add the new event in the queue: \fBTCL_QUEUE_TAIL\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. diff --git a/generic/tcl.decls b/generic/tcl.decls index 8b78c7e..99c0e25 100644 --- a/generic/tcl.decls +++ b/generic/tcl.decls @@ -734,7 +734,7 @@ declare 204 { const char *Tcl_PosixError(Tcl_Interp *interp) } declare 205 { - void Tcl_QueueEvent(Tcl_Event *evPtr, int flags) + void Tcl_QueueEvent(Tcl_Event *evPtr, int position) } declare 206 { int Tcl_Read(Tcl_Channel chan, char *bufPtr, int toRead) @@ -1144,7 +1144,7 @@ declare 318 { } declare 319 { void Tcl_ThreadQueueEvent(Tcl_ThreadId threadId, Tcl_Event *evPtr, - int flags) + int position) } declare 320 { int Tcl_UniCharAtIndex(const char *src, int index) diff --git a/generic/tclDecls.h b/generic/tclDecls.h index a53f25d..b869c97 100644 --- a/generic/tclDecls.h +++ b/generic/tclDecls.h @@ -642,7 +642,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, int flags); +EXTERN void Tcl_QueueEvent(Tcl_Event *evPtr, int position); /* 206 */ EXTERN int Tcl_Read(Tcl_Channel chan, char *bufPtr, int toRead); /* 207 */ @@ -980,7 +980,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, int flags); + Tcl_Event *evPtr, int position); /* 320 */ EXTERN int Tcl_UniCharAtIndex(const char *src, int index); /* 321 */ @@ -2215,7 +2215,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, int flags); /* 205 */ + void (*tcl_QueueEvent) (Tcl_Event *evPtr, int position); /* 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 */ @@ -2329,7 +2329,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, int flags); /* 319 */ + void (*tcl_ThreadQueueEvent) (Tcl_ThreadId threadId, Tcl_Event *evPtr, int position); /* 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/tclNotify.c b/generic/tclNotify.c index 8613e98..e17819e 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, int flags); + Tcl_Event *evPtr, int position); /* *---------------------------------------------------------------------- @@ -175,8 +175,7 @@ TclFinalizeNotifier(void) Tcl_Event *evPtr, *hold; if (!tsdPtr->initialized) { - return; /* Notifier not initialized for the current - * thread. */ + return; /* Notifier not initialized for the current thread */ } Tcl_MutexLock(&(tsdPtr->queueMutex)); @@ -310,7 +309,7 @@ Tcl_CreateEventSource( * checkProc. */ { ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); - EventSource *sourcePtr = (EventSource *) ckalloc(sizeof(EventSource)); + EventSource *sourcePtr = (EventSource *)ckalloc(sizeof(EventSource)); sourcePtr->setupProc = setupProc; sourcePtr->checkProc = checkProc; @@ -392,12 +391,12 @@ Tcl_QueueEvent( * malloc (ckalloc), and it becomes the * property of the event queue. It will be * freed after the event has been handled. */ - int flags) /* One of TCL_QUEUE_TAIL, TCL_QUEUE_HEAD, - * TCL_QUEUE_MARK, possibly combined with TCL_QUEUE_ALERT_IF_EMPTY. */ + int position) /* 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, flags); + QueueEvent(tsdPtr, evPtr, position); } /* @@ -424,8 +423,8 @@ Tcl_ThreadQueueEvent( * malloc (ckalloc), and it becomes the * property of the event queue. It will be * freed after the event has been handled. */ - int flags) /* One of TCL_QUEUE_TAIL, TCL_QUEUE_HEAD, - * TCL_QUEUE_MARK, possibly combined with TCL_QUEUE_ALERT_IF_EMPTY. */ + int position) /* One of TCL_QUEUE_TAIL, TCL_QUEUE_HEAD, TCL_QUEUE_MARK, + * possibly combined with TCL_QUEUE_ALERT_IF_EMPTY. */ { ThreadSpecificData *tsdPtr; @@ -444,7 +443,7 @@ Tcl_ThreadQueueEvent( */ if (tsdPtr) { - if (QueueEvent(tsdPtr, evPtr, flags)) { + if (QueueEvent(tsdPtr, evPtr, position)) { Tcl_AlertNotifier(tsdPtr->clientData); } } else { @@ -484,15 +483,14 @@ QueueEvent( * malloc (ckalloc), and it becomes the * property of the event queue. It will be * freed after the event has been handled. */ - int flags) - /* One of TCL_QUEUE_TAIL_EX, - * TCL_QUEUE_HEAD_EX, TCL_QUEUE_MARK_EX, + int position) /* One of TCL_QUEUE_TAIL, TCL_QUEUE_HEAD, TCL_QUEUE_MARK, * possibly combined with TCL_QUEUE_ALERT_IF_EMPTY */ { - int wasEmpty = 0; - Tcl_MutexLock(&(tsdPtr->queueMutex)); - if ((flags & 3) == TCL_QUEUE_TAIL) { + if (tsdPtr->firstEventPtr != NULL) { + position &= ~TCL_QUEUE_ALERT_IF_EMPTY; + } + if ((position & 3) == TCL_QUEUE_TAIL) { /* * Append the event on the end of the queue. */ @@ -500,12 +498,11 @@ QueueEvent( evPtr->nextPtr = NULL; if (tsdPtr->firstEventPtr == NULL) { tsdPtr->firstEventPtr = evPtr; - wasEmpty = (flags & TCL_QUEUE_ALERT_IF_EMPTY) ? 1 : 0; } else { tsdPtr->lastEventPtr->nextPtr = evPtr; } tsdPtr->lastEventPtr = evPtr; - } else if ((flags & 3) == TCL_QUEUE_HEAD) { + } else if ((position & 3) == TCL_QUEUE_HEAD) { /* * Push the event on the head of the queue. */ @@ -513,10 +510,9 @@ QueueEvent( evPtr->nextPtr = tsdPtr->firstEventPtr; if (tsdPtr->firstEventPtr == NULL) { tsdPtr->lastEventPtr = evPtr; - wasEmpty = (flags & TCL_QUEUE_ALERT_IF_EMPTY) ? 1 : 0; } tsdPtr->firstEventPtr = evPtr; - } else if ((flags & 3) == TCL_QUEUE_MARK) { + } else if ((position & 3) == TCL_QUEUE_MARK) { /* * Insert the event after the current marker event and advance the * marker to the new event. @@ -535,7 +531,7 @@ QueueEvent( } } Tcl_MutexUnlock(&(tsdPtr->queueMutex)); - return wasEmpty; + return position & TCL_QUEUE_ALERT_IF_EMPTY; } /* -- cgit v0.12 From 1469d7388d67343a410fc0157dedeaa7deb27ddd Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 5 Jul 2022 12:03:18 +0000 Subject: Prevent warning: zero size arrays are an extension [-Wzero-length-array], when using C99 --- generic/tclInt.h | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/generic/tclInt.h b/generic/tclInt.h index e238728..63fcf62 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -877,7 +877,9 @@ typedef struct VarInHash { *---------------------------------------------------------------- */ -#if defined(__GNUC__) && (__GNUC__ > 2) +#if defined(__STDC_VERSION__) && (__STDC_VERSION__ >= 199901L) +# define TCLFLEXARRAY +#elif defined(__GNUC__) && (__GNUC__ > 2) # define TCLFLEXARRAY 0 #else # define TCLFLEXARRAY 1 -- cgit v0.12 From eb33dbb186b524be57dd9b4c2ebb9b703cb5080a Mon Sep 17 00:00:00 2001 From: apnadkarni Date: Tue, 5 Jul 2022 15:54:00 +0000 Subject: Fix channel close on thread exit if other threads exist. Add winconsole tests. --- tests/winConsole.test | 237 +++++++++++++++++++++++++++++++++++++++++++------- win/tclWinConsole.c | 33 +++++-- 2 files changed, 231 insertions(+), 39 deletions(-) diff --git a/tests/winConsole.test b/tests/winConsole.test index 6d537b2..cb1babc 100644 --- a/tests/winConsole.test +++ b/tests/winConsole.test @@ -14,7 +14,9 @@ if {"::tcltest" ni [namespace children]} { namespace import -force ::tcltest::* } -::tcltest::ConstraintInitializer twapi { expr {![catch {package require twapi}]} } +catch {package require twapi} ;# Only to bring window to foreground. Not critical + +::tcltest::ConstraintInitializer haveThread { expr {![catch {package require Thread}]} } # Prompt user for a yes/no response proc yesno {question {default "Y"}} { @@ -44,14 +46,16 @@ proc prompt {prompt} { # Input tests test console-gets-1.0 {Console blocking gets} -constraints {win interactive} -body { - set response [prompt "Type \"xyz\" and hit Enter: "] + prompt "Type \"xyz\" and hit Enter: " gets stdin } -result xyz -test console-gets-1.1 {Console file channel: non-blocking gets} {win interactive} { +test console-gets-1.1 {Console file channel: non-blocking gets} -constraints { + win interactive tbd +} -body { set oldmode [fconfigure stdin] - set response [prompt "Type \"abc\" and hit Enter: "] + prompt "Type \"abc\" and hit Enter: " fileevent stdin readable { if {[gets stdin line] >= 0} { set result $line @@ -68,10 +72,55 @@ test console-gets-1.1 {Console file channel: non-blocking gets} {win interactive #cleanup the fileevent fileevent stdin readable {} fconfigure stdin {*}$oldmode - + puts [fconfigure stdin] set result -} abc +} -result abc + +test console-read-1.0 {Console blocking read} -constraints {win interactive} -setup { + set oldmode [fconfigure stdin] + fconfigure stdin -inputmode raw +} -cleanup { + fconfigure stdin {*}$oldmode +} -body { + puts [fconfigure stdin] + prompt "Type the key \"a\". Do NOT hit Enter. You will NOT see characters echoed." + set c [read stdin 1] + puts "" + set c +} -result a + +test console-read-1.1 {Console file channel: non-blocking read} -constraints { + win interactive +} -setup { + set oldmode [fconfigure stdin] +} -cleanup { + fconfigure stdin {*}$oldmode +} -body { + set input "" + fconfigure stdin -blocking 0 -buffering line -inputmode raw + prompt "Type \"abc\". Do NOT hit Enter. You will NOT see characters echoed." + + fileevent stdin readable { + set c [read stdin 1] + if {$c eq ""} { + if {[eof stdin]} { + set result "read eof" + } + } else { + append input $c + if {[string length $input] == 3} { + set result $input + } + } + } + + set result {} + vwait result + fileevent stdin readable {} + puts "" + set result +} -result abc # Output tests @@ -80,16 +129,39 @@ test console-puts-1.0 {Console blocking puts stdout} -constraints {win interacti yesno "Did you see the string \"123\"?" } -result 1 -test console-puts-1.1 {Console blocking puts stderr} -constraints {win interactive} -body { +test console-puts-1.1 {Console non-blocking puts stdout} -constraints { + win interactive +} -setup { + set oldmode [fconfigure stdout] + dict unset oldmode -winsize +} -cleanup { + fconfigure stdout {*}$oldmode +} -body { + fconfigure stdout -blocking 0 -buffering line + set count 0 + fileevent stdout writable { + if {[incr count] < 4} { + puts "$count" + } else { + fileevent stdout writable {} + set done 1 + } + } + vwait done + yesno "Did you see 1, 2, 3 printed on consecutive lines?" +} -result 1 + +test console-puts-2.0 {Console blocking puts stderr} -constraints {win interactive} -body { puts stderr "456" yesno "Did you see the string \"456\"?" } -result 1 -# fconfigure tests -## stdin +# fconfigure get tests + +## fconfigure get stdin -test console-fconfigure-1.0 { +test console-fconfigure-get-1.0 { Console get stdin configuration } -constraints {win interactive} -body { lsort [dict keys [fconfigure stdin]] @@ -104,35 +176,26 @@ foreach {opt result} { -inputmode normal -translation auto } { - test console-fconfigure-1.[incr testnum] "Console get stdin option $opt" \ + test console-fconfigure-get-1.[incr testnum] "Console get stdin option $opt" \ -constraints {win interactive} -body { fconfigure stdin $opt } -result $result } -test console-fconfigure-1.[incr testnum] { +test console-fconfigure-get-1.[incr testnum] { Console get stdin option -eofchar } -constraints {win interactive} -body { fconfigure stdin -eofchar } -result \x1a -test console-fconfigure-1.[incr testnum] { - fconfigure -inputmode password -} -constraints {win interactive} -body { - prompt "Type \"password\" and hit Enter. You should NOT see characters echoed: " - fconfigure stdin -inputmode password - gets stdin password - fconfigure stdin -inputmode normal - set password_echoed [yesno "\nWere the characters echoed?"] - prompt "Type \"normal\" and hit Enter. You should see characters echoed: " - gets stdin normal - set normal_echoed [yesno "Were the characters echoed?"] - list $password_echoed $password $normal_echoed $normal - -} -result [list 0 password 1 normal] +test console-fconfigure-get-1.[incr testnum] { + fconfigure -winsize +} -body { + fconfigure stdin -winsize +} -result {bad option "-winsize": should be one of -blocking, -buffering, -buffersize, -encoding, -eofchar, -translation, or -inputmode} -returnCodes error -## stdout/stderr +## fconfigure get stdout/stderr foreach chan {stdout stderr} major {2 3} { - test console-fconfigure-$major.0 "Console get $chan configuration" -constraints { + test console-fconfigure-get-$major.0 "Console get $chan configuration" -constraints { win interactive } -body { lsort [dict keys [fconfigure $chan]] @@ -144,23 +207,133 @@ foreach chan {stdout stderr} major {2 3} { -encoding utf-16 -translation crlf } { - test console-fconfigure-$major.[incr testnum] "Console get $chan option $opt" \ + test console-fconfigure-get-$major.[incr testnum] "Console get $chan option $opt" \ -constraints {win interactive} -body { fconfigure $chan $opt } -result $result } - test console-fconfigure-$major.[incr testnum] "Console get $chan option -winsize" -constraints {win interactive} -body { + test console-fconfigure-get-$major.[incr testnum] "Console get $chan option -winsize" -constraints {win interactive} -body { fconfigure $chan -winsize } -result {\d+ \d+} -match regexp - test console-fconfigure-$major.[incr testnum] "Console get $chan option -buffering" -constraints {win interactive} -body { + test console-fconfigure-get-$major.[incr testnum] "Console get $chan option -buffering" -constraints {win interactive} -body { fconfigure $chan -buffering } -result [expr {$chan eq "stdout" ? "line" : "none"}] + + test console-fconfigure-get-$major.[incr testnum] { + fconfigure -inputmode + } -body { + fconfigure $chan -inputmode + } -result {bad option "-inputmode": should be one of -blocking, -buffering, -buffersize, -encoding, -eofchar, -translation, or -winsize} -returnCodes error + } +## fconfigure set stdin + +test console-fconfigure-set-1.0 { + fconfigure -inputmode password +} -constraints {win interactive} -body { + set result {} + + prompt "Type \"pass\" and hit Enter. You should NOT see characters echoed: " + fconfigure stdin -inputmode password + lappend result [gets stdin] + lappend result [fconfigure stdin -inputmode] + fconfigure stdin -inputmode normal + lappend result [yesno "\nWere the characters echoed?"] + + prompt "Type \"norm\" and hit Enter. You should see characters echoed: " + lappend result [gets stdin] + lappend result [fconfigure stdin -inputmode] + lappend result [yesno "Were the characters echoed?"] + + set result +} -result [list pass password 0 norm normal 1] + +test console-fconfigure-set-1.1 { + fconfigure -inputmode raw +} -constraints {win interactive} -body { + set result {} + + prompt "Type the keys \"a\", Ctrl-H, \"b\". Do NOT hit Enter. You should NOT see characters echoed: " + fconfigure stdin -inputmode raw + lappend result [read stdin 3] + lappend result [fconfigure stdin -inputmode] + fconfigure stdin -inputmode normal + lappend result [yesno "\nWere the characters echoed?"] + + prompt "\nType the keys \"c\", Ctrl-H, \"d\" and hit Enter. You should see characters echoed: " + lappend result [gets stdin] + lappend result [fconfigure stdin -inputmode] + lappend result [yesno "\nWere the characters echoed (c replaced by d)?"] + + set result +} -result [list a\x08b raw 0 d normal 1] + +test console-fconfigure-set-1.2 { + fconfigure -inputmode reset +} -constraints {win interactive} -body { + set result {} + + prompt "Type \"pass\" and hit Enter. You should NOT see characters echoed: " + fconfigure stdin -inputmode password + lappend result [gets stdin] + lappend result [fconfigure stdin -inputmode] + fconfigure stdin -inputmode reset + lappend result [yesno "\nWere the characters echoed?"] + + prompt "Type \"reset\" and hit Enter. You should see characters echoed: " + lappend result [gets stdin] + lappend result [fconfigure stdin -inputmode] + lappend result [yesno "Were the characters echoed?"] + + set result +} -result [list pass password 0 reset normal 1] + +test console-fconfigure-set-1.3 { + fconfigure stdin -winsize +} -body { + fconfigure stdin -winsize {10 30} +} -result {bad option "-winsize": should be one of -blocking, -buffering, -buffersize, -encoding, -eofchar, -translation, or -inputmode} -returnCodes error + +## fconfigure set stdout,stderr + +test console-fconfigure-set-2.0 { + fconfigure stdout -winsize +} -body { + fconfigure stdout -winsize {10 30} +} -result {bad option "-winsize": should be one of -blocking, -buffering, -buffersize, -encoding, -eofchar, or -translation} -returnCodes error + +test console-fconfigure-set-3.0 { + fconfigure stderr -winsize +} -body { + fconfigure stderr -winsize {10 30} +} -result {bad option "-winsize": should be one of -blocking, -buffering, -buffersize, -encoding, -eofchar, or -translation} -returnCodes error -#cleanup +# Multiple threads + +test console-thread-input-1.0 {Get input in thread} -constraints { + win interactive haveThread +} -setup { + set tid [thread::create] +} -cleanup { + thread::release $tid +} -body { + prompt "Type \"xyz\" and hit Enter: " + thread::send $tid {gets stdin} +} -result xyz + +test console-thread-output-1.0 {Output from thread} -constraints { + win interactive haveThread +} -setup { + set tid [thread::create] +} -cleanup { + thread::release $tid +} -body { + thread::send $tid {puts [thread::id]} + yesno "Did you see $tid printed?" +} -result 1 ::tcltest::cleanupTests return diff --git a/win/tclWinConsole.c b/win/tclWinConsole.c index 4f67b64..2e60c91 100644 --- a/win/tclWinConsole.c +++ b/win/tclWinConsole.c @@ -1014,11 +1014,20 @@ ConsoleCloseProc( */ AcquireSRWLockShared(&handleInfoPtr->lock); - handleInfoPtr->numRefs -= 1; /* Remove reference from this channel */ - handleInfoPtr->console = INVALID_HANDLE_VALUE; + if (closeHandle) { + handleInfoPtr->console = INVALID_HANDLE_VALUE; + } /* Break the thread out of blocking console i/o */ - CancelSynchronousIo(handleInfoPtr->consoleThread); + handleInfoPtr->numRefs -= 1; /* Remove reference from this channel */ + if (handleInfoPtr->numRefs == 1) { + /* + * Abort the i/o if no other threads are listening on it. + * Note without this check, an input line will be skipped on + * the cancel. + */ + CancelSynchronousIo(handleInfoPtr->consoleThread); + } /* * Wake up the console handling thread. Note we do not explicitly @@ -1113,7 +1122,11 @@ ConsoleInputProc( */ if (numRead != 0) { /* If console thread was blocked, awaken it */ - // XXX WakeConditionVariable(&handleInfoPtr->consoleThreadCV); + if (chanInfoPtr->flags & CONSOLE_ASYNC) { + /* Async channels always want read ahead */ + handleInfoPtr->flags |= CONSOLE_DATA_AWAITED; + WakeConditionVariable(&handleInfoPtr->consoleThreadCV); + } break; } /* @@ -1167,6 +1180,11 @@ ConsoleInputProc( } /* Lock is reacquired, loop back to try again */ } + if (chanInfoPtr->flags & CONSOLE_ASYNC) { + /* Async channels always want read ahead */ + handleInfoPtr->flags |= CONSOLE_DATA_AWAITED; + WakeConditionVariable(&handleInfoPtr->consoleThreadCV); + } ReleaseSRWLockExclusive(&handleInfoPtr->lock); return numRead; @@ -2186,12 +2204,13 @@ ConsoleSetOptionProc( return TCL_ERROR; } if (Tcl_UtfNcasecmp(value, "NORMAL", vlen) == 0) { - mode |= ENABLE_ECHO_INPUT | ENABLE_LINE_INPUT; + mode |= + ENABLE_ECHO_INPUT | ENABLE_LINE_INPUT | ENABLE_PROCESSED_INPUT; } else if (Tcl_UtfNcasecmp(value, "PASSWORD", vlen) == 0) { - mode |= ENABLE_LINE_INPUT; + mode |= ENABLE_LINE_INPUT|ENABLE_PROCESSED_INPUT; mode &= ~ENABLE_ECHO_INPUT; } else if (Tcl_UtfNcasecmp(value, "RAW", vlen) == 0) { - mode &= ~(ENABLE_ECHO_INPUT | ENABLE_LINE_INPUT); + mode &= ~(ENABLE_ECHO_INPUT | ENABLE_LINE_INPUT | ENABLE_PROCESSED_INPUT); } else if (Tcl_UtfNcasecmp(value, "RESET", vlen) == 0) { /* * Reset to the initial mode, whatever that is. -- cgit v0.12 From 403569ef177348b14d7bfb85c2a488ecaf0a2117 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 7 Jul 2022 10:59:46 +0000 Subject: Unnecessary quotes in win/rules.vc --- win/rules.vc | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/win/rules.vc b/win/rules.vc index db65ce7..fdc68e0 100644 --- a/win/rules.vc +++ b/win/rules.vc @@ -1418,7 +1418,7 @@ OPTDEFINES = $(OPTDEFINES) /DTCL_CFG_DO64BIT OPTDEFINES = $(OPTDEFINES) /DNO_STRTOI64=1 !endif -!if "$(TCL_MAJOR_VERSION)" == "8" +!if $(TCL_MAJOR_VERSION) == 8 !if "$(_USE_64BIT_TIME_T)" == "1" OPTDEFINES = $(OPTDEFINES) /D_USE_64BIT_TIME_T=1 !endif -- cgit v0.12 From 063aecb05d90ef87d7178fe8dd5d8948052156e8 Mon Sep 17 00:00:00 2001 From: apnadkarni Date: Sun, 10 Jul 2022 10:21:06 +0000 Subject: Bypass reader thread for blocking reads. --- tests/winConsole.test | 20 ++++---- win/tclWinConsole.c | 129 +++++++++++++++++++++++++++++++++++++++++--------- 2 files changed, 115 insertions(+), 34 deletions(-) diff --git a/tests/winConsole.test b/tests/winConsole.test index cb1babc..d008d5c 100644 --- a/tests/winConsole.test +++ b/tests/winConsole.test @@ -45,13 +45,13 @@ proc prompt {prompt} { # Input tests -test console-gets-1.0 {Console blocking gets} -constraints {win interactive} -body { +test console-input-1.0 {Console blocking gets} -constraints {win interactive} -body { prompt "Type \"xyz\" and hit Enter: " gets stdin } -result xyz -test console-gets-1.1 {Console file channel: non-blocking gets} -constraints { - win interactive tbd +test console-input-1.1 {Console file channel: non-blocking gets} -constraints { + win interactive } -body { set oldmode [fconfigure stdin] @@ -72,25 +72,23 @@ test console-gets-1.1 {Console file channel: non-blocking gets} -constraints { #cleanup the fileevent fileevent stdin readable {} fconfigure stdin {*}$oldmode - puts [fconfigure stdin] set result } -result abc -test console-read-1.0 {Console blocking read} -constraints {win interactive} -setup { +test console-input-2.0 {Console blocking read} -constraints {win interactive} -setup { set oldmode [fconfigure stdin] fconfigure stdin -inputmode raw } -cleanup { fconfigure stdin {*}$oldmode } -body { - puts [fconfigure stdin] prompt "Type the key \"a\". Do NOT hit Enter. You will NOT see characters echoed." set c [read stdin 1] puts "" set c } -result a -test console-read-1.1 {Console file channel: non-blocking read} -constraints { +test console-input-2.1 {Console file channel: non-blocking read} -constraints { win interactive } -setup { set oldmode [fconfigure stdin] @@ -118,18 +116,18 @@ test console-read-1.1 {Console file channel: non-blocking read} -constraints { set result {} vwait result fileevent stdin readable {} - puts "" set result } -result abc # Output tests -test console-puts-1.0 {Console blocking puts stdout} -constraints {win interactive} -body { +test console-output-1.0 {Console blocking puts stdout} -constraints {win interactive} -body { + puts [fconfigure stdin] puts stdout "123" yesno "Did you see the string \"123\"?" } -result 1 -test console-puts-1.1 {Console non-blocking puts stdout} -constraints { +test console-output-1.1 {Console non-blocking puts stdout} -constraints { win interactive } -setup { set oldmode [fconfigure stdout] @@ -151,7 +149,7 @@ test console-puts-1.1 {Console non-blocking puts stdout} -constraints { yesno "Did you see 1, 2, 3 printed on consecutive lines?" } -result 1 -test console-puts-2.0 {Console blocking puts stderr} -constraints {win interactive} -body { +test console-output-2.0 {Console blocking puts stderr} -constraints {win interactive} -body { puts stderr "456" yesno "Did you see the string \"456\"?" } -result 1 diff --git a/win/tclWinConsole.c b/win/tclWinConsole.c index 2e60c91..2cc16d9 100644 --- a/win/tclWinConsole.c +++ b/win/tclWinConsole.c @@ -27,7 +27,7 @@ * corresponding to stdin, stdout, stderr) * * - Consoles are created / inherited at process startup. There is currently - * no way in Tcl to programmatically create a console. Even if there were + * no way in Tcl to programmatically create a console. Even if these were * added the above Windows limitation would still apply. * * - Unlike files, sockets etc. where there is a one-to-one @@ -37,8 +37,7 @@ * * - Even with multiple threads, more than one file event handler is unlikely. * It does not make sense for multiple threads to register handlers for - * stdin because the input would be randomly fragmented amongst the threads - * (not even on a per line basis). + * stdin because the input would be randomly fragmented amongst the threads. * * Various design factors are driven by the above, e.g. use of lists instead * of hash tables (at most 3 console handles) and use of global instead of @@ -48,14 +47,8 @@ * * Some additional design notes/reminders for the future: * - * All input is done through the reader thread, even synchronous reads of - * stdin which in theory could be done directly by the interpreter threads. - * This is because I'm not entirely confident about multithreaded access to - * the ReadConsole API (probably ok since Microsoft does not warn against - * this) and also the API requires reading an even number of bytes (WCHAR) - * while the channel callback has no such restriction (in theory). - * Accounting for that in the callbacks is doable but slightly tricky while - * straightforward in the reader thread because of its double buffering. + * Aligned, synchronous reads are done directly by interpreter thread. + * Unaligned or asynchronous reads are done through the reader thread. * * The reader thread does not read ahead. That is, it will not post a read * until some interpreter thread is actually requesting a read. This is @@ -1153,9 +1146,6 @@ ConsoleInputProc( chanInfoPtr->handle = INVALID_HANDLE_VALUE; break; } - /* Request console reader thread for data */ - handleInfoPtr->flags |= CONSOLE_DATA_AWAITED; - WakeConditionVariable(&handleInfoPtr->consoleThreadCV); /* For async, tell caller we are blocked */ if (chanInfoPtr->flags & CONSOLE_ASYNC) { @@ -1165,10 +1155,51 @@ ConsoleInputProc( } /* + * Blocking read. Just get data from directly from console. There + * is a small complication in that we can only read even number + * of bytes (wide-character API) and the destination buffer should be + * WCHAR aligned. If either condition is not met, we defer to the + * reader thread which handles these case rather than dealing with + * them here (which is a little trickier than it might sound.) + */ + if ((1 & (ptrdiff_t)bufPtr) == 0 /* aligned buffer */ + && bufSize > 1 /* Not single byte read */ + ) { + DWORD lastError; + RingSizeT numChars; + ReleaseSRWLockExclusive(&handleInfoPtr->lock); + lastError = ReadConsoleChars(chanInfoPtr->handle, + (WCHAR *)bufPtr, + bufSize / sizeof(WCHAR), + &numChars); + /* NOTE lock released so DON'T break. Return instead */ + if (lastError != ERROR_SUCCESS) { + Tcl_WinConvertError(lastError); + *errorCode = Tcl_GetErrno(); + return -1; + } + else if (numChars > 0) { + /* Successfully read something. */ + return numChars * sizeof(WCHAR); + } + else { + /* + * Ctrl-C/Ctrl-Brk interrupt. Loop around to retry. + * We have to reacquire the lock. No worried about handleInfoPtr + * having gone away since the channel holds a reference. + */ + AcquireSRWLockExclusive(&handleInfoPtr->lock); + continue; + } + } + /* + * Deferring blocking read to reader thread. * Release the lock and sleep. Note that because the channel * holds a reference count on handleInfoPtr, it will not * be deallocated while the lock is released. */ + handleInfoPtr->flags |= CONSOLE_DATA_AWAITED; + WakeConditionVariable(&handleInfoPtr->consoleThreadCV); if (!SleepConditionVariableSRW(&handleInfoPtr->interpThreadCV, &handleInfoPtr->lock, INFINITE, @@ -1178,10 +1209,11 @@ ConsoleInputProc( numRead = -1; break; } + /* Lock is reacquired, loop back to try again */ } + if (chanInfoPtr->flags & CONSOLE_ASYNC) { - /* Async channels always want read ahead */ handleInfoPtr->flags |= CONSOLE_DATA_AWAITED; WakeConditionVariable(&handleInfoPtr->consoleThreadCV); } @@ -1541,6 +1573,49 @@ ConsoleGetHandleProc( } /* + *------------------------------------------------------------------------ + * + * ConsoleDataAvailable -- + * + * Checks if there is data in the console input queue. + * + * Results: + * Returns 1 if the input queue has data, -1 on error else 0 if empty. + * + * Side effects: + * None. + * + *------------------------------------------------------------------------ + */ + static int + ConsoleDataAvailable (HANDLE consoleHandle) +{ + INPUT_RECORD input[5]; + DWORD count; + DWORD i; + + /* + * Need at least one keyboard event. + */ + if (PeekConsoleInputW( + consoleHandle, input, sizeof(input) / sizeof(input[0]), &count) + == FALSE) { + return -1; + } + for (i = 0; i < count; ++i) { + /* + * Event must be a keydown because a trailing LF keyup event is always + * present for line based input. + */ + if (input[i].EventType == KEY_EVENT + && input[i].Event.KeyEvent.bKeyDown) { + return 1; + } + } + return 0; +} + +/* *---------------------------------------------------------------------- * * ConsoleReaderThread -- @@ -1563,7 +1638,6 @@ ConsoleReaderThread( { ConsoleHandleInfo *handleInfoPtr = (ConsoleHandleInfo *) arg; ConsoleHandleInfo **iterator; - BOOL success; char inputChars[200]; /* Temporary buffer */ RingSizeT inputLen = 0; RingSizeT inputOffset = 0; @@ -1655,7 +1729,8 @@ ConsoleReaderThread( * for password input. So only do so if at least one interpreter has * requested data. */ - if (handleInfoPtr->flags & CONSOLE_DATA_AWAITED) { + if ((handleInfoPtr->flags & CONSOLE_DATA_AWAITED) + && ConsoleDataAvailable(handleInfoPtr->console)) { DWORD error; /* Do not hold the lock while blocked in console */ ReleaseSRWLockExclusive(&handleInfoPtr->lock); @@ -1682,11 +1757,20 @@ ConsoleReaderThread( } } else { - /* Wait until an interp thread asks for data. */ - success = SleepConditionVariableSRW(&handleInfoPtr->consoleThreadCV, - &handleInfoPtr->lock, - INFINITE, - 0); + /* + * Either no one was asking for data, or no data was available. + * In the former case, wait until someone wakes us asking for + * data. In the latter case, there is no alternative but to + * poll since ReadConsole does not support async operation. + * So sleep for a short while and loop back to retry. + */ + DWORD sleepTime; + sleepTime = + handleInfoPtr->flags & CONSOLE_DATA_AWAITED ? 50 : INFINITE; + SleepConditionVariableSRW(&handleInfoPtr->consoleThreadCV, + &handleInfoPtr->lock, + sleepTime, + 0); } /* Loop again to check for exit or wait for readers to wake us */ @@ -1884,7 +1968,6 @@ ConsoleWriterThread(LPVOID arg) RingBufferClear(&handleInfoPtr->buffer); - ckfree(handleInfoPtr); return 0; -- cgit v0.12 From ea55b6cb74c6189bf0a9ce55a94e14c59875af91 Mon Sep 17 00:00:00 2001 From: apnadkarni Date: Sun, 10 Jul 2022 14:41:19 +0000 Subject: Blech. Remove unused variable --- win/tclWinConsole.c | 1 - 1 file changed, 1 deletion(-) diff --git a/win/tclWinConsole.c b/win/tclWinConsole.c index 2cc16d9..114b302 100644 --- a/win/tclWinConsole.c +++ b/win/tclWinConsole.c @@ -1107,7 +1107,6 @@ ConsoleInputProc( ReleaseSRWLockShared(&gConsoleLock); /* AFTER acquiring handleInfoPtr->lock */ while (1) { - int freeSpace = RingBufferFreeSpace(&handleInfoPtr->buffer); numRead = RingBufferOut(&handleInfoPtr->buffer, bufPtr, bufSize, 1); /* * Note: even if channel is closed or has an error, as long there is -- cgit v0.12 From 4a38609129a5103a58655c4f4789012c1144f5c7 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Sun, 10 Jul 2022 20:40:15 +0000 Subject: Minor simplification: Use RingBufferHasFreeSpace() instead of RingBufferFreeSpace --- win/tclWinConsole.c | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/win/tclWinConsole.c b/win/tclWinConsole.c index 114b302..4a9a2df 100644 --- a/win/tclWinConsole.c +++ b/win/tclWinConsole.c @@ -97,7 +97,7 @@ typedef struct RingBuffer { RingSizeT length; /* Number of RingBufferChar*/ } RingBuffer; #define RingBufferLength(ringPtr_) ((ringPtr_)->length) -#define RingBufferFreeSpace(ringPtr_) ((ringPtr_)->capacity - (ringPtr_)->length) +#define RingBufferHasFreeSpace(ringPtr_) ((ringPtr_)->length < (ringPtr_)->capacity) #define RINGBUFFER_ASSERT(ringPtr_) assert(RingBufferCheck(ringPtr_)) /* @@ -795,7 +795,7 @@ ConsoleSetupProc( } } else if (chanInfoPtr->watchMask & TCL_WRITABLE) { - if (RingBufferFreeSpace(&handleInfoPtr->buffer) > 0) { + if (RingBufferHasFreeSpace(&handleInfoPtr->buffer)) { /* TCL_WRITABLE */ block = 0; /* Output space available */ } @@ -878,7 +878,7 @@ ConsoleCheckProc( } } else if (chanInfoPtr->watchMask & TCL_WRITABLE) { - if (RingBufferFreeSpace(&handleInfoPtr->buffer) > 0) { + if (RingBufferHasFreeSpace(&handleInfoPtr->buffer)) { needEvent = 1; /* Output space available */ } } @@ -1429,7 +1429,7 @@ ConsoleEventProc( mask = TCL_READABLE; } else if ((chanInfoPtr->watchMask & TCL_WRITABLE) - && RingBufferFreeSpace(&handleInfoPtr->buffer) > 0) { + && RingBufferHasFreeSpace(&handleInfoPtr->buffer)) { /* Generate write event space available */ mask = TCL_WRITABLE; } -- cgit v0.12 From b88529b2f5c7184710ca00b133bccd5660daf989 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 11 Jul 2022 11:24:10 +0000 Subject: Add "win" constraints to tests/winConsole.test, and change one expected test-results on Windows --- tests/winConsole.test | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/tests/winConsole.test b/tests/winConsole.test index d008d5c..a9d9b09 100644 --- a/tests/winConsole.test +++ b/tests/winConsole.test @@ -187,7 +187,7 @@ test console-fconfigure-get-1.[incr testnum] { test console-fconfigure-get-1.[incr testnum] { fconfigure -winsize -} -body { +} -constraints win -body { fconfigure stdin -winsize } -result {bad option "-winsize": should be one of -blocking, -buffering, -buffersize, -encoding, -eofchar, -translation, or -inputmode} -returnCodes error @@ -221,9 +221,9 @@ foreach chan {stdout stderr} major {2 3} { test console-fconfigure-get-$major.[incr testnum] { fconfigure -inputmode - } -body { + } -constraints win -body { fconfigure $chan -inputmode - } -result {bad option "-inputmode": should be one of -blocking, -buffering, -buffersize, -encoding, -eofchar, -translation, or -winsize} -returnCodes error + } -result {bad option "-inputmode": should be one of -blocking, -buffering, -buffersize, -encoding, -eofchar, or -translation} -returnCodes error } @@ -291,7 +291,7 @@ test console-fconfigure-set-1.2 { test console-fconfigure-set-1.3 { fconfigure stdin -winsize -} -body { +} -constraints win -body { fconfigure stdin -winsize {10 30} } -result {bad option "-winsize": should be one of -blocking, -buffering, -buffersize, -encoding, -eofchar, -translation, or -inputmode} -returnCodes error -- cgit v0.12 From 91982ba7527160c9c64c671e494999b3dbf54490 Mon Sep 17 00:00:00 2001 From: apnadkarni Date: Tue, 12 Jul 2022 03:10:50 +0000 Subject: Fix Windows console fconfigure tests to require interactive constraint. Note this means tests are disabled when run with nmake test --- tests/winConsole.test | 19 ++++++++++--------- 1 file changed, 10 insertions(+), 9 deletions(-) diff --git a/tests/winConsole.test b/tests/winConsole.test index a9d9b09..0daf54c 100644 --- a/tests/winConsole.test +++ b/tests/winConsole.test @@ -122,7 +122,6 @@ test console-input-2.1 {Console file channel: non-blocking read} -constraints { # Output tests test console-output-1.0 {Console blocking puts stdout} -constraints {win interactive} -body { - puts [fconfigure stdin] puts stdout "123" yesno "Did you see the string \"123\"?" } -result 1 @@ -187,7 +186,7 @@ test console-fconfigure-get-1.[incr testnum] { test console-fconfigure-get-1.[incr testnum] { fconfigure -winsize -} -constraints win -body { +} -constraints {win interactive} -body { fconfigure stdin -winsize } -result {bad option "-winsize": should be one of -blocking, -buffering, -buffersize, -encoding, -eofchar, -translation, or -inputmode} -returnCodes error @@ -211,19 +210,21 @@ foreach chan {stdout stderr} major {2 3} { } -result $result } - test console-fconfigure-get-$major.[incr testnum] "Console get $chan option -winsize" -constraints {win interactive} -body { + test console-fconfigure-get-$major.[incr testnum] "Console get $chan option -winsize" \ + -constraints {win interactive} -body { fconfigure $chan -winsize } -result {\d+ \d+} -match regexp - test console-fconfigure-get-$major.[incr testnum] "Console get $chan option -buffering" -constraints {win interactive} -body { + test console-fconfigure-get-$major.[incr testnum] "Console get $chan option -buffering" \ + -constraints {win interactive} -body { fconfigure $chan -buffering } -result [expr {$chan eq "stdout" ? "line" : "none"}] test console-fconfigure-get-$major.[incr testnum] { fconfigure -inputmode - } -constraints win -body { + } -constraints {win interactive} -body { fconfigure $chan -inputmode - } -result {bad option "-inputmode": should be one of -blocking, -buffering, -buffersize, -encoding, -eofchar, or -translation} -returnCodes error + } -result {bad option "-inputmode": should be one of -blocking, -buffering, -buffersize, -encoding, -eofchar, -translation, or -winsize} -returnCodes error } @@ -291,7 +292,7 @@ test console-fconfigure-set-1.2 { test console-fconfigure-set-1.3 { fconfigure stdin -winsize -} -constraints win -body { +} -constraints {win interactive} -body { fconfigure stdin -winsize {10 30} } -result {bad option "-winsize": should be one of -blocking, -buffering, -buffersize, -encoding, -eofchar, -translation, or -inputmode} -returnCodes error @@ -299,13 +300,13 @@ test console-fconfigure-set-1.3 { test console-fconfigure-set-2.0 { fconfigure stdout -winsize -} -body { +} -constraints {win interactive} -body { fconfigure stdout -winsize {10 30} } -result {bad option "-winsize": should be one of -blocking, -buffering, -buffersize, -encoding, -eofchar, or -translation} -returnCodes error test console-fconfigure-set-3.0 { fconfigure stderr -winsize -} -body { +} -constraints {win interactive} -body { fconfigure stderr -winsize {10 30} } -result {bad option "-winsize": should be one of -blocking, -buffering, -buffersize, -encoding, -eofchar, or -translation} -returnCodes error -- cgit v0.12 From 505c18d593b11fa682694a7653b17b325c1aac0e Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 12 Jul 2022 08:20:45 +0000 Subject: Code cleanup (use {} in if/else statemenets) --- generic/regexec.c | 15 +++++++++------ generic/tclClock.c | 4 ++-- generic/tclCmdMZ.c | 2 +- generic/tclUtf.c | 3 +-- win/tclWinDde.c | 4 ++-- win/tclWinLoad.c | 5 +++-- 6 files changed, 18 insertions(+), 15 deletions(-) diff --git a/generic/regexec.c b/generic/regexec.c index d0d5680..0ab3c88 100644 --- a/generic/regexec.c +++ b/generic/regexec.c @@ -237,10 +237,11 @@ exec( v->err = 0; assert(v->g->ntree >= 0); n = (size_t) v->g->ntree; - if (n <= LOCALDFAS) + if (n <= LOCALDFAS) { v->subdfas = subdfas; - else + } else { v->subdfas = (struct dfa **) MALLOC(n * sizeof(struct dfa *)); + } if (v->subdfas == NULL) { if (v->pmatch != pmatch && v->pmatch != mat) FREE(v->pmatch); @@ -641,10 +642,11 @@ cdissect( break; case '.': /* concatenation */ assert(t->left != NULL && t->right != NULL); - if (t->left->flags & SHORTER) /* reverse scan */ + if (t->left->flags & SHORTER) {/* reverse scan */ er = crevcondissect(v, t, begin, end); - else + } else { er = ccondissect(v, t, begin, end); + } break; case '|': /* alternation */ assert(t->left != NULL); @@ -652,10 +654,11 @@ cdissect( break; case '*': /* iteration */ assert(t->left != NULL); - if (t->left->flags & SHORTER) /* reverse scan */ + if (t->left->flags & SHORTER) {/* reverse scan */ er = creviterdissect(v, t, begin, end); - else + } else { er = citerdissect(v, t, begin, end); + } break; case '(': /* capturing */ assert(t->left != NULL && t->right == NULL); diff --git a/generic/tclClock.c b/generic/tclClock.c index ca1df44..13a5c65 100644 --- a/generic/tclClock.c +++ b/generic/tclClock.c @@ -1520,9 +1520,9 @@ GetJulianDayFromEraYearMonthDay( * Have to make sure quotient is truncated towards 0 when negative. * See above bug for details. The casts are necessary. */ - if (ym1 >= 0) + if (ym1 >= 0) { ym1o4 = ym1 / 4; - else { + } else { ym1o4 = - (int) (((unsigned int) -ym1) / 4); } #endif diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c index c94abbd..3ff9947 100644 --- a/generic/tclCmdMZ.c +++ b/generic/tclCmdMZ.c @@ -2845,7 +2845,7 @@ TclStringCmp( if (checkEq && (s1len != s2len)) { match = 1; /* This will be reversed below. */ - } else { + } else { /* * The comparison function should compare up to the minimum byte * length only. diff --git a/generic/tclUtf.c b/generic/tclUtf.c index bcae055..8931b39 100644 --- a/generic/tclUtf.c +++ b/generic/tclUtf.c @@ -448,8 +448,7 @@ Tcl_UtfToUniChar( * A three-byte-character lead-byte not followed by two trail-bytes * represents itself. */ - } - else if (byte < 0xF5) { + } else if (byte < 0xF5) { if (((src[1] & 0xC0) == 0x80) && ((src[2] & 0xC0) == 0x80)) { /* * Four-byte-character lead byte followed by at least two trail bytes. diff --git a/win/tclWinDde.c b/win/tclWinDde.c index 2570954..1c10c65 100644 --- a/win/tclWinDde.c +++ b/win/tclWinDde.c @@ -1789,9 +1789,9 @@ DdeObjCmd( } if (result == TCL_OK) { - if (objc == 1) + if (objc == 1) { objPtr = objv[0]; - else { + } else { objPtr = Tcl_ConcatObj(objc, objv); } if (riPtr->handlerPtr != NULL) { diff --git a/win/tclWinLoad.c b/win/tclWinLoad.c index 1d64d18..9d2d87e 100644 --- a/win/tclWinLoad.c +++ b/win/tclWinLoad.c @@ -112,10 +112,11 @@ TclpDlopen( * first error for reporting purposes. */ if (firstError == ERROR_MOD_NOT_FOUND || - firstError == ERROR_DLL_NOT_FOUND) + firstError == ERROR_DLL_NOT_FOUND) { lastError = GetLastError(); - else + } else { lastError = firstError; + } errMsg = Tcl_ObjPrintf("couldn't load library \"%s\": ", Tcl_GetString(pathPtr)); -- cgit v0.12 From f55203403c6ec05a55134dcfea129095e91c098e Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 12 Jul 2022 12:23:54 +0000 Subject: Fix [b79df322a9] follow-up: Tcl_NewUnicodeObj truncates strings --- generic/tclStringObj.c | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/generic/tclStringObj.c b/generic/tclStringObj.c index 86b3937..10a8627 100644 --- a/generic/tclStringObj.c +++ b/generic/tclStringObj.c @@ -984,7 +984,11 @@ TclGetUnicodeFromObj( { String *stringPtr; +#if TCL_UTF_MAX > 3 + SetUTF16StringFromAny(NULL, objPtr); +#else SetStringFromAny(NULL, objPtr); +#endif stringPtr = GET_STRING(objPtr); if (lengthPtr != NULL) { -- cgit v0.12 From 1e6f410bd20b8576dbd0be31a153d56d48a1dae4 Mon Sep 17 00:00:00 2001 From: apnadkarni Date: Tue, 12 Jul 2022 12:31:57 +0000 Subject: Fix [b79df322a9]. Tcl_GetUnicode/Tcl_NewUnicodeObj crash. Add tests --- generic/tclStringObj.c | 31 ++++++++++++++++++++++--------- generic/tclTest.c | 41 +++++++++++++++++++++++++++++++++++++++++ tests/string.test | 12 ++++++++++++ 3 files changed, 75 insertions(+), 9 deletions(-) diff --git a/generic/tclStringObj.c b/generic/tclStringObj.c index 86b3937..852c4ff 100644 --- a/generic/tclStringObj.c +++ b/generic/tclStringObj.c @@ -68,6 +68,7 @@ static int SetStringFromAny(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 int UTF16Length(const unsigned short *unicode); static void UpdateStringOfString(Tcl_Obj *objPtr); #if (TCL_UTF_MAX) > 3 && !defined(TCL_NO_DEPRECATED) static void DupUTF16StringInternalRep(Tcl_Obj *objPtr, @@ -562,6 +563,10 @@ Tcl_NewUnicodeObj( TclNewObj(objPtr); TclInvalidateStringRep(objPtr); + if (numChars < 0) { + numChars = UTF16Length(unicode); + } + String *stringPtr = (String *)ckalloc((offsetof(String, unicode) + sizeof(unsigned short)) + numChars * sizeof(unsigned short)); memcpy(stringPtr->unicode, unicode, numChars * sizeof(unsigned short)); @@ -984,7 +989,7 @@ TclGetUnicodeFromObj( { String *stringPtr; - SetStringFromAny(NULL, objPtr); + SetUTF16StringFromAny(NULL, objPtr); stringPtr = GET_STRING(objPtr); if (lengthPtr != NULL) { @@ -1451,14 +1456,7 @@ Tcl_SetUnicodeObj( String *stringPtr; if (numChars < 0) { - numChars = 0; - - if (unicode) { - while (numChars >= 0 && unicode[numChars] != 0) { - numChars++; - } - } - stringCheckLimits(numChars); + numChars = UTF16Length(unicode); } /* @@ -1482,6 +1480,21 @@ Tcl_SetUnicodeObj( #endif static int +UTF16Length( + const unsigned short *ucs2Ptr) +{ + int numChars = 0; + + if (ucs2Ptr) { + while (numChars >= 0 && ucs2Ptr[numChars] != 0) { + numChars++; + } + } + stringCheckLimits(numChars); + return numChars; +} + +static int UnicodeLength( const Tcl_UniChar *unicode) { diff --git a/generic/tclTest.c b/generic/tclTest.c index b2632f0..bf5741c 100644 --- a/generic/tclTest.c +++ b/generic/tclTest.c @@ -222,6 +222,7 @@ static Tcl_ObjCmdProc TestbytestringObjCmd; static Tcl_ObjCmdProc TestsetbytearraylengthObjCmd; static Tcl_ObjCmdProc TestpurebytesobjObjCmd; static Tcl_ObjCmdProc TeststringbytesObjCmd; +static Tcl_ObjCmdProc Testutf16stringObjCmd; static Tcl_CmdProc TestcmdinfoCmd; static Tcl_CmdProc TestcmdtokenCmd; static Tcl_CmdProc TestcmdtraceCmd; @@ -560,6 +561,7 @@ Tcltest_Init( Tcl_CreateObjCommand(interp, "testsetbytearraylength", TestsetbytearraylengthObjCmd, NULL, NULL); Tcl_CreateObjCommand(interp, "testbytestring", TestbytestringObjCmd, NULL, NULL); Tcl_CreateObjCommand(interp, "teststringbytes", TeststringbytesObjCmd, NULL, NULL); + Tcl_CreateObjCommand(interp, "testutf16string", Testutf16stringObjCmd, NULL, NULL); Tcl_CreateObjCommand(interp, "testwrongnumargs", TestWrongNumArgsObjCmd, NULL, NULL); Tcl_CreateObjCommand(interp, "testfilesystem", TestFilesystemObjCmd, @@ -5176,6 +5178,45 @@ TestbytestringObjCmd( /* *---------------------------------------------------------------------- * + * Testutf16stringObjCmd -- + * + * This specifically tests the Tcl_GetUnicode and Tcl_NewUnicodeObj + * C functions which broke in Tcl 8.7 and were undetected by the + * existing test suite. Bug [b79df322a9] + * + * Results: + * Returns the TCL_OK result code. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +Testutf16stringObjCmd( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* The argument objects. */ +{ + int n = 0; + const Tcl_UniChar *p; + (void)dummy; + + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, "string"); + return TCL_ERROR; + } + + p = Tcl_GetUnicode(objv[1]); + Tcl_SetObjResult(interp, Tcl_NewUnicodeObj(p, -1)); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * * TestsetCmd -- * * Implements the "testset{err,noerr}" cmds that are used when testing diff --git a/tests/string.test b/tests/string.test index d497b42..d128a0b 100644 --- a/tests/string.test +++ b/tests/string.test @@ -34,6 +34,7 @@ testConstraint testindexobj [expr {[info commands testindexobj] ne {}}] testConstraint testevalex [expr {[info commands testevalex] ne {}}] testConstraint utf16 [expr {[string length \U010000] == 2}] testConstraint testbytestring [llength [info commands testbytestring]] +testConstraint testutf16string [llength [info commands testutf16string]] # Used for constraining memory leak tests testConstraint memory [llength [info commands memory]] @@ -2635,6 +2636,17 @@ test string-32.17.$noComp {string is dict, valid dict packed in invalid dict} { } 0 }; # foreach noComp {0 1} + +test string-bug-b79df322a9 {Tcl_GetUnicode/Tcl_NewUnicodeObj api} -constraints { + testutf16string +} -body { + # This simple test suffices because the bug has nothing to do with + # the actual encoding conversion. The test was added because these + # functions are no longer called within the Tcl core and thus + # not tested by either `string`, not `encoding` tests. + testutf16string "abcde" +} -result abcde + # cleanup rename MemStress {} -- cgit v0.12 From a3eea6dc3f9b7ffcbcff6b1ee933f9ef1189df3f Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 13 Jul 2022 07:33:57 +0000 Subject: Fix build with -DTCL_NO_DEPRECATED --- generic/tclStringObj.c | 6 +++++- generic/tclStubInit.c | 1 + generic/tclTest.c | 6 ++---- tests/string.test | 2 +- 4 files changed, 9 insertions(+), 6 deletions(-) diff --git a/generic/tclStringObj.c b/generic/tclStringObj.c index 130379f..b9d603d 100644 --- a/generic/tclStringObj.c +++ b/generic/tclStringObj.c @@ -68,7 +68,9 @@ static int SetStringFromAny(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); +#if !defined(TCL_NO_DEPRECATED) static int UTF16Length(const unsigned short *unicode); +#endif static void UpdateStringOfString(Tcl_Obj *objPtr); #if (TCL_UTF_MAX) > 3 && !defined(TCL_NO_DEPRECATED) static void DupUTF16StringInternalRep(Tcl_Obj *objPtr, @@ -979,6 +981,7 @@ Tcl_GetUnicodeFromObj( } #endif +#if !defined(TCL_NO_DEPRECATED) unsigned short * TclGetUnicodeFromObj( Tcl_Obj *objPtr, /* The object to find the unicode string @@ -1001,6 +1004,7 @@ TclGetUnicodeFromObj( } return stringPtr->unicode; } +#endif /* *---------------------------------------------------------------------- @@ -1481,7 +1485,6 @@ Tcl_SetUnicodeObj( TclInvalidateStringRep(objPtr); stringPtr->allocated = numChars; } -#endif static int UTF16Length( @@ -1497,6 +1500,7 @@ UTF16Length( stringCheckLimits(numChars); return numChars; } +#endif static int UnicodeLength( diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c index eae72ba..2b7952d 100644 --- a/generic/tclStubInit.c +++ b/generic/tclStubInit.c @@ -96,6 +96,7 @@ static void uniCodePanic(void) { } # define Tcl_GetUnicode (unsigned short *(*)(Tcl_Obj *))(void *)uniCodePanic # define Tcl_GetUnicodeFromObj (unsigned short *(*)(Tcl_Obj *, int *))(void *)uniCodePanic +# define TclGetUnicodeFromObj (unsigned short *(*)(Tcl_Obj *, size_t *))(void *)uniCodePanic # define Tcl_NewUnicodeObj (Tcl_Obj *(*)(const unsigned short *, int))(void *)uniCodePanic # define Tcl_SetUnicodeObj (void(*)(Tcl_Obj *, const unsigned short *, int))(void *)uniCodePanic # define Tcl_AppendUnicodeToObj (void(*)(Tcl_Obj *, const unsigned short *, int))(void *)uniCodePanic diff --git a/generic/tclTest.c b/generic/tclTest.c index bf5741c..e3c6663 100644 --- a/generic/tclTest.c +++ b/generic/tclTest.c @@ -5195,14 +5195,12 @@ TestbytestringObjCmd( static int Testutf16stringObjCmd( - ClientData dummy, /* Not used. */ + TCL_UNUSED(void *), Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* The argument objects. */ { - int n = 0; - const Tcl_UniChar *p; - (void)dummy; + const unsigned short *p; if (objc != 2) { Tcl_WrongNumArgs(interp, 1, objv, "string"); diff --git a/tests/string.test b/tests/string.test index d128a0b..ba5be14 100644 --- a/tests/string.test +++ b/tests/string.test @@ -2638,7 +2638,7 @@ test string-32.17.$noComp {string is dict, valid dict packed in invalid dict} { }; # foreach noComp {0 1} test string-bug-b79df322a9 {Tcl_GetUnicode/Tcl_NewUnicodeObj api} -constraints { - testutf16string + testutf16string deprecated } -body { # This simple test suffices because the bug has nothing to do with # the actual encoding conversion. The test was added because these -- cgit v0.12 From 037f0d4f7e7b70aaa44f11a934ed52c0fabca0b3 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 13 Jul 2022 12:37:35 +0000 Subject: Make List->elements a TCLFLEXARRAY. Improve documentation (backported from 9.0) --- generic/tclCmdIL.c | 6 +- generic/tclInt.h | 8 +- generic/tclInterp.c | 2 +- generic/tclListObj.c | 647 +++++++++++++++++++++++++-------------------------- 4 files changed, 327 insertions(+), 336 deletions(-) diff --git a/generic/tclCmdIL.c b/generic/tclCmdIL.c index f32fd98..1197b92 100644 --- a/generic/tclCmdIL.c +++ b/generic/tclCmdIL.c @@ -2901,7 +2901,7 @@ Tcl_LrepeatObjCmd( List *listRepPtr = ListRepPtr(listPtr); listRepPtr->elemCount = elementCount*objc; - dataArray = &listRepPtr->elements; + dataArray = listRepPtr->elements; } /* @@ -3088,7 +3088,7 @@ Tcl_LreverseObjCmd( resultObj = Tcl_NewListObj(elemc, NULL); listRepPtr = ListRepPtr(resultObj); listRepPtr->elemCount = elemc; - dataArray = &listRepPtr->elements; + dataArray = listRepPtr->elements; for (i=0,j=elemc-1 ; ielements; + newArray = listRepPtr->elements; if (group) { for (i=0; elementPtr!=NULL ; elementPtr=elementPtr->nextPtr) { idx = elementPtr->payload.index; diff --git a/generic/tclInt.h b/generic/tclInt.h index 20c4c45..ac6fb54 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -2440,14 +2440,14 @@ typedef struct List { * derived from the list representation. May * be ignored if there is no string rep at * all.*/ - Tcl_Obj *elements; /* First list element; the struct is grown to + Tcl_Obj *elements[TCLFLEXARRAY]; /* First list element; the struct is grown to * accommodate all elements. */ } List; #define LIST_MAX \ - (1 + (int)(((size_t)UINT_MAX - sizeof(List))/sizeof(Tcl_Obj *))) + ((int)(((size_t)UINT_MAX - offsetof(List, elements))/sizeof(Tcl_Obj *))) #define LIST_SIZE(numElems) \ - (unsigned)(sizeof(List) + (((numElems) - 1) * sizeof(Tcl_Obj *))) + (TCL_HASH_TYPE)(offsetof(List, elements) + ((numElems) * sizeof(Tcl_Obj *))) /* * Macro used to get the elements of a list object. @@ -2457,7 +2457,7 @@ typedef struct List { ((List *) (listPtr)->internalRep.twoPtrValue.ptr1) #define ListObjGetElements(listPtr, objc, objv) \ - ((objv) = &(ListRepPtr(listPtr)->elements), \ + ((objv) = ListRepPtr(listPtr)->elements, \ (objc) = ListRepPtr(listPtr)->elemCount) #define ListObjLength(listPtr, len) \ diff --git a/generic/tclInterp.c b/generic/tclInterp.c index b87bf7c..4ce2f31 100644 --- a/generic/tclInterp.c +++ b/generic/tclInterp.c @@ -1837,7 +1837,7 @@ AliasNRCmd( listPtr = Tcl_NewListObj(cmdc, NULL); listRep = ListRepPtr(listPtr); listRep->elemCount = cmdc; - cmdv = &listRep->elements; + cmdv = listRep->elements; prefv = &aliasPtr->objPtr; memcpy(cmdv, prefv, prefc * sizeof(Tcl_Obj *)); diff --git a/generic/tclListObj.c b/generic/tclListObj.c index a7f723d..c24809e 100644 --- a/generic/tclListObj.c +++ b/generic/tclListObj.c @@ -77,20 +77,22 @@ const Tcl_ObjType tclListType = { * * NewListInternalRep -- * - * Creates a list internal rep with space for objc elements. objc - * must be > 0. If objv!=NULL, initializes with the first objc values - * in that array. If objv==NULL, initalize list internal rep to have - * 0 elements, with space to add objc more. Flag value "p" indicates + * Creates a 'List' structure with space for 'objc' elements. 'objc' must + * be > 0. If 'objv' is not NULL, The list is initialized with first + * 'objc' values in that array. Otherwise the list is initialized to have + * 0 elements, with space to add 'objc' more. Flag value 'p' indicates * how to behave on failure. * - * Results: - * A new List struct with refCount 0 is returned. If some failure - * prevents this then if p=0, NULL is returned and otherwise the - * routine panics. + * Value * - * Side effects: - * The ref counts of the elements in objv are incremented since the - * resulting list now refers to them. + * A new 'List' structure with refCount 0. If some failure + * prevents this NULL is returned if 'p' is 0 , and 'Tcl_Panic' + * is called if it is not. + * + * Effect + * + * The refCount of each value in 'objv' is incremented as it is added + * to the list. * *---------------------------------------------------------------------- */ @@ -140,7 +142,7 @@ NewListInternalRep( int i; listRepPtr->elemCount = objc; - elemPtrs = &listRepPtr->elements; + elemPtrs = listRepPtr->elements; for (i = 0; i < objc; i++) { elemPtrs[i] = objv[i]; Tcl_IncrRefCount(elemPtrs[i]); @@ -154,21 +156,9 @@ NewListInternalRep( /* *---------------------------------------------------------------------- * - * AttemptNewList -- + * AttemptNewList -- * - * Creates a list internal rep with space for objc elements. objc - * must be > 0. If objv!=NULL, initializes with the first objc values - * in that array. If objv==NULL, initalize list internal rep to have - * 0 elements, with space to add objc more. - * - * Results: - * A new List struct with refCount 0 is returned. If some failure - * prevents this then NULL is returned, and an error message is left - * in the interp result, unless interp is NULL. - * - * Side effects: - * The ref counts of the elements in objv are incremented since the - * resulting list now refers to them. + * Like NewListInternalRep, but additionally sets an error message on failure. * *---------------------------------------------------------------------- */ @@ -201,23 +191,20 @@ AttemptNewList( * * Tcl_NewListObj -- * - * This function is normally called when not debugging: i.e., when - * TCL_MEM_DEBUG is not defined. It creates a new list object from an - * (objc,objv) array: that is, each of the objc elements of the array - * referenced by objv is inserted as an element into a new Tcl object. + * Creates a new list object and adds values to it. When TCL_MEM_DEBUG is + * defined, 'Tcl_DbNewListObj' is called instead. * - * When TCL_MEM_DEBUG is defined, this function just returns the result - * of calling the debugging version Tcl_DbNewListObj. + * Value * - * Results: - * A new list object is returned that is initialized from the object - * pointers in objv. If objc is less than or equal to zero, an empty - * object is returned. The new object's string representation is left - * NULL. The resulting new list object has ref count 0. + * A new list 'Tcl_Obj' to which is appended values from 'objv', or if + * 'objc' is less than or equal to zero, a list 'Tcl_Obj' having no + * elements. The string representation of the new 'Tcl_Obj' is set to + * NULL. The refCount of the list is 0. * - * Side effects: - * The ref counts of the elements in objv are incremented since the - * resulting list now refers to them. + * Effect + * + * The refCount of each elements in 'objv' is incremented as it is added + * to the list. * *---------------------------------------------------------------------- */ @@ -268,28 +255,14 @@ Tcl_NewListObj( /* *---------------------------------------------------------------------- * - * Tcl_DbNewListObj -- - * - * This function is normally called when debugging: i.e., when - * TCL_MEM_DEBUG is defined. It creates new list objects. It is the same - * as the Tcl_NewListObj function above except that it calls - * Tcl_DbCkalloc directly with the file name and line number from its - * caller. This simplifies debugging since then the [memory active] - * command will report the correct file name and line number when - * reporting objects that haven't been freed. + * Tcl_DbNewListObj -- * - * When TCL_MEM_DEBUG is not defined, this function just returns the - * result of calling Tcl_NewListObj. + * Like 'Tcl_NewListObj', but it calls Tcl_DbCkalloc directly with the + * file name and line number from its caller. This simplifies debugging + * since the [memory active] command will report the correct file + * name and line number when reporting objects that haven't been freed. * - * Results: - * A new list object is returned that is initialized from the object - * pointers in objv. If objc is less than or equal to zero, an empty - * object is returned. The new object's string representation is left - * NULL. The new list object has ref count 0. - * - * Side effects: - * The ref counts of the elements in objv are incremented since the - * resulting list now refers to them. + * When TCL_MEM_DEBUG is not defined, 'Tcl_NewListObj' is called instead. * *---------------------------------------------------------------------- */ @@ -348,19 +321,8 @@ Tcl_DbNewListObj( * * Tcl_SetListObj -- * - * Modify an object to be a list containing each of the objc elements of - * the object array referenced by objv. - * - * Results: - * None. - * - * Side effects: - * The object is made a list object and is initialized from the object - * pointers in objv. If objc is less than or equal to zero, an empty - * object is returned. The new object's string representation is left - * NULL. The ref counts of the elements in objv are incremented since the - * list now refers to them. The object's old string and internal - * representations are freed and its type is set NULL. + * Like 'Tcl_NewListObj', but operates on an existing 'Tcl_Obj'instead of + * creating a new one. * *---------------------------------------------------------------------- */ @@ -403,18 +365,20 @@ Tcl_SetListObj( * * TclListObjCopy -- * - * Makes a "pure list" copy of a list value. This provides for the C - * level a counterpart of the [lrange $list 0 end] command, while using - * internals details to be as efficient as possible. + * Creates a new 'Tcl_Obj' which is a pure copy of a list value. This + * provides for the C level a counterpart of the [lrange $list 0 end] + * command, while using internals details to be as efficient as possible. * - * Results: - * Normally returns a pointer to a new Tcl_Obj, that contains the same - * list value as *listPtr does. The returned Tcl_Obj has a refCount of - * zero. If *listPtr does not hold a list, NULL is returned, and if - * interp is non-NULL, an error message is recorded there. + * Value * - * Side effects: - * None. + * The address of the new 'Tcl_Obj' which shares its internal + * representation with 'listPtr', and whose refCount is 0. If 'listPtr' + * is not actually a list, the value is NULL, and an error message is left + * in 'interp' if it is not NULL. + * + * Effect + * + * 'listPtr' is converted to a list if it isn't one already. * *---------------------------------------------------------------------- */ @@ -529,27 +493,30 @@ TclListObjRange( * * Tcl_ListObjGetElements -- * - * This function returns an (objc,objv) array of the elements in a list - * object. + * Retreive the elements in a list 'Tcl_Obj'. * - * Results: - * The return value is normally TCL_OK; in this case *objcPtr is set to - * the count of list elements and *objvPtr is set to a pointer to an - * array of (*objcPtr) pointers to each list element. If listPtr does not - * refer to a list object and the object can not be converted to one, - * TCL_ERROR is returned and an error message will be left in the - * interpreter's result if interp is not NULL. - * - * The objects referenced by the returned array should be treated as - * readonly and their ref counts are _not_ incremented; the caller must - * do that if it holds on to a reference. Furthermore, the pointer and - * length returned by this function may change as soon as any function is - * called on the list object; be careful about retaining the pointer in a - * local data structure. + * Value * - * Side effects: - * The possible conversion of the object referenced by listPtr - * to a list object. + * TCL_OK + * + * A count of list elements is stored, 'objcPtr', And a pointer to the + * array of elements in the list is stored in 'objvPtr'. + * + * The elements accessible via 'objvPtr' should be treated as readonly + * and the refCount for each object is _not_ incremented; the caller + * must do that if it holds on to a reference. Furthermore, the + * pointer and length returned by this function may change as soon as + * any function is called on the list object. Be careful about + * retaining the pointer in a local data structure. + * + * TCL_ERROR + * + * 'listPtr' is not a valid list. An error message is left in the + * interpreter's result if 'interp' is not NULL. + * + * Effect + * + * 'listPtr' is converted to a list object if it isn't one already. * *---------------------------------------------------------------------- */ @@ -570,7 +537,8 @@ Tcl_ListObjGetElements( ListGetInternalRep(listPtr, listRepPtr); if (listRepPtr == NULL) { - int result, length; + int result; + int length; (void) Tcl_GetStringFromObj(listPtr, &length); if (length == 0) { @@ -585,7 +553,7 @@ Tcl_ListObjGetElements( ListGetInternalRep(listPtr, listRepPtr); } *objcPtr = listRepPtr->elemCount; - *objvPtr = &listRepPtr->elements; + *objvPtr = listRepPtr->elements; return TCL_OK; } @@ -594,20 +562,27 @@ Tcl_ListObjGetElements( * * Tcl_ListObjAppendList -- * - * This function appends the elements in the list value referenced by - * elemListPtr to the list value referenced by listPtr. + * Appends the elements of elemListPtr to those of listPtr. * - * Results: - * The return value is normally TCL_OK. If listPtr or elemListPtr do not - * refer to list values, TCL_ERROR is returned and an error message is - * left in the interpreter's result if interp is not NULL. + * Value * - * Side effects: - * The reference counts of the elements in elemListPtr are incremented - * since the list now refers to them. listPtr and elemListPtr are - * converted, if necessary, to list objects. Also, appending the new - * elements may cause listObj's array of element pointers to grow. - * listPtr's old string representation, if any, is invalidated. + * TCL_OK + * + * Success. + * + * TCL_ERROR + * + * 'listPtr' or 'elemListPtr' are not valid lists. An error + * message is left in the interpreter's result if 'interp' is not NULL. + * + * Effect + * + * The reference count of each element of 'elemListPtr' as it is added to + * 'listPtr'. 'listPtr' and 'elemListPtr' are converted to 'tclListType' + * if they are not already. Appending the new elements may cause the + * array of element pointers in 'listObj' to grow. If any objects are + * appended to 'listPtr'. Any preexisting string representation of + * 'listPtr' is invalidated. * *---------------------------------------------------------------------- */ @@ -646,24 +621,27 @@ Tcl_ListObjAppendList( * * Tcl_ListObjAppendElement -- * - * This function is a special purpose version of Tcl_ListObjAppendList: - * it appends a single object referenced by objPtr to the list object - * referenced by listPtr. If listPtr is not already a list object, an - * attempt will be made to convert it to one. + * Like 'Tcl_ListObjAppendList', but Appends a single value to a list. * - * Results: - * The return value is normally TCL_OK; in this case objPtr is added to - * the end of listPtr's list. If listPtr does not refer to a list object - * and the object can not be converted to one, TCL_ERROR is returned and - * an error message will be left in the interpreter's result if interp is - * not NULL. + * Value * - * Side effects: - * The ref count of objPtr is incremented since the list now refers to - * it. listPtr will be converted, if necessary, to a list object. Also, - * appending the new element may cause listObj's array of element - * pointers to grow. listPtr's old string representation, if any, is - * invalidated. + * TCL_OK + * + * 'objPtr' is appended to the elements of 'listPtr'. + * + * TCL_ERROR + * + * listPtr does not refer to a list object and the object can not be + * converted to one. An error message will be left in the + * interpreter's result if interp is not NULL. + * + * Effect + * + * If 'listPtr' is not already of type 'tclListType', it is converted. + * The 'refCount' of 'objPtr' is incremented as it is added to 'listPtr'. + * Appending the new element may cause the the array of element pointers + * in 'listObj' to grow. Any preexisting string representation of + * 'listPtr' is invalidated. * *---------------------------------------------------------------------- */ @@ -675,7 +653,8 @@ Tcl_ListObjAppendElement( Tcl_Obj *objPtr) /* Object to append to listPtr's list. */ { List *listRepPtr, *newPtr = NULL; - int numElems, numRequired, needGrow, isShared, attempt; + int numElems, numRequired; + int needGrow, isShared, attempt; if (Tcl_IsShared(listPtr)) { Tcl_Panic("%s called with shared object", "Tcl_ListObjAppendElement"); @@ -683,7 +662,8 @@ Tcl_ListObjAppendElement( ListGetInternalRep(listPtr, listRepPtr); if (listRepPtr == NULL) { - int result, length; + int result; + int length; (void) Tcl_GetStringFromObj(listPtr, &length); if (length == 0) { @@ -739,7 +719,7 @@ Tcl_ListObjAppendElement( } } if (isShared || needGrow) { - Tcl_Obj **dst, **src = &listRepPtr->elements; + Tcl_Obj **dst, **src = listRepPtr->elements; /* * Either we have a shared internalrep and we must copy to write, or we @@ -767,7 +747,7 @@ Tcl_ListObjAppendElement( return TCL_ERROR; } - dst = &newPtr->elements; + dst = newPtr->elements; newPtr->refCount++; newPtr->canonicalFlag = listRepPtr->canonicalFlag; newPtr->elemCount = listRepPtr->elemCount; @@ -803,7 +783,7 @@ Tcl_ListObjAppendElement( * the ref count for the (now shared) objPtr. */ - *(&listRepPtr->elements + listRepPtr->elemCount) = objPtr; + listRepPtr->elements[listRepPtr->elemCount] = objPtr; Tcl_IncrRefCount(objPtr); listRepPtr->elemCount++; @@ -821,23 +801,27 @@ Tcl_ListObjAppendElement( * * Tcl_ListObjIndex -- * - * This function returns a pointer to the index'th object from the list - * referenced by listPtr. The first element has index 0. If index is - * negative or greater than or equal to the number of elements in the - * list, a NULL is returned. If listPtr is not a list object, an attempt - * will be made to convert it to a list. + * Retrieve a pointer to the element of 'listPtr' at 'index'. The index + * of the first element is 0. * - * Results: - * The return value is normally TCL_OK; in this case objPtrPtr is set to - * the Tcl_Obj pointer for the index'th list element or NULL if index is - * out of range. This object should be treated as readonly and its ref - * count is _not_ incremented; the caller must do that if it holds on to - * the reference. If listPtr does not refer to a list and can't be - * converted to one, TCL_ERROR is returned and an error message is left - * in the interpreter's result if interp is not NULL. + * Value * - * Side effects: - * listPtr will be converted, if necessary, to a list object. + * TCL_OK + * + * A pointer to the element at 'index' is stored in 'objPtrPtr'. If + * 'index' is out of range, NULL is stored in 'objPtrPtr'. This + * object should be treated as readonly and its 'refCount' is _not_ + * incremented. The caller must do that if it holds on to the + * reference. + * + * TCL_ERROR + * + * 'listPtr' is not a valid list. An an error message is left in the + * interpreter's result if 'interp' is not NULL. + * + * Effect + * + * If 'listPtr' is not already of type 'tclListType', it is converted. * *---------------------------------------------------------------------- */ @@ -853,7 +837,8 @@ Tcl_ListObjIndex( ListGetInternalRep(listPtr, listRepPtr); if (listRepPtr == NULL) { - int result, length; + int result; + int length; (void) Tcl_GetStringFromObj(listPtr, &length); if (length == 0) { @@ -870,7 +855,7 @@ Tcl_ListObjIndex( if ((index < 0) || (index >= listRepPtr->elemCount)) { *objPtrPtr = NULL; } else { - *objPtrPtr = (&listRepPtr->elements)[index]; + *objPtrPtr = listRepPtr->elements[index]; } return TCL_OK; @@ -881,19 +866,20 @@ Tcl_ListObjIndex( * * Tcl_ListObjLength -- * - * This function returns the number of elements in a list object. If the - * object is not already a list object, an attempt will be made to - * convert it to one. + * Retrieve the number of elements in a list. * - * Results: - * The return value is normally TCL_OK; in this case *intPtr will be set - * to the integer count of list elements. If listPtr does not refer to a - * list object and the object can not be converted to one, TCL_ERROR is - * returned and an error message will be left in the interpreter's result - * if interp is not NULL. + * Value * - * Side effects: - * The possible conversion of the argument object to a list object. + * TCL_OK + * + * A count of list elements is stored at the address provided by + * 'intPtr'. If 'listPtr' is not already of type 'tclListPtr', it is + * converted. + * + * TCL_ERROR + * + * 'listPtr' is not a valid list. An error message will be left in + * the interpreter's result if 'interp' is not NULL. * *---------------------------------------------------------------------- */ @@ -903,13 +889,14 @@ 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. */ + int *intPtr) /* The resulting length is stored here. */ { List *listRepPtr; ListGetInternalRep(listPtr, listRepPtr); if (listRepPtr == NULL) { - int result, length; + int result; + int length; (void) Tcl_GetStringFromObj(listPtr, &length); if (length == 0) { @@ -932,35 +919,36 @@ Tcl_ListObjLength( * * Tcl_ListObjReplace -- * - * This function replaces zero or more elements of the list referenced by - * listPtr with the objects from an (objc,objv) array. The objc elements - * of the array referenced by objv replace the count elements in listPtr - * starting at first. + * Replace values in a list. * - * If the argument first is zero or negative, it refers to the first - * element. If first is greater than or equal to the number of elements - * in the list, then no elements are deleted; the new elements are - * appended to the list. Count gives the number of elements to replace. - * If count is zero or negative then no elements are deleted; the new - * elements are simply inserted before first. + * If 'first' is zero or TCL_INDEX_NONE, it refers to the first element. If + * 'first' outside the range of elements in the list, no elements are + * deleted. * - * The argument objv refers to an array of objc pointers to the new - * elements to be added to listPtr in place of those that were deleted. - * If objv is NULL, no new elements are added. If listPtr is not a list - * object, an attempt will be made to convert it to one. + * If 'count' is zero or TCL_INDEX_NONE no elements are deleted, and any new + * elements are inserted at the beginning of the list. * - * Results: - * The return value is normally TCL_OK. If listPtr does not refer to a - * list object and can not be converted to one, TCL_ERROR is returned and - * an error message will be left in the interpreter's result if interp is - * not NULL. + * Value * - * Side effects: - * The ref counts of the objc elements in objv are incremented since the - * resulting list now refers to them. Similarly, the ref counts for - * replaced objects are decremented. listPtr is converted, if necessary, - * to a list object. listPtr's old string representation, if any, is - * freed. + * TCL_OK + * + * The first 'objc' values of 'objv' replaced 'count' elements in 'listPtr' + * starting at 'first'. If 'objc' 0, no new elements are added. + * + * TCL_ERROR + * + * 'listPtr' is not a valid list. An error message is left in the + * interpreter's result if 'interp' is not NULL. + * + * Effect + * + * If 'listPtr' is not of type 'tclListType', it is converted if possible. + * + * The 'refCount' of each element appended to the list is incremented. + * Similarly, the 'refCount' for each replaced element is decremented. + * + * If 'listPtr' is modified, any previous string representation is + * invalidated. * *---------------------------------------------------------------------- */ @@ -977,7 +965,8 @@ Tcl_ListObjReplace( { List *listRepPtr; Tcl_Obj **elemPtrs; - int needGrow, numElems, numRequired, numAfterLast, start, i, j, isShared; + int numElems, numRequired, numAfterLast, start, i, j; + int needGrow, isShared; if (Tcl_IsShared(listPtr)) { Tcl_Panic("%s called with shared object", "Tcl_ListObjReplace"); @@ -1011,7 +1000,7 @@ Tcl_ListObjReplace( * Resist any temptation to optimize this case. */ - elemPtrs = &listRepPtr->elements; + elemPtrs = listRepPtr->elements; numElems = listRepPtr->elemCount; if (first < 0) { @@ -1065,7 +1054,7 @@ Tcl_ListObjReplace( if (newPtr) { listRepPtr = newPtr; ListResetInternalRep(listPtr, listRepPtr); - elemPtrs = &listRepPtr->elements; + elemPtrs = listRepPtr->elements; listRepPtr->maxElemCount = attempt; needGrow = numRequired > listRepPtr->maxElemCount; } @@ -1140,7 +1129,7 @@ Tcl_ListObjReplace( ListResetInternalRep(listPtr, listRepPtr); listRepPtr->refCount++; - elemPtrs = &listRepPtr->elements; + elemPtrs = listRepPtr->elements; if (isShared) { /* @@ -1228,22 +1217,19 @@ Tcl_ListObjReplace( * * TclLindexList -- * - * This procedure handles the 'lindex' command when objc==3. + * Implements the 'lindex' command when objc==3. * - * Results: - * Returns a pointer to the object extracted, or NULL if an error - * occurred. The returned object already includes one reference count for - * the pointer returned. + * Implemented entirely as a wrapper around 'TclLindexFlat'. Reconfigures + * the argument format into required form while taking care to manage + * shimmering so as to tend to keep the most useful internalreps + * and/or avoid the most expensive conversions. * - * Side effects: - * None. + * Value * - * Notes: - * This procedure is implemented entirely as a wrapper around - * TclLindexFlat. All it does is reconfigure the argument format into the - * form required by TclLindexFlat, while taking care to manage shimmering - * in such a way that we tend to keep the most useful internalreps and/or - * avoid the most expensive conversions. + * A pointer to the specified element, with its 'refCount' incremented, or + * NULL if an error occurred. + * + * Notes * *---------------------------------------------------------------------- */ @@ -1302,7 +1288,7 @@ TclLindexList( assert(listRepPtr != NULL); listPtr = TclLindexFlat(interp, listPtr, listRepPtr->elemCount, - &listRepPtr->elements); + listRepPtr->elements); Tcl_DecrRefCount(indexListCopy); return listPtr; } @@ -1310,25 +1296,20 @@ TclLindexList( /* *---------------------------------------------------------------------- * - * TclLindexFlat -- + * TclLindexFlat -- * - * This procedure is the core of the 'lindex' command, with all index - * arguments presented as a flat list. + * The core of the 'lindex' command, with all index + * arguments presented as a flat list. * - * Results: - * Returns a pointer to the object extracted, or NULL if an error - * occurred. The returned object already includes one reference count for - * the pointer returned. + * Value * - * Side effects: - * None. + * A pointer to the object extracted, with its 'refCount' incremented, or + * NULL if an error occurred. Thus, the calling code will usually do + * something like: + * + * Tcl_SetObjResult(interp, result); + * Tcl_DecrRefCount(result); * - * Notes: - * The reference count of the returned object includes one reference - * corresponding to the pointer returned. Thus, the calling code will - * usually do something like: - * Tcl_SetObjResult(interp, result); - * Tcl_DecrRefCount(result); * *---------------------------------------------------------------------- */ @@ -1404,24 +1385,17 @@ TclLindexFlat( * * TclLsetList -- * - * Core of the 'lset' command when objc == 4. Objv[2] may be either a + * The core of [lset] when objc == 4. Objv[2] may be either a * scalar index or a list of indices. * It also handles 'lpop' when given a NULL value. * - * Results: - * Returns the new value of the list variable, or NULL if there was an - * error. The returned object includes one reference count for the - * pointer returned. + * Implemented entirely as a wrapper around 'TclLindexFlat', as described + * for 'TclLindexList'. * - * Side effects: - * None. + * Value * - * Notes: - * This procedure is implemented entirely as a wrapper around - * TclLsetFlat. All it does is reconfigure the argument format into the - * form required by TclLsetFlat, while taking care to manage shimmering - * in such a way that we tend to keep the most useful internalreps and/or - * avoid the most expensive conversions. + * The new list, with the 'refCount' of 'valuPtr' incremented, or NULL if + * there was an error. * *---------------------------------------------------------------------- */ @@ -1486,36 +1460,39 @@ TclLsetList( * Core engine of the 'lset' command. * It also handles 'lpop' when given a NULL value. * - * Results: - * Returns the new value of the list variable, or NULL if an error - * occurred. The returned object includes one reference count for the - * pointer returned. + * Value * - * Side effects: - * On entry, the reference count of the variable value does not reflect - * any references held on the stack. The first action of this function is - * to determine whether the object is shared, and to duplicate it if it - * is. The reference count of the duplicate is incremented. At this - * point, the reference count will be 1 for either case, so that the - * object will appear to be unshared. - * - * If an error occurs, and the object has been duplicated, the reference - * count on the duplicate is decremented so that it is now 0: this - * dismisses any memory that was allocated by this function. - * - * If no error occurs, the reference count of the original object is - * incremented if the object has not been duplicated, and nothing is done - * to a reference count of the duplicate. Now the reference count of an - * unduplicated object is 2 (the returned pointer, plus the one stored in - * the variable). The reference count of a duplicate object is 1, - * reflecting that the returned pointer is the only active reference. The - * caller is expected to store the returned value back in the variable - * and decrement its reference count. (INST_STORE_* does exactly this.) - * - * Surgery is performed on the unshared list value to produce the result. - * TclLsetFlat maintains a linked list of Tcl_Obj's whose string + * The resulting list + * + * The 'refCount' of 'valuePtr' is incremented. If 'listPtr' was not + * duplicated, its 'refCount' is incremented. The reference count of + * an unduplicated object is therefore 2 (one for the returned pointer + * and one for the variable that holds it). The reference count of a + * duplicate object is 1, reflecting that result is the only active + * reference. The caller is expected to store the result in the + * variable and decrement its reference count. (INST_STORE_* does + * exactly this.) + * + * NULL + * + * An error occurred. If 'listPtr' was duplicated, the reference + * count on the duplicate is decremented so that it is 0, causing any + * memory allocated by this function to be freed. + * + * + * Effect + * + * On entry, the reference count of 'listPtr' does not reflect any + * references held on the stack. The first action of this function is to + * determine whether 'listPtr' is shared and to create a duplicate + * unshared copy if it is. The reference count of the duplicate is + * incremented. At this point, the reference count is 1 in either case so + * that the object is considered unshared. + * + * The unshared list is altered directly to produce the result. + * 'TclLsetFlat' maintains a linked list of 'Tcl_Obj' values whose string * representations must be spoilt by threading via 'ptr2' of the - * two-pointer internal representation. On entry to TclLsetFlat, the + * two-pointer internal representation. On entry to 'TclLsetFlat', the * values of 'ptr2' are immaterial; on exit, the 'ptr2' field of any * Tcl_Obj that has been modified is set to NULL. * @@ -1531,7 +1508,8 @@ TclLsetFlat( /* Index args. */ Tcl_Obj *valuePtr) /* Value arg to 'lset' or NULL to 'lpop'. */ { - int index, result, len; + int index, len; + int result; Tcl_Obj *subListPtr, *retValuePtr, *chainPtr; Tcl_ObjInternalRep *irPtr; @@ -1724,12 +1702,12 @@ TclLsetFlat( } /* - * Store valuePtr in proper sublist and return. The -1 is to avoid a - * compiler warning (not a problem because we checked that we have a - * proper list - or something convertible to one - above). + * Store valuePtr in proper sublist and return. The TCL_INDEX_NONE is + * to avoid a compiler warning (not a problem because we checked that + * we have a proper list - or something convertible to one - above). */ - len = -1; + len = TCL_INDEX_NONE; TclListObjLengthM(NULL, subListPtr, &len); if (valuePtr == NULL) { Tcl_ListObjReplace(NULL, subListPtr, index, 1, 0, NULL); @@ -1748,26 +1726,38 @@ TclLsetFlat( * * TclListObjSetElement -- * - * Set a single element of a list to a specified value + * Set a single element of a list to a specified value. * - * Results: - * The return value is normally TCL_OK. If listPtr does not refer to a - * list object and cannot be converted to one, TCL_ERROR is returned and - * an error message will be left in the interpreter result if interp is - * not NULL. Similarly, if index designates an element outside the range - * [0..listLength-1], where listLength is the count of elements in the - * list object designated by listPtr, TCL_ERROR is returned and an error - * message is left in the interpreter result. + * It is the caller's responsibility to invalidate the string + * representation of the 'listPtr'. * - * Side effects: - * Tcl_Panic if listPtr designates a shared object. Otherwise, attempts - * to convert it to a list with a non-shared internal rep. Decrements the - * ref count of the object at the specified index within the list, - * replaces with the object designated by valuePtr, and increments the - * ref count of the replacement object. + * Value + * + * TCL_OK + * + * Success. + * + * TCL_ERROR + * + * 'listPtr' does not refer to a list object and cannot be converted + * to one. An error message will be left in the interpreter result if + * interp is not NULL. + * + * TCL_ERROR + * + * An index designates an element outside the range [0..listLength-1], + * where 'listLength' is the count of elements in the list object + * designated by 'listPtr'. An error message is left in the + * interpreter result. + * + * Effect + * + * If 'listPtr' designates a shared object, 'Tcl_Panic' is called. If + * 'listPtr' is not already of type 'tclListType', it is converted and the + * internal representation is unshared. The 'refCount' of the element at + * 'index' is decremented and replaced in the list with the 'valuePtr', + * whose 'refCount' in turn is incremented. * - * It is the caller's responsibility to invalidate the string - * representation of the object. * *---------------------------------------------------------------------- */ @@ -1797,7 +1787,8 @@ TclListObjSetElement( ListGetInternalRep(listPtr, listRepPtr); if (listRepPtr == NULL) { - int result, length; + int result; + int length; (void) Tcl_GetStringFromObj(listPtr, &length); if (length == 0) { @@ -1837,7 +1828,7 @@ TclListObjSetElement( */ if (listRepPtr->refCount > 1) { - Tcl_Obj **dst, **src = &listRepPtr->elements; + Tcl_Obj **dst, **src = listRepPtr->elements; List *newPtr = AttemptNewList(NULL, listRepPtr->maxElemCount, NULL); if (newPtr == NULL) { @@ -1850,7 +1841,7 @@ TclListObjSetElement( newPtr->elemCount = elemCount; newPtr->canonicalFlag = listRepPtr->canonicalFlag; - dst = &newPtr->elements; + dst = newPtr->elements; while (elemCount--) { *dst = *src++; Tcl_IncrRefCount(*dst++); @@ -1861,7 +1852,7 @@ TclListObjSetElement( listRepPtr = newPtr; ListResetInternalRep(listPtr, listRepPtr); } - elemPtrs = &listRepPtr->elements; + elemPtrs = listRepPtr->elements; /* * Add a reference to the new list element. @@ -1901,13 +1892,11 @@ TclListObjSetElement( * * FreeListInternalRep -- * - * Deallocate the storage associated with a list object's internal - * representation. + * Deallocate the storage associated with the internal representation of a + * a list object. * - * Results: - * None. + * Effect * - * Side effects: * Frees listPtr's List* internal representation, if no longer shared. * May decrement the ref counts of element objects, which may free them. * @@ -1924,7 +1913,7 @@ FreeListInternalRep( assert(listRepPtr != NULL); if (listRepPtr->refCount-- <= 1) { - Tcl_Obj **elemPtrs = &listRepPtr->elements; + Tcl_Obj **elemPtrs = listRepPtr->elements; int i, numElems = listRepPtr->elemCount; for (i = 0; i < numElems; i++) { @@ -1939,14 +1928,12 @@ FreeListInternalRep( * * DupListInternalRep -- * - * Initialize the internal representation of a list Tcl_Obj to share the + * Initialize the internal representation of a list 'Tcl_Obj' to share the * internal representation of an existing list object. * - * Results: - * None. + * Effect * - * Side effects: - * The reference count of the List internal rep is incremented. + * The 'refCount' of the List internal rep is incremented. * *---------------------------------------------------------------------- */ @@ -1968,16 +1955,20 @@ DupListInternalRep( * * SetListFromAny -- * - * Attempt to generate a list internal form for the Tcl object "objPtr". + * Convert any object to a list. * - * Results: - * The return value is TCL_OK or TCL_ERROR. If an error occurs during - * conversion, an error message is left in the interpreter's result - * unless "interp" is NULL. + * Value + * + * TCL_OK + * + * Success. The internal representation of 'objPtr' is set, and the type + * of 'objPtr' is 'tclListType'. + * + * TCL_ERROR + * + * An error occured during conversion. An error message is left in the + * interpreter's result if 'interp' is not NULL. * - * Side effects: - * If no error occurs, a list is stored as "objPtr"s internal - * representation. * *---------------------------------------------------------------------- */ @@ -2001,7 +1992,8 @@ SetListFromAny( if (!TclHasStringRep(objPtr) && TclHasInternalRep(objPtr, &tclDictType)) { Tcl_Obj *keyPtr, *valuePtr; Tcl_DictSearch search; - int done, size; + int done; + int size; /* * Create the new list representation. Note that we do not need to do @@ -2023,7 +2015,7 @@ SetListFromAny( * Populate the list representation. */ - elemPtrs = &listRepPtr->elements; + elemPtrs = listRepPtr->elements; Tcl_DictObjFirst(NULL, objPtr, &search, &keyPtr, &valuePtr, &done); while (!done) { *elemPtrs++ = keyPtr; @@ -2048,7 +2040,7 @@ SetListFromAny( if (listRepPtr == NULL) { return TCL_ERROR; } - elemPtrs = &listRepPtr->elements; + elemPtrs = listRepPtr->elements; /* * Each iteration, parse and store a list element. @@ -2057,12 +2049,13 @@ SetListFromAny( while (nextElem < limit) { const char *elemStart; char *check; - int elemSize, literal; + int elemSize; + int literal; if (TCL_OK != TclFindElement(interp, nextElem, limit - nextElem, &elemStart, &nextElem, &elemSize, &literal)) { fail: - while (--elemPtrs >= &listRepPtr->elements) { + while (--elemPtrs >= listRepPtr->elements) { Tcl_DecrRefCount(*elemPtrs); } ckfree(listRepPtr); @@ -2092,7 +2085,7 @@ SetListFromAny( Tcl_IncrRefCount(*elemPtrs++);/* Since list now holds ref to it. */ } - listRepPtr->elemCount = elemPtrs - &listRepPtr->elements; + listRepPtr->elemCount = elemPtrs - listRepPtr->elements; } /* @@ -2110,18 +2103,16 @@ SetListFromAny( * * UpdateStringOfList -- * - * Update the string representation for a list object. Note: This - * function does not invalidate an existing old string rep so storage - * will be lost if this has not already been done. + * Update the string representation for a list object. * - * Results: - * None. + * Any previously-exising string representation is not invalidated, so + * storage is lost if this has not been taken care of. * - * Side effects: - * The object's string is set to a valid string that results from the - * list-to-string conversion. This string will be empty if the list has - * no elements. The list internal representation should not be NULL and - * we assume it is not NULL. + * Effect + * + * The string representation of 'listPtr' is set to the resulting string. + * This string will be empty if the list has no elements. It is assumed + * that the list internal representation is not NULL. * *---------------------------------------------------------------------- */ @@ -2174,7 +2165,7 @@ UpdateStringOfList( flagPtr = (char *)ckalloc(numElems); } - elemPtrs = &listRepPtr->elements; + elemPtrs = listRepPtr->elements; for (i = 0; i < numElems; i++) { flagPtr[i] = (i ? TCL_DONT_QUOTE_HASH : 0); elem = TclGetStringFromObj(elemPtrs[i], &length); -- cgit v0.12 From 554ed37525a85518448300c6cdfd33d7d2684425 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 14 Jul 2022 10:53:55 +0000 Subject: Same bug-fix as [b79df322a9], but then for Tcl_AppendUnicodeToObj() --- generic/tclStringObj.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/generic/tclStringObj.c b/generic/tclStringObj.c index b9d603d..7ce1cdc 100644 --- a/generic/tclStringObj.c +++ b/generic/tclStringObj.c @@ -1744,7 +1744,7 @@ Tcl_AppendUnicodeToObj( return; } - SetStringFromAny(NULL, objPtr); + SetUTF16StringFromAny(NULL, objPtr); stringPtr = GET_STRING(objPtr); stringPtr = stringAttemptRealloc(stringPtr, stringPtr->numChars + length); memcpy(&stringPtr->unicode[stringPtr->numChars], unicode, length); -- cgit v0.12 From 393e14cb3ddbf32f99e5c62cf4bbfe2962d4624d Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 14 Jul 2022 10:57:27 +0000 Subject: Put '}' and 'else' at the same line everywhere (code formatting) --- generic/tclCmdIL.c | 9 ++---- generic/tclListObj.c | 84 ++++++++++++++++++++-------------------------------- generic/tclUtil.c | 1 - 3 files changed, 35 insertions(+), 59 deletions(-) diff --git a/generic/tclCmdIL.c b/generic/tclCmdIL.c index 3d6b470..cdc302c 100644 --- a/generic/tclCmdIL.c +++ b/generic/tclCmdIL.c @@ -3109,8 +3109,7 @@ Tcl_LreverseObjCmd( } Tcl_SetObjResult(interp, resultObj); - } - else { + } else { /* * Not shared, so swap "in place". This relies on Tcl_LOGE above @@ -4444,15 +4443,13 @@ Tcl_LsortObjCmd( } } } - } - else if (indices) { + } else if (indices) { for (i=0; elementPtr != NULL ; elementPtr = elementPtr->nextPtr) { TclNewIndexObj(objPtr, elementPtr->payload.index); newArray[i++] = objPtr; Tcl_IncrRefCount(objPtr); } - } - else { + } else { for (i=0; elementPtr != NULL ; elementPtr = elementPtr->nextPtr) { objPtr = elementPtr->payload.objPtr; newArray[i++] = objPtr; diff --git a/generic/tclListObj.c b/generic/tclListObj.c index d4cd4b2..03e88e5 100644 --- a/generic/tclListObj.c +++ b/generic/tclListObj.c @@ -290,8 +290,7 @@ ListSpanDecrRefs(ListSpan *spanPtr) { if (spanPtr->refCount <= 1) { ckfree(spanPtr); - } - else { + } else { spanPtr->refCount -= 1; } } @@ -590,8 +589,7 @@ ListRepUnsharedShiftDown(ListRep *repPtr, ListSizeT shiftCount) if (repPtr->spanPtr) { repPtr->spanPtr->spanStart -= shiftCount; LIST_ASSERT(repPtr->spanPtr->spanLength == storePtr->numUsed); - } - else { + } else { /* * If there was no span, firstUsed must have been 0 (Invariant) * AND shiftCount must have been 0 (<= firstUsed on call) @@ -644,8 +642,7 @@ ListRepUnsharedShiftUp(ListRep *repPtr, ListSizeT shiftCount) storePtr->firstUsed += shiftCount; if (repPtr->spanPtr) { repPtr->spanPtr->spanStart += shiftCount; - } - else { + } else { /* No span means entire original list is span */ /* Should have been zero before shift - Invariant TBD */ LIST_ASSERT(storePtr->firstUsed == shiftCount); @@ -763,10 +760,11 @@ ListStoreNew( return NULL; } - if (flags & LISTREP_SPACE_FLAGS) + if (flags & LISTREP_SPACE_FLAGS) { capacity = ListStoreUpSize(objc); - else + } else { capacity = objc; + } storePtr = (ListStore *)attemptckalloc(LIST_SIZE(capacity)); if (storePtr == NULL && capacity != objc) { @@ -786,23 +784,19 @@ ListStoreNew( storePtr->numAllocated = capacity; if (capacity == objc) { storePtr->firstUsed = 0; - } - else { + } else { ListSizeT extra = capacity - objc; int spaceFlags = flags & LISTREP_SPACE_FLAGS; if (spaceFlags == LISTREP_SPACE_ONLY_BACK) { storePtr->firstUsed = 0; - } - else if (spaceFlags == LISTREP_SPACE_FAVOR_FRONT) { + } else if (spaceFlags == LISTREP_SPACE_FAVOR_FRONT) { /* Leave more space in the front */ storePtr->firstUsed = extra - (extra / 4); /* NOT same as 3*extra/4 */ - } - else if (spaceFlags == LISTREP_SPACE_FAVOR_BACK) { + } else if (spaceFlags == LISTREP_SPACE_FAVOR_BACK) { /* Leave more space in the back */ storePtr->firstUsed = extra / 4; - } - else { + } else { /* Apportion equally */ storePtr->firstUsed = extra / 2; } @@ -912,8 +906,7 @@ ListRepInit( repPtr->storePtr = storePtr; if (storePtr->firstUsed == 0) { repPtr->spanPtr = NULL; - } - else { + } else { repPtr->spanPtr = ListSpanNew(storePtr->firstUsed, storePtr->numUsed); } @@ -963,10 +956,11 @@ ListRepInitAttempt( int result = ListRepInit(objc, objv, 0, repPtr); if (result != TCL_OK && interp != NULL) { - if (objc > LIST_MAX) + if (objc > LIST_MAX) { ListLimitExceededError(interp); - else + } else { MemoryAllocationError(interp, LIST_SIZE(objc)); + } } return result; } @@ -1337,8 +1331,7 @@ Tcl_SetListObj( /* TODO - perhaps ask for extra space? */ ListRepInit(objc, objv, LISTREP_PANIC_ON_FAIL, &listRep); ListObjReplaceRepAndInvalidate(objPtr, &listRep); - } - else { + } else { TclFreeInternalRep(objPtr); TclInvalidateStringRep(objPtr); Tcl_InitStringRep(objPtr, NULL, 0); @@ -1476,8 +1469,7 @@ ListRepRange( srcRepPtr->spanPtr->spanStart = spanStart; srcRepPtr->spanPtr->spanLength = rangeLen; *rangeRepPtr = *srcRepPtr; - } - else { + } else { /* Span not present or is shared - Allocate a new span */ rangeRepPtr->storePtr = srcRepPtr->storePtr; rangeRepPtr->spanPtr = ListSpanNew(spanStart, rangeLen); @@ -1491,8 +1483,7 @@ ListRepRange( if (!preserveSrcRep) { ListRepFreeUnreferenced(rangeRepPtr); } - } - else if (preserveSrcRep || ListRepIsShared(srcRepPtr)) { + } else if (preserveSrcRep || ListRepIsShared(srcRepPtr)) { /* Option 2 - span or modification in place not allowed/desired */ ListRepElements(srcRepPtr, numSrcElems, srcElems); /* TODO - allocate extra space? */ @@ -2047,8 +2038,7 @@ Tcl_ListObjReplace( } if (numToDelete < 0) { numToDelete = 0; - } - else if (first > ListSizeT_MAX - numToDelete /* Handle integer overflow */ + } else if (first > ListSizeT_MAX - numToDelete /* Handle integer overflow */ || origListLen < first + numToDelete) { numToDelete = origListLen - first; } @@ -2089,8 +2079,7 @@ Tcl_ListObjReplace( ListRepRange(&listRep, numToDelete, origListLen-1, 0, &tailRep); ListObjReplaceRepAndInvalidate(listObj, &tailRep); return TCL_OK; - } - else if ((first+numToDelete) >= origListLen) { + } else if ((first+numToDelete) >= origListLen) { /* Delete from tail, so return head */ ListRep headRep; ListRepRange(&listRep, 0, first-1, 0, &headRep); @@ -2137,14 +2126,14 @@ Tcl_ListObjReplace( /* An unshared span record, re-use it */ listRep.spanPtr->spanStart = listRep.storePtr->firstUsed; listRep.spanPtr->spanLength = newLen; - } - else { + } else { /* Need a new span record */ - if (listRep.storePtr->firstUsed == 0) + if (listRep.storePtr->firstUsed == 0) { listRep.spanPtr = NULL; - else + } else { listRep.spanPtr = ListSpanNew(listRep.storePtr->firstUsed, newLen); + } } ListObjReplaceRepAndInvalidate(listObj, &listRep); return TCL_OK; @@ -2269,8 +2258,7 @@ Tcl_ListObjReplace( /* Exact fit */ leadShift = 0; tailShift = 0; - } - else if (lenChange < 0) { + } else if (lenChange < 0) { /* * More deletions than insertions. The gap after deletions is large * enough for insertions. Move a segment depending on size. @@ -2279,14 +2267,12 @@ Tcl_ListObjReplace( /* Tail segment smaller. Insert after lead, move tail down */ leadShift = 0; tailShift = lenChange; - } - else { + } else { /* Lead segment smaller. Insert before tail, move lead up */ leadShift = -lenChange; tailShift = 0; } - } - else { + } else { LIST_ASSERT(lenChange > 0); /* Reminder */ /* @@ -2321,8 +2307,7 @@ Tcl_ListObjReplace( } } LIST_ASSERT(leadShift >= 0 || leadSpace >= -leadShift); - } - else if (tailSpace >= lenChange) { + } else if (tailSpace >= lenChange) { /* Move only tail segment to the back to make more room. */ leadShift = 0; tailShift = lenChange; @@ -2338,8 +2323,7 @@ Tcl_ListObjReplace( } } LIST_ASSERT(tailShift <= tailSpace); - } - else { + } else { /* * Both lead and tail need to be shifted to make room. * Divide remaining free space equally between front and back. @@ -2414,13 +2398,11 @@ Tcl_ListObjReplace( /* An unshared span record, re-use it, even if not required */ listRep.spanPtr->spanStart = listRep.storePtr->firstUsed; listRep.spanPtr->spanLength = listRep.storePtr->numUsed; - } - else { + } else { /* Need a new span record */ if (listRep.storePtr->firstUsed == 0) { listRep.spanPtr = NULL; - } - else { + } else { listRep.spanPtr = ListSpanNew(listRep.storePtr->firstUsed, listRep.storePtr->numUsed); } @@ -2829,8 +2811,7 @@ TclLsetFlat( parentList = subListObj; if (index == elemCount) { TclNewObj(subListObj); - } - else { + } else { subListObj = elemPtrs[index]; } if (Tcl_IsShared(subListObj)) { @@ -2848,8 +2829,7 @@ TclLsetFlat( if (index == elemCount) { Tcl_ListObjAppendElement(NULL, parentList, subListObj); - } - else { + } else { TclListObjSetElement(NULL, parentList, index, subListObj); } if (Tcl_IsShared(subListObj)) { diff --git a/generic/tclUtil.c b/generic/tclUtil.c index 269cc2e..7ab6eae 100644 --- a/generic/tclUtil.c +++ b/generic/tclUtil.c @@ -2030,7 +2030,6 @@ Tcl_ConcatObj( for (i = 0; i < objc; i++) { objPtr = objv[i]; if (!TclListObjIsCanonical(objPtr)) { - /* Because of above loop, only possible if empty string. Skip */ continue; } if (resPtr) { -- cgit v0.12 From 91c060ce823f97838cb5ef520600d9b63e13a027 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 14 Jul 2022 15:44:53 +0000 Subject: 'result' variable should be 'int', not 'ListSizeT' --- generic/tclListObj.c | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/generic/tclListObj.c b/generic/tclListObj.c index 03e88e5..019ed39 100644 --- a/generic/tclListObj.c +++ b/generic/tclListObj.c @@ -2701,7 +2701,8 @@ TclLsetFlat( /* Index args. */ Tcl_Obj *valueObj) /* Value arg to 'lset' or NULL to 'lpop'. */ { - ListSizeT index, result, len; + ListSizeT index, len; + int result; Tcl_Obj *subListObj, *retValueObj; Tcl_Obj *pendingInvalidates[10]; Tcl_Obj **pendingInvalidatesPtr = pendingInvalidates; -- cgit v0.12 From 269b0fd3c44a9cbb3afb12f6164598f1e26c229c Mon Sep 17 00:00:00 2001 From: apnadkarni Date: Fri, 15 Jul 2022 15:50:26 +0000 Subject: Start on list representation black box tests --- generic/tclInt.decls | 11 ++ generic/tclInt.h | 3 + generic/tclIntDecls.h | 12 ++ generic/tclListObj.c | 309 +++++++++++++++++++++++++++++++------------------- generic/tclStubInit.c | 2 + generic/tclTest.c | 154 +++++++++++++++++++++++++ 6 files changed, 374 insertions(+), 117 deletions(-) diff --git a/generic/tclInt.decls b/generic/tclInt.decls index 5a9f4f0..7828872 100644 --- a/generic/tclInt.decls +++ b/generic/tclInt.decls @@ -1039,6 +1039,17 @@ declare 258 { declare 259 { void TclUnusedStubEntry(void) } + +# TIP 625: for unit testing - create list objects with span +declare 260 { + Tcl_Obj *TclListTestObj(int length, int leadingSpace, int endSpace) +} + +# TIP 625: for unit testing - check list invariants +declare 261 { + void TclListObjValidate(Tcl_Interp *interp, Tcl_Obj *listObj) +} + ############################################################################## diff --git a/generic/tclInt.h b/generic/tclInt.h index b892a7b..06ec2ad 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -2500,6 +2500,9 @@ typedef struct ListSpan { ListSizeT spanLength; /* Number of elements in the span */ int refCount; /* Count of references to this span record */ } ListSpan; +#ifndef LIST_SPAN_THRESHOLD /* May be set on build line */ +#define LIST_SPAN_THRESHOLD 101 +#endif /* * ListRep -- diff --git a/generic/tclIntDecls.h b/generic/tclIntDecls.h index 33b6883..5d728a0 100644 --- a/generic/tclIntDecls.h +++ b/generic/tclIntDecls.h @@ -658,6 +658,12 @@ EXTERN Tcl_Obj * TclpCreateTemporaryDirectory(Tcl_Obj *dirObj, Tcl_Obj *basenameObj); /* 259 */ EXTERN void TclUnusedStubEntry(void); +/* 260 */ +EXTERN Tcl_Obj * TclListTestObj(int length, int leadingSpace, + int endSpace); +/* 261 */ +EXTERN void TclListObjValidate(Tcl_Interp *interp, + Tcl_Obj *listObj); typedef struct TclIntStubs { int magic; @@ -923,6 +929,8 @@ typedef struct TclIntStubs { 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 */ + Tcl_Obj * (*tclListTestObj) (int length, int leadingSpace, int endSpace); /* 260 */ + void (*tclListObjValidate) (Tcl_Interp *interp, Tcl_Obj *listObj); /* 261 */ } TclIntStubs; extern const TclIntStubs *tclIntStubsPtr; @@ -1370,6 +1378,10 @@ extern const TclIntStubs *tclIntStubsPtr; (tclIntStubsPtr->tclpCreateTemporaryDirectory) /* 258 */ #define TclUnusedStubEntry \ (tclIntStubsPtr->tclUnusedStubEntry) /* 259 */ +#define TclListTestObj \ + (tclIntStubsPtr->tclListTestObj) /* 260 */ +#define TclListObjValidate \ + (tclIntStubsPtr->tclListObjValidate) /* 261 */ #endif /* defined(USE_TCL_STUBS) */ diff --git a/generic/tclListObj.c b/generic/tclListObj.c index 019ed39..dc08f4d 100644 --- a/generic/tclListObj.c +++ b/generic/tclListObj.c @@ -71,10 +71,11 @@ * If ENABLE_LIST_INVARIANTS is enabled (-DENABLE_LIST_INVARIANTS from the * command line), the entire list internal representation is checked for * inconsistencies. This has a non-trivial cost so has to be separately - * enabled and not part of assertions checking. + * enabled and not part of assertions checking. However, the test suite does + * invoke ListRepValidate directly even without ENABLE_LIST_INVARIANTS. */ #ifdef ENABLE_LIST_INVARIANTS -#define LISTREP_CHECK(listRepPtr_) ListRepValidate(listRepPtr_) +#define LISTREP_CHECK(listRepPtr_) ListRepValidate(listRepPtr_, __FILE__, __LINE__) #else #define LISTREP_CHECK(listRepPtr_) (void) 0 #endif @@ -114,33 +115,29 @@ /* * Prototypes for non-inline static functions defined later in this file: */ -static int MemoryAllocationError(Tcl_Interp *, size_t size); -static int ListLimitExceededError(Tcl_Interp *); -static ListStore * -ListStoreNew(ListSizeT objc, Tcl_Obj *const objv[], int flags); -static int -ListRepInit(ListSizeT objc, Tcl_Obj *const objv[], int flags, ListRep *); -static int ListRepInitAttempt(Tcl_Interp *, - ListSizeT objc, - Tcl_Obj *const objv[], - ListRep *); -static void ListRepClone(ListRep *fromRepPtr, ListRep *toRepPtr, int flags); -static void ListRepUnsharedFreeUnreferenced(const ListRep *repPtr); -static int TclListObjGetRep(Tcl_Interp *, Tcl_Obj *listPtr, ListRep *repPtr); -static void ListRepRange(ListRep *srcRepPtr, - ListSizeT rangeStart, - ListSizeT rangeEnd, - int preserveSrcRep, - ListRep *rangeRepPtr); +static int MemoryAllocationError(Tcl_Interp *, size_t size); +static int ListLimitExceededError(Tcl_Interp *); +static ListStore *ListStoreNew(ListSizeT objc, Tcl_Obj *const objv[], int flags); +static int ListRepInit(ListSizeT objc, Tcl_Obj *const objv[], int flags, ListRep *); +static int ListRepInitAttempt(Tcl_Interp *, + ListSizeT objc, + Tcl_Obj *const objv[], + ListRep *); +static void ListRepClone(ListRep *fromRepPtr, ListRep *toRepPtr, int flags); +static void ListRepUnsharedFreeUnreferenced(const ListRep *repPtr); +static int TclListObjGetRep(Tcl_Interp *, Tcl_Obj *listPtr, ListRep *repPtr); +static void ListRepRange(ListRep *srcRepPtr, + ListSizeT rangeStart, + ListSizeT rangeEnd, + int preserveSrcRep, + ListRep *rangeRepPtr); static ListStore *ListStoreReallocate(ListStore *storePtr, ListSizeT numSlots); -#ifdef ENABLE_LIST_ASSERTS /* Else gcc complains about unused static */ -static void ListRepValidate(const ListRep *repPtr); -#endif - -static void DupListInternalRep(Tcl_Obj *srcPtr, Tcl_Obj *copyPtr); -static void FreeListInternalRep(Tcl_Obj *listPtr); -static int SetListFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr); -static void UpdateStringOfList(Tcl_Obj *listPtr); +static void ListRepValidate(const ListRep *repPtr, const char *file, + int lineNum); +static void DupListInternalRep(Tcl_Obj *srcPtr, Tcl_Obj *copyPtr); +static void FreeListInternalRep(Tcl_Obj *listPtr); +static int SetListFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr); +static void UpdateStringOfList(Tcl_Obj *listPtr); /* * The structure below defines the list Tcl object type by means of functions @@ -217,7 +214,7 @@ const Tcl_ObjType tclListType = { TclInvalidateStringRep(objPtr_); \ ListObjStompRep(objPtr_, repPtr_); \ } while (0) - + /* *------------------------------------------------------------------------ * @@ -245,7 +242,7 @@ ListSpanNew( spanPtr->spanLength = numSlots; return spanPtr; } - + /* *------------------------------------------------------------------------ * @@ -261,13 +258,12 @@ ListSpanNew( * *------------------------------------------------------------------------ */ - static inline void ListSpanIncrRefs(ListSpan *spanPtr) { spanPtr->refCount += 1; } - + /* *------------------------------------------------------------------------ * @@ -284,7 +280,6 @@ ListSpanIncrRefs(ListSpan *spanPtr) * *------------------------------------------------------------------------ */ - static inline void ListSpanDecrRefs(ListSpan *spanPtr) { @@ -294,7 +289,7 @@ ListSpanDecrRefs(ListSpan *spanPtr) spanPtr->refCount -= 1; } } - + /* *------------------------------------------------------------------------ * @@ -315,7 +310,6 @@ ListSpanDecrRefs(ListSpan *spanPtr) * *------------------------------------------------------------------------ */ - static inline int ListSpanMerited( ListSizeT length, /* Length of the proposed span */ @@ -330,20 +324,20 @@ ListSpanMerited( existing storage has a "large" ref count, then it might make sense to do even a small span. */ -#ifndef TCL_LIST_SPAN_MINSIZE /* May be set on build line */ -#define TCL_LIST_SPAN_MINSIZE 101 -#endif - if (length < TCL_LIST_SPAN_MINSIZE) + if (length < LIST_SPAN_THRESHOLD) { return 0;/* No span for small lists */ - if (length < (allocatedStorageLength/2 - allocatedStorageLength/8)) + } + if (length < (allocatedStorageLength / 2 - allocatedStorageLength / 8)) { return 0; /* No span if less than 3/8 of allocation */ - if (length < usedStorageLength / 2) + } + if (length < usedStorageLength / 2) { return 0; /* No span if less than half current storage */ + } return 1; } - + /* *------------------------------------------------------------------------ * @@ -367,7 +361,7 @@ ListStoreUpSize(ListSizeT numSlotsRequested) { return numSlotsRequested < (LIST_MAX / 2) ? 2 * numSlotsRequested : LIST_MAX; } - + /* *------------------------------------------------------------------------ * @@ -394,7 +388,7 @@ ListRepFreeUnreferenced(const ListRep *repPtr) ListRepUnsharedFreeUnreferenced(repPtr); } } - + /* *------------------------------------------------------------------------ * @@ -426,7 +420,7 @@ ObjArrayIncrRefs( ++objv; } } - + /* *------------------------------------------------------------------------ * @@ -458,7 +452,7 @@ ObjArrayDecrRefs( ++objv; } } - + /* *------------------------------------------------------------------------ * @@ -489,7 +483,7 @@ ObjArrayCopy( *to++ = *from++; } } - + /* *------------------------------------------------------------------------ * @@ -521,7 +515,7 @@ MemoryAllocationError( } return TCL_ERROR; } - + /* *------------------------------------------------------------------------ * @@ -543,13 +537,12 @@ ListLimitExceededError(Tcl_Interp *interp) if (interp != NULL) { Tcl_SetObjResult( interp, - Tcl_ObjPrintf("max length of a Tcl list (%u) elements) exceeded", - LIST_MAX)); + Tcl_NewStringObj("max length of a Tcl list exceeded", -1)); Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL); } return TCL_ERROR; } - + /* *------------------------------------------------------------------------ * @@ -651,69 +644,99 @@ ListRepUnsharedShiftUp(ListRep *repPtr, ListSizeT shiftCount) LISTREP_CHECK(repPtr); } - -#ifdef ENABLE_LIST_ASSERTS /* Else gcc complains about unused static */ + /* *------------------------------------------------------------------------ * * ListRepValidate -- * - * Checks all invariants for a ListRep. + * Checks all invariants for a ListRep and panics on failure. + * Note this is independent of NDEBUG, assert etc. * * Results: * None. * * Side effects: - * Panics (assertion failure) if any invariant is not met. + * Panics if any invariant is not met. * *------------------------------------------------------------------------ */ static void -ListRepValidate(const ListRep *repPtr) +ListRepValidate(const ListRep *repPtr, const char *file, int lineNum) { ListStore *storePtr = repPtr->storePtr; + const char *condition; (void)storePtr; /* To stop gcc from whining about unused vars */ +#define INVARIANT(cond_) \ + do { \ + if (!(cond_)) { \ + condition = #cond_; \ + goto failure; \ + } \ + } while (0) + /* Separate each condition so line number gives exact reason for failure */ - LIST_ASSERT(storePtr != NULL); - LIST_ASSERT(storePtr->numAllocated >= 0); - LIST_ASSERT(storePtr->numAllocated <= LIST_MAX); - LIST_ASSERT(storePtr->firstUsed >= 0); - LIST_ASSERT(storePtr->firstUsed < storePtr->numAllocated); - LIST_ASSERT(storePtr->numUsed >= 0); - LIST_ASSERT(storePtr->numUsed <= storePtr->numAllocated); - LIST_ASSERT(storePtr->firstUsed - <= (storePtr->numAllocated - storePtr->numUsed)); - -#if 0 && defined(LIST_MEM_DEBUG) - /* Corresponding zeroing out not implemented yet */ - for (i = 0; i < storePtr->firstUsed; ++i) { - LIST_ASSERT(storePtr->slots[i] == NULL); - } - for (i = storePtr->firstUsed + storePtr->numUsed; - i < storePtr->numAllocated; - ++i) { - LIST_ASSERT(storePtr->slots[i] == NULL); - } -#endif + INVARIANT(storePtr != NULL); + INVARIANT(storePtr->numAllocated >= 0); + INVARIANT(storePtr->numAllocated <= LIST_MAX); + INVARIANT(storePtr->firstUsed >= 0); + INVARIANT(storePtr->firstUsed < storePtr->numAllocated); + INVARIANT(storePtr->numUsed >= 0); + INVARIANT(storePtr->numUsed <= storePtr->numAllocated); + INVARIANT(storePtr->firstUsed <= (storePtr->numAllocated - storePtr->numUsed)); if (! ListRepIsShared(repPtr)) { /* * If this is the only reference and there is no span, then store * occupancy must begin at 0 */ - LIST_ASSERT(repPtr->spanPtr || repPtr->storePtr->firstUsed == 0); + INVARIANT(repPtr->spanPtr || repPtr->storePtr->firstUsed == 0); } - LIST_ASSERT(ListRepStart(repPtr) >= storePtr->firstUsed); - LIST_ASSERT(ListRepLength(repPtr) <= storePtr->numUsed); - LIST_ASSERT(ListRepStart(repPtr) - <= (storePtr->firstUsed + storePtr->numUsed - ListRepLength(repPtr))); + INVARIANT(ListRepStart(repPtr) >= storePtr->firstUsed); + INVARIANT(ListRepLength(repPtr) <= storePtr->numUsed); + INVARIANT(ListRepStart(repPtr) <= (storePtr->firstUsed + storePtr->numUsed - ListRepLength(repPtr))); -} -#endif /* ENABLE_LIST_ASSERTS */ +#undef INVARIANT + + return; +failure: + Tcl_Panic("List internal failure in %s line %d. Condition: %s", + file, + lineNum, + condition); +} + +/* + *------------------------------------------------------------------------ + * + * TclListObjValidate -- + * + * Wrapper around ListRepValidate. Primarily used from test suite. + * + * Results: + * None. + * + * Side effects: + * Will panic if internal structure is not consistent or if object + * cannot be converted to a list object. + * + *------------------------------------------------------------------------ + */ +void +TclListObjValidate(Tcl_Interp *interp, Tcl_Obj *listObj) +{ + ListRep listRep; + if (TclListObjGetRep(interp, listObj, &listRep) != TCL_OK) { + Tcl_Panic("Object passed to TclListObjValidate cannot be converted to " + "a list object."); + } + ListRepValidate(&listRep, __FILE__, __LINE__); +} + /* *---------------------------------------------------------------------- * @@ -754,8 +777,7 @@ ListStoreNew( */ if (objc > LIST_MAX) { if (flags & LISTREP_PANIC_ON_FAIL) { - Tcl_Panic("max length of a Tcl list (%u elements) exceeded", - LIST_MAX); + Tcl_Panic("max length of a Tcl list exceeded"); } return NULL; } @@ -811,7 +833,7 @@ ListStoreNew( return storePtr; } - + /* *------------------------------------------------------------------------ * @@ -851,7 +873,7 @@ ListStoreReallocate (ListStore *storePtr, ListSizeT numSlots) newStorePtr->numAllocated = newCapacity; return newStorePtr; } - + /* *---------------------------------------------------------------------- * @@ -920,7 +942,7 @@ ListRepInit( repPtr->spanPtr = NULL; return TCL_ERROR; } - + /* *---------------------------------------------------------------------- * @@ -964,7 +986,7 @@ ListRepInitAttempt( } return result; } - + /* *------------------------------------------------------------------------ * @@ -995,7 +1017,7 @@ ListRepClone(ListRep *fromRepPtr, ListRep *toRepPtr, int flags) ListRepElements(fromRepPtr, numFrom, fromObjs); ListRepInit(numFrom, fromObjs, flags | LISTREP_PANIC_ON_FAIL, toRepPtr); } - + /* *------------------------------------------------------------------------ * @@ -1016,7 +1038,6 @@ ListRepClone(ListRep *fromRepPtr, ListRep *toRepPtr, int flags) * *------------------------------------------------------------------------ */ - static void ListRepUnsharedFreeUnreferenced(const ListRep *repPtr) { ListSizeT count; @@ -1058,7 +1079,7 @@ static void ListRepUnsharedFreeUnreferenced(const ListRep *repPtr) LIST_ASSERT(ListRepLength(repPtr) == storePtr->numUsed); LISTREP_CHECK(repPtr); } - + /* *---------------------------------------------------------------------- * @@ -1118,7 +1139,7 @@ Tcl_NewListObj( return listObj; } #endif /* if TCL_MEM_DEBUG */ - + /* *---------------------------------------------------------------------- * @@ -1186,7 +1207,7 @@ Tcl_DbNewListObj( return Tcl_NewListObj(objc, objv); } #endif /* TCL_MEM_DEBUG */ - + /* *------------------------------------------------------------------------ * @@ -1240,7 +1261,7 @@ TclNewListObj2( storePtr->numUsed = objc; return listObj; } - + /* *---------------------------------------------------------------------- * @@ -1287,7 +1308,7 @@ TclListObjGetRep( LISTREP_CHECK(repPtr); return TCL_OK; } - + /* *---------------------------------------------------------------------- * @@ -1538,7 +1559,7 @@ ListRepRange( LISTREP_CHECK(rangeRepPtr); return; } - + /* *---------------------------------------------------------------------- * @@ -1655,7 +1676,6 @@ Tcl_ListObjGetElements( * *---------------------------------------------------------------------- */ - int Tcl_ListObjAppendList( Tcl_Interp *interp, /* Used to report errors if not NULL. */ @@ -1680,7 +1700,7 @@ Tcl_ListObjAppendList( return TclListObjAppendElements(interp, toObj, objc, objv); } - + /* *------------------------------------------------------------------------ * @@ -1821,7 +1841,7 @@ Tcl_ListObjAppendList( ListObjReplaceRepAndInvalidate(toObj, &listRep); return TCL_OK; } - + /* *---------------------------------------------------------------------- * @@ -1848,7 +1868,6 @@ Tcl_ListObjAppendList( * *---------------------------------------------------------------------- */ - int Tcl_ListObjAppendElement( Tcl_Interp *interp, /* Used to report errors if not NULL. */ @@ -1887,7 +1906,6 @@ Tcl_ListObjAppendElement( * *---------------------------------------------------------------------- */ - int Tcl_ListObjIndex( Tcl_Interp *interp, /* Used to report errors if not NULL. */ @@ -1962,7 +1980,7 @@ Tcl_ListObjLength( *lenPtr = ListRepLength(&listRep); return TCL_OK; } - + /* *---------------------------------------------------------------------- * @@ -2018,6 +2036,7 @@ Tcl_ListObjReplace( ListSizeT leadShift; ListSizeT tailShift; Tcl_Obj **listObjs; + int favor; if (Tcl_IsShared(listObj)) { Tcl_Panic("%s called with shared object", "Tcl_ListObjReplace"); @@ -2047,6 +2066,17 @@ Tcl_ListObjReplace( return ListLimitExceededError(interp); } + if ((first+numToDelete) >= origListLen) { + /* Operating at back of list. Favor leaving space at back */ + favor = LISTREP_SPACE_FAVOR_BACK; + } else if (first == 0) { + /* Operating on front of list. Favor leaving space in front */ + favor = LISTREP_SPACE_FAVOR_FRONT; + } else { + /* Operating on middle of list. */ + favor = LISTREP_SPACE_FAVOR_NONE; + } + /* * There are a number of special cases to consider from an optimization * point of view. @@ -2108,7 +2138,7 @@ Tcl_ListObjReplace( * (ii) The list's span must be at head of the in-use slots in the store * (iii) There must be unused room at front of the store * NOTE THIS IS TRUE EVEN IF THE ListStore IS SHARED as it will not - * affect the other Tcl_Obj's referencing this ListStore. See the TIP. + * affect the other Tcl_Obj's referencing this ListStore. */ if (first == 0 && /* (i) */ ListRepStart(&listRep) == listRep.storePtr->firstUsed && /* (ii) */ @@ -2187,7 +2217,7 @@ Tcl_ListObjReplace( listObjs = &listRep.storePtr->slots[ListRepStart(&listRep)]; ListRepInit(origListLen + lenChange, NULL, - LISTREP_PANIC_ON_FAIL | LISTREP_SPACE_FAVOR_NONE, + LISTREP_PANIC_ON_FAIL | favor, &newRep); toObjs = ListRepSlotPtr(&newRep, 0); if (leadSegmentLen > 0) { @@ -2412,7 +2442,6 @@ Tcl_ListObjReplace( ListObjReplaceRepAndInvalidate(listObj, &listRep); return TCL_OK; } - /* *---------------------------------------------------------------------- @@ -2438,7 +2467,6 @@ Tcl_ListObjReplace( * *---------------------------------------------------------------------- */ - Tcl_Obj * TclLindexList( Tcl_Interp *interp, /* Tcl interpreter. */ @@ -2518,7 +2546,6 @@ TclLindexList( * *---------------------------------------------------------------------- */ - Tcl_Obj * TclLindexFlat( Tcl_Interp *interp, /* Tcl interpreter. */ @@ -2607,7 +2634,6 @@ TclLindexFlat( * *---------------------------------------------------------------------- */ - Tcl_Obj * TclLsetList( Tcl_Interp *interp, /* Tcl interpreter. */ @@ -2691,7 +2717,6 @@ TclLsetList( * *---------------------------------------------------------------------- */ - Tcl_Obj * TclLsetFlat( Tcl_Interp *interp, /* Tcl interpreter. */ @@ -2950,7 +2975,6 @@ TclLsetFlat( * *---------------------------------------------------------------------- */ - int TclListObjSetElement( Tcl_Interp *interp, /* Tcl interpreter; used for error reporting @@ -3030,7 +3054,6 @@ TclListObjSetElement( * *---------------------------------------------------------------------- */ - static void FreeListInternalRep( Tcl_Obj *listObj) /* List object with internal rep to free. */ @@ -3065,7 +3088,6 @@ FreeListInternalRep( * *---------------------------------------------------------------------- */ - static void DupListInternalRep( Tcl_Obj *srcObj, /* Object with internal rep to copy. */ @@ -3075,7 +3097,7 @@ DupListInternalRep( ListObjGetRep(srcObj, &listRep); ListObjOverwriteRep(copyObj, &listRep); } - + /* *---------------------------------------------------------------------- * @@ -3094,7 +3116,6 @@ DupListInternalRep( * *---------------------------------------------------------------------- */ - static int SetListFromAny( Tcl_Interp *interp, /* Used for error reporting if not NULL. */ @@ -3257,7 +3278,6 @@ fail: * *---------------------------------------------------------------------- */ - static void UpdateStringOfList( Tcl_Obj *listObj) /* List object with string rep to update. */ @@ -3345,6 +3365,61 @@ UpdateStringOfList( } /* + *------------------------------------------------------------------------ + * + * TclListTestObj -- + * + * Returns a list object with a specific internal rep and content. + * Used specifically for testing so span can be controlled explicitly. + * + * Results: + * Pointer to the Tcl_Obj containing the list. + * + * Side effects: + * None. + * + *------------------------------------------------------------------------ + */ +Tcl_Obj * +TclListTestObj (int length, int leadingSpace, int endSpace) +{ + if (length < 0) + length = 0; + if (leadingSpace < 0) + leadingSpace = 0; + if (endSpace < 0) + endSpace = 0; + + ListRep listRep; + ListSizeT capacity; + Tcl_Obj *listObj; + + TclNewObj(listObj); + + /* Only a test object so ignoring overflow checks */ + capacity = length + leadingSpace + endSpace; + if (capacity == 0) { + return listObj; + } + + ListRepInit(capacity, NULL, 0, &listRep); + + ListStore *storePtr = listRep.storePtr; + int i; + for (i = 0; i < length; ++i) { + storePtr->slots[i + leadingSpace] = Tcl_NewIntObj(i); + Tcl_IncrRefCount(storePtr->slots[i + leadingSpace]); + } + storePtr->firstUsed = leadingSpace; + storePtr->numUsed = length; + if (leadingSpace != 0) { + listRep.spanPtr = ListSpanNew(leadingSpace, length); + } + ListObjReplaceRepAndInvalidate(listObj, &listRep); + return listObj; +} + +/* * Local Variables: * mode: c * c-basic-offset: 4 diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c index 2b7952d..37886d6 100644 --- a/generic/tclStubInit.c +++ b/generic/tclStubInit.c @@ -1119,6 +1119,8 @@ static const TclIntStubs tclIntStubs = { TclStaticLibrary, /* 257 */ TclpCreateTemporaryDirectory, /* 258 */ TclUnusedStubEntry, /* 259 */ + TclListTestObj, /* 260 */ + TclListObjValidate, /* 261 */ }; static const TclIntPlatStubs tclIntPlatStubs = { diff --git a/generic/tclTest.c b/generic/tclTest.c index e3c6663..e1dd1d5 100644 --- a/generic/tclTest.c +++ b/generic/tclTest.c @@ -258,6 +258,7 @@ static Tcl_ObjCmdProc TestgetvarfullnameCmd; static Tcl_CmdProc TestinterpdeleteCmd; static Tcl_CmdProc TestlinkCmd; static Tcl_ObjCmdProc TestlinkarrayCmd; +static Tcl_ObjCmdProc TestlistrepCmd; static Tcl_ObjCmdProc TestlocaleCmd; static Tcl_CmdProc TestmainthreadCmd; static Tcl_CmdProc TestsetmainloopCmd; @@ -640,6 +641,7 @@ Tcltest_Init( NULL, NULL); Tcl_CreateCommand(interp, "testlink", TestlinkCmd, NULL, NULL); Tcl_CreateObjCommand(interp, "testlinkarray", TestlinkarrayCmd, NULL, NULL); + Tcl_CreateObjCommand(interp, "testlistrep", TestlistrepCmd, NULL, NULL); Tcl_CreateObjCommand(interp, "testlocale", TestlocaleCmd, NULL, NULL); Tcl_CreateCommand(interp, "testpanic", TestpanicCmd, NULL, NULL); @@ -3389,6 +3391,158 @@ TestlinkarrayCmd( /* *---------------------------------------------------------------------- * + * TestlistrepCmd -- + * + * This function is invoked to generate a list object with a specific + * internal representation. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +TestlistrepCmd( + TCL_UNUSED(void *), + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ + /* Subcommands supported by this command */ + const char* subcommands[] = { + "new", + "describe", + "config", + "validate", + NULL + }; + enum { + LISTREP_NEW, + LISTREP_DESCRIBE, + LISTREP_CONFIG, + LISTREP_VALIDATE + } cmdIndex; + Tcl_Obj *resultObj = NULL; + + if (objc < 2) { + Tcl_WrongNumArgs(interp, 1, objv, "command ?arg ...?"); + return TCL_ERROR; + } + if (Tcl_GetIndexFromObj( + interp, objv[1], subcommands, "command", 0, &cmdIndex) + != TCL_OK) { + return TCL_ERROR; + } + switch (cmdIndex) { + case LISTREP_NEW: + if (objc < 3 || objc > 5) { + Tcl_WrongNumArgs(interp, 2, objv, "length ?leadSpace endSpace?"); + return TCL_ERROR; + } else { + int length; + int leadSpace = 0; + int endSpace = 0; + if (Tcl_GetIntFromObj(interp, objv[2], &length) != TCL_OK) { + return TCL_ERROR; + } + if (objc > 3) { + if (Tcl_GetIntFromObj(interp, objv[3], &leadSpace) != TCL_OK) { + return TCL_ERROR; + } + if (objc > 4) { + if (Tcl_GetIntFromObj(interp, objv[4], &endSpace) + != TCL_OK) { + return TCL_ERROR; + } + } + } + resultObj = TclListTestObj(length, leadSpace, endSpace); + } + break; + + case LISTREP_DESCRIBE: +#define APPEND_FIELD(targetObj_, structPtr_, fld_) \ + do { \ + Tcl_ListObjAppendElement( \ + interp, (targetObj_), Tcl_NewStringObj(#fld_, -1)); \ + Tcl_ListObjAppendElement( \ + interp, (targetObj_), Tcl_NewWideIntObj((structPtr_)->fld_)); \ + } while (0) + if (objc != 3) { + Tcl_WrongNumArgs(interp, 2, objv, "object"); + return TCL_ERROR; + } else { + Tcl_Obj **objs; + ListSizeT nobjs; + ListRep listRep; + Tcl_Obj *listRepObjs[4]; + + /* Force list representation */ + if (Tcl_ListObjGetElements(interp, objv[2], &nobjs, &objs) != TCL_OK) { + return TCL_ERROR; + } + ListObjGetRep(objv[2], &listRep); + listRepObjs[0] = Tcl_NewStringObj("store", -1); + listRepObjs[1] = Tcl_NewListObj(12, NULL); + Tcl_ListObjAppendElement( + interp, listRepObjs[1], Tcl_NewStringObj("memoryAddress", -1)); + Tcl_ListObjAppendElement( + interp, listRepObjs[1], Tcl_ObjPrintf("%p", listRep.storePtr)); + APPEND_FIELD(listRepObjs[1], listRep.storePtr, firstUsed); + APPEND_FIELD(listRepObjs[1], listRep.storePtr, numUsed); + APPEND_FIELD(listRepObjs[1], listRep.storePtr, numAllocated); + APPEND_FIELD(listRepObjs[1], listRep.storePtr, refCount); + APPEND_FIELD(listRepObjs[1], listRep.storePtr, flags); + if (listRep.spanPtr) { + listRepObjs[2] = Tcl_NewStringObj("span", -1); + listRepObjs[3] = Tcl_NewListObj(8, NULL); + Tcl_ListObjAppendElement(interp, + listRepObjs[3], + Tcl_NewStringObj("memoryAddress", -1)); + Tcl_ListObjAppendElement( + interp, listRepObjs[3], Tcl_ObjPrintf("%p", listRep.spanPtr)); + APPEND_FIELD(listRepObjs[3], listRep.spanPtr, spanStart); + APPEND_FIELD( + listRepObjs[3], listRep.spanPtr, spanLength); + APPEND_FIELD(listRepObjs[3], listRep.spanPtr, refCount); + } + resultObj = Tcl_NewListObj(listRep.spanPtr ? 4 : 2, listRepObjs); + } +#undef APPEND_FIELD + break; + + case LISTREP_CONFIG: + if (objc != 2) { + Tcl_WrongNumArgs(interp, 2, objv, "object"); + return TCL_ERROR; + } + resultObj = Tcl_NewListObj(2, NULL); + Tcl_ListObjAppendElement( + NULL, resultObj, Tcl_NewStringObj("LIST_SPAN_THRESHOLD", -1)); + Tcl_ListObjAppendElement( + NULL, resultObj, Tcl_NewWideIntObj(LIST_SPAN_THRESHOLD)); + break; + + case LISTREP_VALIDATE: + if (objc != 3) { + Tcl_WrongNumArgs(interp, 2, objv, "object"); + return TCL_ERROR; + } + TclListObjValidate(interp, objv[2]); /* Panics if invalid */ + resultObj = Tcl_NewObj(); + break; + } + Tcl_SetObjResult(interp, resultObj); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * * TestlocaleCmd -- * * This procedure implements the "testlocale" command. It is used -- cgit v0.12 From c1af880cfe49e05ba4dd7d2607ba3715f1ff87c3 Mon Sep 17 00:00:00 2001 From: Kevin B Kenny Date: Fri, 15 Jul 2022 17:11:41 +0000 Subject: Restore FP control word on conversion of zero values. Sneak path existed that failed to restore the floating point control word when scanning a zero value. The result was that floating point rounding was incorrectly left set to 53-bit significance, round-to-even, which is incompatible with the math library from musl. --- generic/tclStrToD.c | 42 +++++++++++++++++++++++++++++------------- 1 file changed, 29 insertions(+), 13 deletions(-) diff --git a/generic/tclStrToD.c b/generic/tclStrToD.c index 61162d0..efff815 100644 --- a/generic/tclStrToD.c +++ b/generic/tclStrToD.c @@ -1627,7 +1627,6 @@ MakeLowPrecisionDouble( int numSigDigs, /* Number of digits in the significand */ long exponent) /* Power of ten */ { - double retval; /* Value of the number. */ mp_int significandBig; /* Significand expressed as a bignum. */ /* @@ -1635,18 +1634,25 @@ MakeLowPrecisionDouble( * This causes the result of double-precision calculations to be rounded * twice: once to the precision of double-extended and then again to the * precision of double. Double-rounding introduces gratuitous errors of 1 - * ulp, so we need to change rounding mode to 53-bits. + * ulp, so we need to change rounding mode to 53-bits. We also make + * 'retval' volatile, so that it doesn't get promoted to a register. */ - - TCL_IEEE_DOUBLE_ROUNDING; + volatile double retval; /* Value of the number. */ /* - * Test for the easy cases. + * Test for zero significand, which requires explicit construction + * of -0.0. (Unary minus returns a positive zero.) */ - if (significand == 0) { return copysign(0.0, -signum); } + + /* + * Set the FP control word for 53 bits, WARNING: It must be reset + * before returning. + */ + TCL_IEEE_DOUBLE_ROUNDING; + if (numSigDigs <= QUICK_MAX) { if (exponent >= 0) { if (exponent <= mmaxpow) { @@ -1744,7 +1750,6 @@ MakeHighPrecisionDouble( int numSigDigs, /* Number of significant digits */ long exponent) /* Power of 10 by which to multiply */ { - double retval; int machexp; /* Machine exponent of a power of 10. */ /* @@ -1752,19 +1757,30 @@ MakeHighPrecisionDouble( * This causes the result of double-precision calculations to be rounded * twice: once to the precision of double-extended and then again to the * precision of double. Double-rounding introduces gratuitous errors of 1 - * ulp, so we need to change rounding mode to 53-bits. + * ulp, so we need to change rounding mode to 53-bits. We also make + * 'retval' volatile to make sure that it doesn't get promoted to a + * register. */ + volatile double retval; + /* + * A zero significand requires explicit construction of -0.0. + * (Unary minus returns positive zero.) + */ + if (mp_iszero(significand)) { + return copysign(0.0, -signum); + } + + /* + * Set the 53-bit rounding mode. WARNING: It must be reset before + * returning. + */ TCL_IEEE_DOUBLE_ROUNDING; /* - * Quick checks for zero, and over/underflow. Be careful to avoid + * Make quick checks for over/underflow. Be careful to avoid * integer overflow when calculating with 'exponent'. */ - - if (mp_iszero(significand)) { - return copysign(0.0, -signum); - } if (exponent >= 0 && exponent-1 > maxDigits-numSigDigs) { retval = HUGE_VAL; goto returnValue; -- cgit v0.12 From f4e50b43c7316f2cc960a202a8759116f575284f Mon Sep 17 00:00:00 2001 From: apnadkarni Date: Sat, 16 Jul 2022 15:53:38 +0000 Subject: Optimize couple of special cases: - If unshared, prefer in-place deletion at end to span creation. - Range on entire list. --- generic/tclListObj.c | 113 +++++++++++++++++++++++++++++++++++---------------- 1 file changed, 78 insertions(+), 35 deletions(-) diff --git a/generic/tclListObj.c b/generic/tclListObj.c index dc08f4d..8f8d0b9 100644 --- a/generic/tclListObj.c +++ b/generic/tclListObj.c @@ -1412,16 +1412,18 @@ TclListObjCopy( * None. * * Side effects: - * The ListStore and ListSpan referenced by in the returned ListRep - * may or may not be the same as those passed in. For example, the - * ListStore may differ because the range is small enough that a new - * ListStore is more memory-optimal. The ListSpan may differ because - * it is NULL or shared. Regardless, reference counts on the returned - * values are not incremented. Generally, ListObjReplaceRepAndInvalidate may be - * used to store the new ListRep back into an object or a ListRepIncRefs - * followed by ListRepDecrRefs to free in case of errors. - * TODO WARNING:- this is not a very clean interface and easy for caller - * to get wrong. Better change it to pass in the source ListObj + * The ListStore and ListSpan referenced by in the returned ListRep + * may or may not be the same as those passed in. For example, the + * ListStore may differ because the range is small enough that a new + * ListStore is more memory-optimal. The ListSpan may differ because + * it is NULL or shared. Regardless, reference counts on the returned + * values are not incremented. Generally, ListObjReplaceRepAndInvalidate + * may be used to store the new ListRep back into an object or a + * ListRepIncrRefs followed by ListRepDecrRefs to free in case of errors. + * Any other use should be carefully reconsidered. + * TODO WARNING:- this is an awkward interface and easy for caller + * to get wrong. Mostly due to refcount combinations. Perhaps passing + * in the source listObj instead of source listRep might simplify. * *------------------------------------------------------------------------ */ @@ -1438,13 +1440,14 @@ ListRepRange( Tcl_Obj **srcElems; ListSizeT numSrcElems = ListRepLength(srcRepPtr); ListSizeT rangeLen; - int doSpan; + ListSizeT numAfterRangeEnd; LISTREP_CHECK(srcRepPtr); /* Take the opportunity to garbage collect */ /* TODO - we probably do not need the preserveSrcRep here unlike later */ if (!preserveSrcRep) { + /* T:listrep-1.{4,5,8,9} */ ListRepFreeUnreferenced(srcRepPtr); } @@ -1463,11 +1466,13 @@ ListRepRange( rangeLen = rangeEnd - rangeStart + 1; /* - * We can create a range one of three ways: - * (1) Use a ListSpan referencing the current ListStore - * (2) Creating a new ListStore - * (3) Removing all elements outside the range in the current ListStore - * Option (3) may only be done if caller has not disallowed it AND + * We can create a range one of four ways: + * (0) Range encapsulates entire list + * (1) Special case: deleting in-place from end of an unshared object + * (2) Use a ListSpan referencing the current ListStore + * (3) Creating a new ListStore + * (4) Removing all elements outside the range in the current ListStore + * Option (4) may only be done if caller has not disallowed it AND * the ListStore is not shared. * * The choice depends on heuristics related to speed and memory. @@ -1477,12 +1482,32 @@ ListRepRange( * string-canonizing effect of [lrange 0 end] so the Tcl_Obj should not * be returned as is even if the range encompasses the whole list. */ - doSpan = ListSpanMerited(rangeLen, - srcRepPtr->storePtr->numUsed, - srcRepPtr->storePtr->numAllocated); - - if (doSpan) { - /* Option 1 - because span would be most efficient */ + if (rangeStart == 0 && rangeEnd == (numSrcElems-1)) { + /* Option 0 - entire list. This may be used to canonicalize */ + *rangeRepPtr = *srcRepPtr; /* Not ref counts not incremented */ + } else if (rangeStart == 0 && (!preserveSrcRep) + && (!ListRepIsShared(srcRepPtr) && srcRepPtr->spanPtr == NULL)) { + /* Option 1 - Special case unshared, exclude end elements, no span */ + LIST_ASSERT(srcRepPtr->storePtr->firstUsed == 0); /* If no span */ + ListRepElements(srcRepPtr, numSrcElems, srcElems); + numAfterRangeEnd = numSrcElems - (rangeEnd + 1); + /* Assert: Because numSrcElems > rangeEnd earlier */ + LIST_ASSERT(numAfterRangeEnd >= 0); + if (numAfterRangeEnd != 0) { + /* T:listrep-1.{8,9} */ + ObjArrayDecrRefs(srcElems, rangeEnd + 1, numAfterRangeEnd); + } + /* srcRepPtr->storePtr->firstUsed,numAllocated unchanged */ + srcRepPtr->storePtr->numUsed = rangeLen; + srcRepPtr->storePtr->flags = 0; + rangeRepPtr->storePtr = srcRepPtr->storePtr; /* Note no incr ref */ + rangeRepPtr->spanPtr = NULL; + } else if (ListSpanMerited(rangeLen, + srcRepPtr->storePtr->numUsed, + srcRepPtr->storePtr->numAllocated)) { + /* + * Option 2 - because span would be most efficient + */ ListSizeT spanStart = ListRepStart(srcRepPtr) + rangeStart; if (!preserveSrcRep && srcRepPtr->spanPtr && srcRepPtr->spanPtr->refCount <= 1) { @@ -1491,7 +1516,7 @@ ListRepRange( srcRepPtr->spanPtr->spanLength = rangeLen; *rangeRepPtr = *srcRepPtr; } else { - /* Span not present or is shared - Allocate a new span */ + /* Span not present or is shared. T:listrep-1.5 */ rangeRepPtr->storePtr = srcRepPtr->storePtr; rangeRepPtr->spanPtr = ListSpanNew(spanStart, rangeLen); } @@ -1505,7 +1530,7 @@ ListRepRange( ListRepFreeUnreferenced(rangeRepPtr); } } else if (preserveSrcRep || ListRepIsShared(srcRepPtr)) { - /* Option 2 - span or modification in place not allowed/desired */ + /* Option 3 - span or modification in place not allowed/desired */ ListRepElements(srcRepPtr, numSrcElems, srcElems); /* TODO - allocate extra space? */ ListRepInit(rangeLen, @@ -1514,14 +1539,13 @@ ListRepRange( rangeRepPtr); } else { /* - * Option 3 - modify in place. Note that because of the invariant + * Option 4 - modify in place. Note that because of the invariant * that spanless list stores must start at 0, we have to move * everything to the front. * TODO - perhaps if a span already exists, no need to move to front? * or maybe no need to move all the way to the front? * TODO - if range is small relative to allocation, allocate new? */ - ListSizeT numAfterRangeEnd; /* Asserts follow from call to ListRepFreeUnreferenced earlier */ LIST_ASSERT(!preserveSrcRep); @@ -1533,12 +1557,13 @@ ListRepRange( /* Free leading elements outside range */ if (rangeStart != 0) { + /* T:listrep-1.4 */ ObjArrayDecrRefs(srcElems, 0, rangeStart); } /* Ditto for trailing */ numAfterRangeEnd = numSrcElems - (rangeEnd + 1); - LIST_ASSERT(numAfterRangeEnd - >= 0); /* Because numSrcElems > rangeEnd earlier */ + /* Assert: Because numSrcElems > rangeEnd earlier */ + LIST_ASSERT(numAfterRangeEnd >= 0); if (numAfterRangeEnd != 0) { ObjArrayDecrRefs(srcElems, rangeEnd + 1, numAfterRangeEnd); } @@ -1549,8 +1574,11 @@ ListRepRange( srcRepPtr->storePtr->firstUsed = 0; srcRepPtr->storePtr->numUsed = rangeLen; srcRepPtr->storePtr->flags = 0; - rangeRepPtr->storePtr = srcRepPtr->storePtr; /* Note no incr ref */ - rangeRepPtr->spanPtr = NULL; + if (srcRepPtr->spanPtr) { + ListSpanDecrRefs(srcRepPtr->spanPtr); + srcRepPtr->spanPtr = NULL; + } + *rangeRepPtr = *srcRepPtr; /* Note no ref count increments */ } /* TODO - call freezombies here if !preserveSrcRep? */ @@ -1766,6 +1794,7 @@ Tcl_ListObjAppendList( LIST_ASSERT(toLen == listRep.storePtr->numUsed); if (finalLen > listRep.storePtr->numAllocated) { + /* T:listrep-1.{2,11} */ ListStore *newStorePtr; newStorePtr = ListStoreReallocate(listRep.storePtr, finalLen); if (newStorePtr == NULL) { @@ -2100,17 +2129,20 @@ Tcl_ListObjReplace( if (numToInsert == 0) { if (numToDelete == 0) { /* Should force canonical even for no-op */ + /* T:listrep-1.10 */ TclInvalidateStringRep(listObj); return TCL_OK; } if (first == 0) { - /* Delete from front, so return tail */ + /* Delete from front, so return tail. */ + /* T:listrep-1.{4,5} */ ListRep tailRep; ListRepRange(&listRep, numToDelete, origListLen-1, 0, &tailRep); ListObjReplaceRepAndInvalidate(listObj, &tailRep); return TCL_OK; } else if ((first+numToDelete) >= origListLen) { /* Delete from tail, so return head */ + /* T:listrep-1.{8,9} */ ListRep headRep; ListRepRange(&listRep, 0, first-1, 0, &headRep); ListObjReplaceRepAndInvalidate(listObj, &headRep); @@ -2126,8 +2158,9 @@ Tcl_ListObjReplace( * Check Case (2) - pure inserts under certain conditions: */ if (numToDelete == 0) { - /* Case (2a) - Append to list */ + /* Case (2a) - Append to list. */ if (first == origListLen) { + /* T:listrep-1.11 */ return TclListObjAppendElements( interp, listObj, numToInsert, insertObjs); } @@ -2170,7 +2203,6 @@ Tcl_ListObjReplace( } } - /* Just for readability of the code */ lenChange = numToInsert - numToDelete; leadSegmentLen = first; @@ -2184,6 +2216,7 @@ Tcl_ListObjReplace( * ListObjReplaceAndInvalidate below. */ if (numFreeSlots < lenChange && !ListRepIsShared(&listRep)) { + /* T:listrep-1.{1,3} */ ListStore *newStorePtr = ListStoreReallocate(listRep.storePtr, origListLen + lenChange); if (newStorePtr == NULL) { @@ -2264,13 +2297,14 @@ Tcl_ListObjReplace( /* * Free up elements to be deleted. Before that, increment the ref counts - * for objects to be inserted in case there is overlap. See bug3598580 - * or test listobj-11.1 + * for objects to be inserted in case there is overlap. T:listobj-11.1 */ if (numToInsert) { + /* T:listrep-1.{1,3} */ ObjArrayIncrRefs(insertObjs, 0, numToInsert); } if (numToDelete) { + /* T:listrep-1.{6,7} */ ObjArrayDecrRefs(listObjs, first, numToDelete); } @@ -2295,10 +2329,12 @@ Tcl_ListObjReplace( */ if (leadSegmentLen > tailSegmentLen) { /* Tail segment smaller. Insert after lead, move tail down */ + /* T:listrep-1.7 */ leadShift = 0; tailShift = lenChange; } else { /* Lead segment smaller. Insert before tail, move lead up */ + /* T:listrep-1.6 */ leadShift = -lenChange; tailShift = 0; } @@ -2347,6 +2383,7 @@ Tcl_ListObjReplace( if (finalFreeSpace > 1 && (leadSpace == 0 || leadSegmentLen == 0)) { ListSizeT postShiftTailSpace = tailSpace - lenChange; if (postShiftTailSpace > (finalFreeSpace/2)) { + /* T:listrep-1.{1,3} */ ListSizeT extraShift = postShiftTailSpace - (finalFreeSpace / 2); tailShift += extraShift; leadShift = extraShift; /* Move head to the back as well */ @@ -2390,12 +2427,14 @@ Tcl_ListObjReplace( if (leadShift > 0) { /* Will happen when we have to make room at bottom */ if (tailShift != 0 && tailSegmentLen != 0) { + /* T:listrep-1.{1,3} */ ListSizeT tailStart = leadSegmentLen + numToDelete; memmove(&listObjs[tailStart + tailShift], &listObjs[tailStart], tailSegmentLen * sizeof(Tcl_Obj *)); } if (leadSegmentLen != 0) { + /* T:listrep-1.{3,6} */ memmove(&listObjs[leadShift], &listObjs[0], leadSegmentLen * sizeof(Tcl_Obj *)); @@ -2407,6 +2446,7 @@ Tcl_ListObjReplace( leadSegmentLen * sizeof(Tcl_Obj *)); } if (tailShift != 0 && tailSegmentLen != 0) { + /* T:listrep-1.7 */ ListSizeT tailStart = leadSegmentLen + numToDelete; memmove(&listObjs[tailStart + tailShift], &listObjs[tailStart], @@ -2415,6 +2455,7 @@ Tcl_ListObjReplace( } if (numToInsert) { /* Do NOT use ObjArrayCopy here since we have already incr'ed ref counts */ + /* T:listrep-1.{1,3} */ memmove(&listObjs[leadSegmentLen + leadShift], insertObjs, numToInsert * sizeof(Tcl_Obj *)); @@ -2431,8 +2472,10 @@ Tcl_ListObjReplace( } else { /* Need a new span record */ if (listRep.storePtr->firstUsed == 0) { + /* T:listrep-1.7 */ listRep.spanPtr = NULL; } else { + /* T:listrep-1.{1,3,6} */ listRep.spanPtr = ListSpanNew(listRep.storePtr->firstUsed, listRep.storePtr->numUsed); } -- cgit v0.12 From a034ecec4fd9513f2d8df0636bdbca1118fc7938 Mon Sep 17 00:00:00 2001 From: apnadkarni Date: Sat, 16 Jul 2022 17:22:11 +0000 Subject: First few list representation tests --- generic/tclListObj.c | 5 + tests/listRep.test | 296 +++++++++++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 301 insertions(+) create mode 100644 tests/listRep.test diff --git a/generic/tclListObj.c b/generic/tclListObj.c index 8f8d0b9..3a3c531 100644 --- a/generic/tclListObj.c +++ b/generic/tclListObj.c @@ -1858,6 +1858,7 @@ Tcl_ListObjAppendList( LIST_ASSERT(listRep.storePtr->numAllocated >= finalLen); if (toLen) { + /* T:listrep-2.2 */ ObjArrayCopy(ListRepSlotPtr(&listRep, 0), toLen, toObjv); } ObjArrayCopy(ListRepSlotPtr(&listRep, toLen), elemCount, elemObjv); @@ -2254,20 +2255,24 @@ Tcl_ListObjReplace( &newRep); toObjs = ListRepSlotPtr(&newRep, 0); if (leadSegmentLen > 0) { + /* T:listrep-2.{2,3} */ ObjArrayCopy(toObjs, leadSegmentLen, listObjs); } if (numToInsert > 0) { + /* T:listrep-2.{1,2,3} */ ObjArrayCopy(&toObjs[leadSegmentLen], numToInsert, insertObjs); } if (tailSegmentLen > 0) { + /* T:listrep-2.{1,2,3} */ ObjArrayCopy(&toObjs[leadSegmentLen + numToInsert], tailSegmentLen, &listObjs[leadSegmentLen+numToDelete]); } newRep.storePtr->numUsed = origListLen + lenChange; if (newRep.spanPtr) { + /* T:listrep-2.{1,2,3} */ newRep.spanPtr->spanLength = newRep.storePtr->numUsed; } LISTREP_CHECK(&newRep); diff --git a/tests/listRep.test b/tests/listRep.test new file mode 100644 index 0000000..654ae5d --- /dev/null +++ b/tests/listRep.test @@ -0,0 +1,296 @@ +# This file contains tests that specifically exercise the internal representation +# of a list. +# +# Copyright © 2022 Ashok P. Nadkarni +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. + +# Unlike the other files related to list commands which for the most part do +# black box testing focusing on functionality, this file does more of white box +# testing to exercise code paths that implement different list representations +# (with spans, leading free space etc., shared/unshared etc.) In addition to +# functional correctness, the tests also check for the expected internal +# representation as that pertains to performance heuristics. Generally speaking, +# combinations of the following need to be tested, +# - free space in front, back, neither, both of list representation +# - shared Tcl_Objs +# - shared internal reps (independent of shared Tcl_Objs) +# - byte-compiled vs non-compiled +# +# Being white box tests, they are sensitive to changes to further optimizations +# and changes in heuristics. That cannot be helped. + +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 + namespace import -force ::tcltest::* +} + +::tcltest::loadTestedCommands + +testConstraint testlistrep [llength [info commands testlistrep]] +interp alias {} describe {} testlistrep describe + +proc irange {first last} { + set l {} + while {$first <= $last} { + lappend l $first + incr first + } + return $l +} +proc leadSpace {l} { + # Returns the leading space in a list store + return [dict get [describe $l] store firstUsed] +} +proc tailSpace {l} { + # Returns the trailing space in a list store + array set rep [describe $l] + dict with rep(store) { + return [expr {$numAllocated - ($firstUsed + $numUsed)}] + } +} +proc allocated {l} { + # Returns the allocated space in a list store + return [dict get [describe $l] store numAllocated] +} +proc repStoreRefCount {l} { + # Returns the ref count for the list store + return [dict get [describe $l] store refCount] +} +proc validate {l} { + # Panics if internal listrep structures are not valid + testlistrep validate $l +} +proc leadSpaceMore {l} { + expr {[leadSpace $l] >= 2*[tailSpace $l]} +} +proc tailSpaceMore {l} { + expr {[tailSpace $l] >= 2*[leadSpace $l]} +} +proc spaceEqual {l} { + # 1 if lead and tail space shared (diff of 1 at most) + set diff [expr {[leadSpace $l] - [tailSpace $l]}] + return [expr {$diff >= -1 && $diff <= 1}] +} +proc hasSpan {l args} { + # Returns 1 if list has a span. If args are specified, they are checked with + # span values (start and length) + array set rep [describe $l] + if {![info exists rep(span)]} { + return 0 + } + if {[llength $args] == 0} { + return 1; # No need to check values + } + lassign $args start len + if {[dict get $rep(span) spanStart] == $start && + [dict get $rep(span) spanLength] == $len} { + return 1 + } + return 0 +} +proc checkListrep {l listLen numAllocated leadSpace tailSpace {refCount 0}} { + # Checks if the internal representation of $l match + # passed arguments. Return "" if yes, else error messages. + array set rep [testlistrep describe $l] + + set rep(leadSpace) [dict get $rep(store) firstUsed] + set rep(numAllocated) [dict get $rep(store) numAllocated] + set rep(tailSpace) [expr { + $rep(numAllocated) - ($rep(leadSpace) + [dict get $rep(store) numUsed]) + }] + set rep(refCount) [dict get $rep(store) refCount] + + if {[info exists rep(span)]} { + set rep(listLen) [dict get $rep(span) spanLength] + } else { + set rep(listLen) [dict get $rep(store) numUsed] + } + + set errors [list] + foreach arg {listLen numAllocated leadSpace tailSpace} { + if {$rep($arg) != [set $arg]} { + lappend errors "$arg in list representation ($rep($arg)) is not expected value ([set $arg])." + } + } + # Check refCount only if caller has specified it as non-0 + if {$refCount && $refCount != $rep(refCount)} { + lappend errors "refCount in list representation ($rep(refCount)) is not expected value ($refCount)." + } + return $errors +} + +proc assertListrep {l listLen numAllocated leadSpace tailSpace {refCount 0}} { + # Like check_listrep but raises error + set errors [checkListrep $l $listLen $numAllocated $leadSpace $tailSpace $refCount] + if {[llength $errors]} { + error [join $errors \n] + } + return +} + +# The default length should be large enough that doubling the allocation will +# clearly distinguish free space allocation difference between front and back. +# (difference in the two should at least be 2 else we cannot tell if front +# or back was favored appropriately) +proc freeSpaceNone {{len 8}} {return [testlistrep new $len 0 0]} +proc freeSpaceLead {{len 8} {lead 3}} {return [testlistrep new $len $lead 0]} +proc freeSpaceTail {{len 8} {tail 3}} {return [testlistrep new $len 0 $tail]} +proc freeSpaceBoth {{len 8} {lead 3} {tail 3}} { + return [testlistrep new $len $lead $tail] +} + +# Just ensure above stubs return what's expected +if {[testConstraint testlistrep]} { + assertListrep [freeSpaceNone] 8 8 0 0 1 + assertListrep [freeSpaceLead] 8 11 3 0 1 + assertListrep [freeSpaceTail] 8 11 0 3 1 + assertListrep [freeSpaceBoth] 8 14 3 3 1 +} + +# Define some variables for some indices because the Tcl compiler will do some +# operations completely in byte code if indices are literals +set zero 0 +set one 1 +set four 4 +set end end + +# +# listrep-1.* tests all operate on unshared lists with no free space + +test listrep-1.1 { + Inserts in front of unshared list with no free space should reallocate with + equal free space at front and back +} -constraints testlistrep -body { + set l [linsert [freeSpaceNone] $zero 99] + validate $l + list $l [spaceEqual $l] +} -result [list {99 0 1 2 3 4 5 6 7} 1] + +test listrep-1.2 { + Inserts at back of unshared list with no free space should allocate all + space at back (essentially old lappend behavior) +} -constraints testlistrep -body { + set l [linsert [freeSpaceNone] $end 99] + validate $l + list $l [leadSpace $l] [tailSpace $l] +} -result [list {0 1 2 3 4 5 6 7 99} 0 9] + +test listrep-1.3 { + Inserts in middle of unshared list with no free space should reallocate with + equal free space at front and back +} -constraints testlistrep -body { + set l [linsert [freeSpaceNone] $four 99] + validate $l + list $l [spaceEqual $l] +} -result [list {0 1 2 3 99 4 5 6 7} 1] + +test listrep-1.4 { + Deletes from front of small unshared list with no free space should + just shift up leaving room at back +} -constraints testlistrep -body { + set l [lreplace [freeSpaceNone] $zero $zero] + validate $l + list $l [leadSpace $l] [tailSpace $l] +} -result [list {1 2 3 4 5 6 7} 0 1] + +test listrep-1.5 { + Deletes from front of large unshared list with no free space should + create a span +} -constraints testlistrep -body { + set l [lreplace [freeSpaceNone 1000] $zero $one] + validate $l + list $l [leadSpace $l] [tailSpace $l] [hasSpan $l 2 998] +} -result [list [irange 2 999] 2 0 1] + +test listrep-1.6 { + Deletes closer to front of large list should move (smaller) front segment +} -constraints testlistrep -body { + set l [lreplace [freeSpaceNone 1000] $four $four] + validate $l + list $l [leadSpace $l] [tailSpace $l] [hasSpan $l 1 999] +} -result [list [concat [irange 0 3] [irange 5 999]] 1 0 1] + +test listrep-1.7 { + Deletes closer to back of large list should move (smaller) back segment + and will not need a span +} -constraints testlistrep -body { + set l [lreplace [freeSpaceNone 1000] end-$four end-$four] + validate $l + list $l [leadSpace $l] [tailSpace $l] [hasSpan $l] +} -result [list [concat [irange 0 994] [irange 996 999]] 0 1 0] + +test listrep-1.8 { + Deletes at back of small unshared list should not need a span +} -constraints testlistrep -body { + set l [lreplace [freeSpaceNone] end-$one end] + validate $l + list $l [leadSpace $l] [tailSpace $l] [hasSpan $l] +} -result [list {0 1 2 3 4 5} 0 2 0] + +test listrep-1.9 { + Deletes at back of large unshared list should not need a span +} -constraints testlistrep -body { + set l [lreplace [freeSpaceNone 1000] end-$four end] + validate $l + list $l [leadSpace $l] [tailSpace $l] [hasSpan $l] +} -result [list [irange 0 994] 0 5 0] + +test listrep-1.10 { + lreplace no-op should force a canonical list representation +} -body { + lreplace { 1 2 3 4 } $zero -1 +} -result {1 2 3 4} + +test listrep-1.11 { + Append elements to large unshared list using lreplace is optimized as lappend + so no free space in front +} -body { + # Note $end, not end else byte code compiler short-cuts + set l [lreplace [freeSpaceNone 1000] $end+1 $end+1 99] + list $l [leadSpace $l] [expr {[tailSpace $l] > 0}] [hasSpan $l] +} -result [list [linsert [irange 0 999] end+1 99] 0 1 0] + +# +# listrep-2.* tests all operate on shared lists with no free space +# The lrange construct on an variable's value will result in a listrep +# that is shared (it's not enough that the Tcl_Obj is shared so just +# assigning to another variable does not suffice) + +test listrep-2.1 { + Inserts in front of shared list with no free space should reallocate with + more leading space in front +} -constraints testlistrep -body { + set a [freeSpaceNone] + set b [lrange $a 0 end] + set l [linsert $b $zero 99] + validate $l + list [repStoreRefCount $b] $l [leadSpaceMore $l] [repStoreRefCount $l] +} -result [list 2 {99 0 1 2 3 4 5 6 7} 1 1] + +test listrep-2.2 { + Inserts at back of shared list with no free space should reallocate with + more leading space in back +} -constraints testlistrep -body { + set a [freeSpaceNone] + set b [lrange $a 0 end] + set l [linsert $b $end 99] + validate $l + list [repStoreRefCount $b] $l [tailSpaceMore $l] [repStoreRefCount $l] +} -result [list 2 {0 1 2 3 4 5 6 7 99} 1 1] + +test listrep-2.3 { + Inserts in middle of shared list with no free space should reallocate with + equal spacing +} -constraints testlistrep -body { + set a [freeSpaceNone] + set b [lrange $a 0 end] + set l [linsert $b $four 99] + validate $l + list [repStoreRefCount $b] $l [spaceEqual $l] [repStoreRefCount $l] +} -result [list 2 {0 1 2 3 99 4 5 6 7} 1 1] + +# +::tcltest::cleanupTests +return -- cgit v0.12 From be522119abc546c0f97b40ce6396cb9b73f35041 Mon Sep 17 00:00:00 2001 From: apnadkarni Date: Sun, 17 Jul 2022 17:00:52 +0000 Subject: Another batch of white box listrep tests --- generic/tclListObj.c | 66 +++++++----- tests/listRep.test | 288 ++++++++++++++++++++++++++++++++++++++++++++++++--- 2 files changed, 312 insertions(+), 42 deletions(-) diff --git a/generic/tclListObj.c b/generic/tclListObj.c index 3a3c531..8419b4e 100644 --- a/generic/tclListObj.c +++ b/generic/tclListObj.c @@ -1447,7 +1447,7 @@ ListRepRange( /* Take the opportunity to garbage collect */ /* TODO - we probably do not need the preserveSrcRep here unlike later */ if (!preserveSrcRep) { - /* T:listrep-1.{4,5,8,9} */ + /* T:listrep-1.{4,5,8,9},2.{4,5,6,7} */ ListRepFreeUnreferenced(srcRepPtr); } @@ -1505,9 +1505,7 @@ ListRepRange( } else if (ListSpanMerited(rangeLen, srcRepPtr->storePtr->numUsed, srcRepPtr->storePtr->numAllocated)) { - /* - * Option 2 - because span would be most efficient - */ + /* Option 2 - because span would be most efficient */ ListSizeT spanStart = ListRepStart(srcRepPtr) + rangeStart; if (!preserveSrcRep && srcRepPtr->spanPtr && srcRepPtr->spanPtr->refCount <= 1) { @@ -1516,7 +1514,8 @@ ListRepRange( srcRepPtr->spanPtr->spanLength = rangeLen; *rangeRepPtr = *srcRepPtr; } else { - /* Span not present or is shared. T:listrep-1.5 */ + /* Span not present or is shared. */ + /* T:listrep-1.5,2.{5,7} */ rangeRepPtr->storePtr = srcRepPtr->storePtr; rangeRepPtr->spanPtr = ListSpanNew(spanStart, rangeLen); } @@ -1527,10 +1526,12 @@ ListRepRange( * is mandated. */ if (!preserveSrcRep) { + /* T:listrep-2.{5,7} */ ListRepFreeUnreferenced(rangeRepPtr); } } else if (preserveSrcRep || ListRepIsShared(srcRepPtr)) { /* Option 3 - span or modification in place not allowed/desired */ + /* T:listrep-2.{4,6} */ ListRepElements(srcRepPtr, numSrcElems, srcElems); /* TODO - allocate extra space? */ ListRepInit(rangeLen, @@ -1858,7 +1859,7 @@ Tcl_ListObjAppendList( LIST_ASSERT(listRep.storePtr->numAllocated >= finalLen); if (toLen) { - /* T:listrep-2.2 */ + /* T:listrep-2.{2,9} */ ObjArrayCopy(ListRepSlotPtr(&listRep, 0), toLen, toObjv); } ObjArrayCopy(ListRepSlotPtr(&listRep, toLen), elemCount, elemObjv); @@ -2129,21 +2130,24 @@ Tcl_ListObjReplace( /* Check Case (1) - Treat pure deletes from front or back as range ops */ if (numToInsert == 0) { if (numToDelete == 0) { - /* Should force canonical even for no-op */ - /* T:listrep-1.10 */ + /* + * Should force canonical even for no-op. Remember Tcl_Obj unshared + * so OK to invalidate string rep + */ + /* T:listrep-1.10,2.8 */ TclInvalidateStringRep(listObj); return TCL_OK; } if (first == 0) { /* Delete from front, so return tail. */ - /* T:listrep-1.{4,5} */ + /* T:listrep-1.{4,5},2.{4,5} */ ListRep tailRep; ListRepRange(&listRep, numToDelete, origListLen-1, 0, &tailRep); ListObjReplaceRepAndInvalidate(listObj, &tailRep); return TCL_OK; } else if ((first+numToDelete) >= origListLen) { /* Delete from tail, so return head */ - /* T:listrep-1.{8,9} */ + /* T:listrep-1.{8,9},2.{6,7} */ ListRep headRep; ListRepRange(&listRep, 0, first-1, 0, &headRep); ListObjReplaceRepAndInvalidate(listObj, &headRep); @@ -2161,7 +2165,7 @@ Tcl_ListObjReplace( if (numToDelete == 0) { /* Case (2a) - Append to list. */ if (first == origListLen) { - /* T:listrep-1.11 */ + /* T:listrep-1.11,2.9 */ return TclListObjAppendElements( interp, listObj, numToInsert, insertObjs); } @@ -2217,7 +2221,7 @@ Tcl_ListObjReplace( * ListObjReplaceAndInvalidate below. */ if (numFreeSlots < lenChange && !ListRepIsShared(&listRep)) { - /* T:listrep-1.{1,3} */ + /* T:listrep-1.{1,3,14,18} */ ListStore *newStorePtr = ListStoreReallocate(listRep.storePtr, origListLen + lenChange); if (newStorePtr == NULL) { @@ -2255,24 +2259,24 @@ Tcl_ListObjReplace( &newRep); toObjs = ListRepSlotPtr(&newRep, 0); if (leadSegmentLen > 0) { - /* T:listrep-2.{2,3} */ + /* T:listrep-2.{2,3,13,14,15} */ ObjArrayCopy(toObjs, leadSegmentLen, listObjs); } if (numToInsert > 0) { - /* T:listrep-2.{1,2,3} */ + /* T:listrep-2.{1,2,3,10,11,12,13,14,15} */ ObjArrayCopy(&toObjs[leadSegmentLen], numToInsert, insertObjs); } if (tailSegmentLen > 0) { - /* T:listrep-2.{1,2,3} */ + /* T:listrep-2.{1,2,3,10,11,12,13,14,15} */ ObjArrayCopy(&toObjs[leadSegmentLen + numToInsert], tailSegmentLen, &listObjs[leadSegmentLen+numToDelete]); } newRep.storePtr->numUsed = origListLen + lenChange; if (newRep.spanPtr) { - /* T:listrep-2.{1,2,3} */ + /* T:listrep-2.{1,2,3,10,11,12,13,14,15} */ newRep.spanPtr->spanLength = newRep.storePtr->numUsed; } LISTREP_CHECK(&newRep); @@ -2305,15 +2309,21 @@ Tcl_ListObjReplace( * for objects to be inserted in case there is overlap. T:listobj-11.1 */ if (numToInsert) { - /* T:listrep-1.{1,3} */ + /* T:listrep-1.{1,3,12,13,14,15,16,17,18} */ ObjArrayIncrRefs(insertObjs, 0, numToInsert); } if (numToDelete) { - /* T:listrep-1.{6,7} */ + /* T:listrep-1.{6,7,12,13,14,15,16,17,18} */ ObjArrayDecrRefs(listObjs, first, numToDelete); } /* + * TODO - below the moves are optimized but this may result in needing a + * span allocation. Perhaps for small lists, it may be more efficient to + * just move everything up front and save on allocating a span. + */ + + /* * Calculate shifts if necessary to accomodate insertions. * NOTE: all indices are relative to listObjs which is not necessarily the * start of the ListStore storage area. @@ -2324,7 +2334,7 @@ Tcl_ListObjReplace( */ if (lenChange == 0) { - /* Exact fit */ + /* T:listrep-1.{12,15}. Exact fit */ leadShift = 0; tailShift = 0; } else if (lenChange < 0) { @@ -2334,12 +2344,12 @@ Tcl_ListObjReplace( */ if (leadSegmentLen > tailSegmentLen) { /* Tail segment smaller. Insert after lead, move tail down */ - /* T:listrep-1.7 */ + /* T:listrep-1.{7,17} */ leadShift = 0; tailShift = lenChange; } else { /* Lead segment smaller. Insert before tail, move lead up */ - /* T:listrep-1.6 */ + /* T:listrep-1.{6,13,16} */ leadShift = -lenChange; tailShift = 0; } @@ -2388,7 +2398,7 @@ Tcl_ListObjReplace( if (finalFreeSpace > 1 && (leadSpace == 0 || leadSegmentLen == 0)) { ListSizeT postShiftTailSpace = tailSpace - lenChange; if (postShiftTailSpace > (finalFreeSpace/2)) { - /* T:listrep-1.{1,3} */ + /* T:listrep-1.{1,3,14,18} */ ListSizeT extraShift = postShiftTailSpace - (finalFreeSpace / 2); tailShift += extraShift; leadShift = extraShift; /* Move head to the back as well */ @@ -2432,14 +2442,14 @@ Tcl_ListObjReplace( if (leadShift > 0) { /* Will happen when we have to make room at bottom */ if (tailShift != 0 && tailSegmentLen != 0) { - /* T:listrep-1.{1,3} */ + /* T:listrep-1.{1,3,14,18} */ ListSizeT tailStart = leadSegmentLen + numToDelete; memmove(&listObjs[tailStart + tailShift], &listObjs[tailStart], tailSegmentLen * sizeof(Tcl_Obj *)); } if (leadSegmentLen != 0) { - /* T:listrep-1.{3,6} */ + /* T:listrep-1.{3,6,16,18} */ memmove(&listObjs[leadShift], &listObjs[0], leadSegmentLen * sizeof(Tcl_Obj *)); @@ -2451,7 +2461,7 @@ Tcl_ListObjReplace( leadSegmentLen * sizeof(Tcl_Obj *)); } if (tailShift != 0 && tailSegmentLen != 0) { - /* T:listrep-1.7 */ + /* T:listrep-1.{7,17} */ ListSizeT tailStart = leadSegmentLen + numToDelete; memmove(&listObjs[tailStart + tailShift], &listObjs[tailStart], @@ -2460,7 +2470,7 @@ Tcl_ListObjReplace( } if (numToInsert) { /* Do NOT use ObjArrayCopy here since we have already incr'ed ref counts */ - /* T:listrep-1.{1,3} */ + /* T:listrep-1.{1,3,12,13,14,15,16,17,18} */ memmove(&listObjs[leadSegmentLen + leadShift], insertObjs, numToInsert * sizeof(Tcl_Obj *)); @@ -2477,10 +2487,10 @@ Tcl_ListObjReplace( } else { /* Need a new span record */ if (listRep.storePtr->firstUsed == 0) { - /* T:listrep-1.7 */ + /* T:listrep-1.{7,12,15,17} */ listRep.spanPtr = NULL; } else { - /* T:listrep-1.{1,3,6} */ + /* T:listrep-1.{1,3,13,14,16,18} */ listRep.spanPtr = ListSpanNew(listRep.storePtr->firstUsed, listRep.storePtr->numUsed); } diff --git a/tests/listRep.test b/tests/listRep.test index 654ae5d..203bb39 100644 --- a/tests/listRep.test +++ b/tests/listRep.test @@ -63,14 +63,22 @@ proc validate {l} { testlistrep validate $l } proc leadSpaceMore {l} { - expr {[leadSpace $l] >= 2*[tailSpace $l]} + set leadSpace [leadSpace $l] + expr {$leadSpace > 0 && $leadSpace >= 2*[tailSpace $l]} } proc tailSpaceMore {l} { - expr {[tailSpace $l] >= 2*[leadSpace $l]} + set tailSpace [tailSpace $l] + expr {$tailSpace > 0 && $tailSpace >= 2*[leadSpace $l]} } proc spaceEqual {l} { - # 1 if lead and tail space shared (diff of 1 at most) - set diff [expr {[leadSpace $l] - [tailSpace $l]}] + # 1 if lead and tail space shared (diff of 1 at most) and more than 0 + set leadSpace [leadSpace $l] + set tailSpace [tailSpace $l] + if {$leadSpace == 0 && $tailSpace == 0} { + # At least one must be positive + return 0 + } + set diff [expr {$leadSpace - $tailSpace}] return [expr {$diff >= -1 && $diff <= 1}] } proc hasSpan {l args} { @@ -153,6 +161,7 @@ if {[testConstraint testlistrep]} { # operations completely in byte code if indices are literals set zero 0 set one 1 +set two 2 set four 4 set end end @@ -238,7 +247,7 @@ test listrep-1.9 { } -result [list [irange 0 994] 0 5 0] test listrep-1.10 { - lreplace no-op should force a canonical list representation + lreplace no-op on unshared list should force a canonical list representation } -body { lreplace { 1 2 3 4 } $zero -1 } -result {1 2 3 4} @@ -248,22 +257,102 @@ test listrep-1.11 { so no free space in front } -body { # Note $end, not end else byte code compiler short-cuts - set l [lreplace [freeSpaceNone 1000] $end+1 $end+1 99] + set l [lreplace [freeSpaceNone 1000] $end+1 $end+1 1000] list $l [leadSpace $l] [expr {[tailSpace $l] > 0}] [hasSpan $l] -} -result [list [linsert [irange 0 999] end+1 99] 0 1 0] +} -result [list [irange 0 1000] 0 1 0] + +test listrep-1.12 { + Replacement of elements at front with same number elements in unshared list + is in-place +} -body { + set l [lreplace [freeSpaceNone] $zero $one 10 11] + list $l [leadSpace $l] [tailSpace $l] +} -result [list {10 11 2 3 4 5 6 7} 0 0] + +test listrep-1.13 { + Replacement of elements at front with fewer elements in unshared list + results in a spanned list with space only in front +} -body { + set l [lreplace [freeSpaceNone] $zero $four 10] + list $l [leadSpace $l] [tailSpace $l] +} -result [list {10 5 6 7} 4 0] + +test listrep-1.14 { + Replacement of elements at front with more elements in unshared list + results in a reallocated spanned list with space at front and back +} -body { + set l [lreplace [freeSpaceNone] $zero $one 10 11 12] + list $l [spaceEqual $l] +} -result [list {10 11 12 2 3 4 5 6 7} 1] + +test listrep-1.15 { + Replacement of elements in middle with same number elements in unshared list + is in-place +} -body { + set l [lreplace [freeSpaceNone] $one $two 10 11] + list $l [leadSpace $l] [tailSpace $l] +} -result [list {0 10 11 3 4 5 6 7} 0 0] + +test listrep-1.16 { + Replacement of elements in front half with fewer elements in unshared list + results in a spanned list with space only in front since smaller segment moved +} -body { + set l [lreplace [freeSpaceNone] $one $four 10] + list $l [leadSpace $l] [tailSpace $l] +} -result [list {0 10 5 6 7} 3 0] + +test listrep-1.17 { + Replacement of elements in back half with fewer elements in unshared list + results in a spanned list with space only at back +} -body { + set l [lreplace [freeSpaceNone] end-$four end-$one 10] + list $l [leadSpace $l] [tailSpace $l] +} -result [list {0 1 2 10 7} 0 3] + +test listrep-1.18 { + Replacement of elements in middle more elements in unshared list + results in a reallocated spanned list with space at front and back +} -body { + set l [lreplace [freeSpaceNone] $one $two 10 11 12] + list $l [spaceEqual $l] +} -result [list {0 10 11 12 3 4 5 6 7} 1] + +test listrep-1.19 { + Replacement of elements at back with same number elements in unshared list + is in-place +} -body { + set l [lreplace [freeSpaceNone] $end-1 $end 10 11] + list $l [leadSpace $l] [tailSpace $l] +} -result [list {0 1 2 3 4 5 10 11} 0 0] + +test listrep-1.20 { + Replacement of elements at back with fewer elements in unshared list + is in-place with space only at the back +} -body { + set l [lreplace [freeSpaceNone] $end-2 $end 10] + list $l [leadSpace $l] [tailSpace $l] +} -result [list {0 1 2 3 4 10} 0 2] + +test listrep-1.21 { + Replacement of elements at back with more elements in unshared list + allocates new representation with equal space at front and back +} -body { + set l [lreplace [freeSpaceNone] $end-1 $end 10 11 12] + list $l [spaceEqual $l] +} -result [list {0 1 2 3 4 5 10 11 12} 1] # -# listrep-2.* tests all operate on shared lists with no free space -# The lrange construct on an variable's value will result in a listrep -# that is shared (it's not enough that the Tcl_Obj is shared so just -# assigning to another variable does not suffice) +# listrep-2.* tests all operate on shared list reps with no free space. Note the +# *list internal rep* must be shared, not only the Tcl_Obj so just assigning to +# another variable does not suffice. The lrange construct on an variable's value +# will do the needful. test listrep-2.1 { Inserts in front of shared list with no free space should reallocate with more leading space in front } -constraints testlistrep -body { set a [freeSpaceNone] - set b [lrange $a 0 end] + set b [lrange $a 0 end]; # Ensure shared listrep set l [linsert $b $zero 99] validate $l list [repStoreRefCount $b] $l [leadSpaceMore $l] [repStoreRefCount $l] @@ -274,7 +363,7 @@ test listrep-2.2 { more leading space in back } -constraints testlistrep -body { set a [freeSpaceNone] - set b [lrange $a 0 end] + set b [lrange $a 0 end]; # Ensure shared listrep set l [linsert $b $end 99] validate $l list [repStoreRefCount $b] $l [tailSpaceMore $l] [repStoreRefCount $l] @@ -285,12 +374,183 @@ test listrep-2.3 { equal spacing } -constraints testlistrep -body { set a [freeSpaceNone] - set b [lrange $a 0 end] + set b [lrange $a 0 end]; # Ensure shared listrep set l [linsert $b $four 99] validate $l list [repStoreRefCount $b] $l [spaceEqual $l] [repStoreRefCount $l] } -result [list 2 {0 1 2 3 99 4 5 6 7} 1 1] +test listrep-2.4 { + Deletes from front of small shared list with no free space should + allocate new list of exact size +} -constraints testlistrep -body { + set a [freeSpaceNone] + set b [lrange $a 0 end]; # Ensure shared listrep + set l [lreplace $b $zero $zero] + validate $l + list [repStoreRefCount $b] $l [leadSpace $l] [tailSpace $l] [repStoreRefCount $l] +} -result [list 2 {1 2 3 4 5 6 7} 0 0 1] + +test listrep-2.5 { + Deletes from front of large shared list with no free space should + create span +} -constraints testlistrep -body { + set a [freeSpaceNone 1000] + set b [lrange $a 0 end]; # Ensure shared listrep + set l [lreplace $b $zero $zero] + validate $l + # The listrep store should be shared among a, b, l (3 refs) + list [repStoreRefCount $b] $l [hasSpan $l] [leadSpace $l] [tailSpace $l] [repStoreRefCount $l] +} -result [list 3 [irange 1 999] 1 0 0 3] + +test listrep-2.6 { + Deletes from back of small shared list with no free space should + allocate new list of exact size +} -constraints testlistrep -body { + set a [freeSpaceNone] + set b [lrange $a 0 end]; # Ensure shared listrep + set l [lreplace $b $end $end] + validate $l + list [repStoreRefCount $b] $l [leadSpace $l] [tailSpace $l] [repStoreRefCount $l] +} -result [list 2 {0 1 2 3 4 5 6} 0 0 1] + +test listrep-2.7 { + Deletes from back of large shared list with no free space should + use a span +} -constraints testlistrep -body { + set a [freeSpaceNone 1000] + set b [lrange $a 0 end]; # Ensure shared listrep + set l [lreplace $b $end $end] + validate $l + # Note lead and tail space is 0 because original list store in a,b is used + list [repStoreRefCount $b] $l [leadSpace $l] [tailSpace $l] [repStoreRefCount $l] +} -result [list 3 [irange 0 998] 0 0 3] + +test listrep-2.8 { + lreplace no-op on shared list should force a canonical list representation + with original unchanged +} -body { + set l { 1 2 3 4 } + list [lreplace $l $zero -1] $l +} -result [list {1 2 3 4} { 1 2 3 4 }] + +test listrep-2.9 { + Appends to back of large shared list with no free space allocates new + list with space only at the back. +} -constraints testlistrep -body { + set a [freeSpaceNone 1000] + set b [lrange $a 0 end]; # Ensure shared listrep + set l [lreplace $b $end+1 $end+1 1000] + validate $l + list [repStoreRefCount $b] $l [leadSpace $l] [expr {[tailSpace $l]>0}] [repStoreRefCount $l] +} -result [list 2 [irange 0 1000] 0 1 1] + +test listrep-2.10 { + Replacement of elements at front with same number elements in shared list + results in a new list store with more space in front than back +} -constraints testlistrep -body { + set a [freeSpaceNone] + set b [lrange $a 0 end]; # Ensure shared listrep + set l [lreplace $b $zero $one 10 11] + validate $l + list [repStoreRefCount $b] $l [leadSpaceMore $l] [repStoreRefCount $l] +} -result [list 2 {10 11 2 3 4 5 6 7} 1 1] + +test listrep-2.11 { + Replacement of elements at front with fewer elements in shared list + results in a new list store with more space in front than back +} -constraints testlistrep -body { + set a [freeSpaceNone] + set b [lrange $a 0 end]; # Ensure shared listrep + set l [lreplace $b $zero $four 10] + validate $l + list [repStoreRefCount $b] $l [leadSpaceMore $l] [repStoreRefCount $l] +} -result [list 2 {10 5 6 7} 1 1] + +test listrep-2.12 { + Replacement of elements at front with more elements in shared list + results in a new spanned list with more space in front +} -constraints testlistrep -body { + set a [freeSpaceNone] + set b [lrange $a 0 end]; # Ensure shared listrep + set l [lreplace $b $zero $one 10 11 12] + validate $l + list [repStoreRefCount $b] $l [leadSpaceMore $l] [repStoreRefCount $l] +} -result [list 2 {10 11 12 2 3 4 5 6 7} 1 1] + +test listrep-2.13 { + Replacement of elements in middle with same number elements in shared list + results in a new list store with equal space in front and back +} -constraints testlistrep -body { + set a [freeSpaceNone] + set b [lrange $a 0 end]; # Ensure shared listrep + set l [lreplace $b $one $two 10 11] + validate $l + list [repStoreRefCount $b] $l [spaceEqual $l] [repStoreRefCount $l] +} -result [list 2 {0 10 11 3 4 5 6 7} 1 1] + +test listrep-2.14 { + Replacement of elements in middle with fewer elements in shared list + results in a new list store with equal space +} -constraints testlistrep -body { + set a [freeSpaceNone] + set b [lrange $a 0 end]; # Ensure shared listrep + set l [lreplace $b $one 5 10] + validate $l + list [repStoreRefCount $b] $l [spaceEqual $l] [repStoreRefCount $l] +} -result [list 2 {0 10 6 7} 1 1] + +test listrep-2.15 { + Replacement of elements in middle with more elements in shared list + results in a new spanned list with space in front and back +} -constraints testlistrep -body { + set a [freeSpaceNone] + set b [lrange $a 0 end]; # Ensure shared listrep + set l [lreplace $b $one $two 10 11 12] + validate $l + list [repStoreRefCount $b] $l [spaceEqual $l] [repStoreRefCount $l] +} -result [list 2 {0 10 11 12 3 4 5 6 7} 1 1] + +test listrep-2.16 { + Replacement of elements at back with same number elements in shared list + results in a new list store with more space in back than front +} -constraints testlistrep -body { + set a [freeSpaceNone] + set b [lrange $a 0 end]; # Ensure shared listrep + set l [lreplace $b end-$one $end 10 11] + validate $l + list [repStoreRefCount $b] $l [tailSpaceMore $l] [repStoreRefCount $l] +} -result [list 2 {0 1 2 3 4 5 10 11} 1 1] + +test listrep-2.17 { + Replacement of elements at back with fewer elements in shared list + results in a new list store with more space in back than front +} -constraints testlistrep -body { + set a [freeSpaceNone] + set b [lrange $a 0 end]; # Ensure shared listrep + set l [lreplace $b end-$four $end 10] + validate $l + list [repStoreRefCount $b] $l [tailSpaceMore $l] [repStoreRefCount $l] +} -result [list 2 {0 1 2 10} 1 1] + +test listrep-2.18 { + Replacement of elements at back with more elements in shared list + results in a new list store with more space in back than front +} -constraints testlistrep -body { + set a [freeSpaceNone] + set b [lrange $a 0 end]; # Ensure shared listrep + set l [lreplace $b end-$four $end 10] + validate $l + list [repStoreRefCount $b] $l [tailSpaceMore $l] [repStoreRefCount $l] +} -result [list 2 {0 1 2 10} 1 1] + + +# TBD - tests on spanned lists +# TBD - tests when tcl-obj is shared but listrep is not (lappend, lset etc.) +# TBD - range and subrange tests +# - spanned and unspanned # +# Special case - nested lremove (does seem tested even in 8.6) + ::tcltest::cleanupTests return -- cgit v0.12 From b0dd51b115eda106d6dd034f4867d446d28f4e1c Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 18 Jul 2022 11:07:59 +0000 Subject: Only use -DBUILD_tcl for shared/static library --- generic/tcl.h | 2 +- unix/Makefile.in | 10 +++++----- 2 files changed, 6 insertions(+), 6 deletions(-) diff --git a/generic/tcl.h b/generic/tcl.h index d99e9fa..ca68eaa 100644 --- a/generic/tcl.h +++ b/generic/tcl.h @@ -2379,7 +2379,7 @@ const char * TclTomMathInitializeStubs(Tcl_Interp *interp, #if defined(_WIN32) TCL_NORETURN void Tcl_ConsolePanic(const char *format, ...); #else -# define Tcl_ConsolePanic ((Tcl_PanicProc *)0) +# define Tcl_ConsolePanic ((Tcl_PanicProc *)NULL) #endif #ifdef USE_TCL_STUBS diff --git a/unix/Makefile.in b/unix/Makefile.in index d0a9d86..28fa446 100644 --- a/unix/Makefile.in +++ b/unix/Makefile.in @@ -176,7 +176,7 @@ NATIVE_TCLSH = @TCLSH_PROG@ STLIB_LD = @STLIB_LD@ SHLIB_LD = @SHLIB_LD@ -SHLIB_CFLAGS = @SHLIB_CFLAGS@ -DBUILD_tcl +SHLIB_CFLAGS = @SHLIB_CFLAGS@ SHLIB_LD_LIBS = @SHLIB_LD_LIBS@ SHLIB_LD_FLAGS = @SHLIB_LD_FLAGS@ TCL_SHLIB_LD_EXTRAS = @TCL_SHLIB_LD_EXTRAS@ @@ -278,12 +278,12 @@ VALGRINDARGS = --tool=memcheck --num-callers=24 \ STUB_CC_SWITCHES = -I"${BUILD_DIR}" -I${UNIX_DIR} -I${GENERIC_DIR} -I${TOMMATH_DIR} \ ${CFLAGS} ${CFLAGS_WARNING} ${SHLIB_CFLAGS} \ - ${AC_FLAGS} ${ENV_FLAGS} ${EXTRA_CFLAGS} \ - @EXTRA_CC_SWITCHES@ + ${AC_FLAGS} ${ENV_FLAGS} ${EXTRA_CFLAGS} @EXTRA_CC_SWITCHES@ \ + ${NO_DEPRECATED_FLAGS} -DMP_FIXED_CUTOFFS -DMP_NO_STDINT -CC_SWITCHES = $(STUB_CC_SWITCHES) ${NO_DEPRECATED_FLAGS} -DMP_FIXED_CUTOFFS -DMP_NO_STDINT +CC_SWITCHES = $(STUB_CC_SWITCHES) -DBUILD_tcl -APP_CC_SWITCHES = $(CC_SWITCHES) @EXTRA_APP_CC_SWITCHES@ +APP_CC_SWITCHES = $(STUB_CC_SWITCHES) @EXTRA_APP_CC_SWITCHES@ LIBS = @TCL_LIBS@ -- cgit v0.12 From 004fe2d35203d7d11d592e8808c83f8a04dfeb31 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 18 Jul 2022 11:56:23 +0000 Subject: Updste stdlib.h (add missing functions). Restructure tclAppInit.c --- compat/stdlib.h | 14 +++++++++----- unix/tclAppInit.c | 10 ++++++---- win/tclAppInit.c | 26 ++++++++++++++------------ 3 files changed, 29 insertions(+), 21 deletions(-) diff --git a/compat/stdlib.h b/compat/stdlib.h index bb0f133..2f7eaf4 100644 --- a/compat/stdlib.h +++ b/compat/stdlib.h @@ -21,14 +21,18 @@ extern void abort(void); extern double atof(const char *string); extern int atoi(const char *string); extern long atol(const char *string); -extern char * calloc(unsigned int numElements, unsigned int size); +extern void * calloc(unsigned long numElements, unsigned long size); extern void exit(int status); -extern int free(char *blockPtr); +extern void free(void *blockPtr); extern char * getenv(const char *name); -extern char * malloc(unsigned int numBytes); -extern void qsort(void *base, int n, int size, int (*compar)( +extern void * malloc(unsigned long numBytes); +extern void qsort(void *base, unsigned long n, unsigned long size, int (*compar)( const void *element1, const void *element2)); -extern char * realloc(char *ptr, unsigned int numBytes); +extern void * realloc(void *ptr, unsigned long numBytes); +extern char * realpath(const char *path, char *resolved_path); +extern int mkstemps(char *templ, int suffixlen); +extern int mkstemp(char *templ); +extern char * mkdtemp(char *templ); extern long strtol(const char *string, char **endPtr, int base); extern unsigned long strtoul(const char *string, char **endPtr, int base); diff --git a/unix/tclAppInit.c b/unix/tclAppInit.c index 3f69f45..51a4cb5 100644 --- a/unix/tclAppInit.c +++ b/unix/tclAppInit.c @@ -12,13 +12,15 @@ * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ -#if defined(BUILD_tcl) || defined(USE_TCL_STUBS) -#error "Don't build with BUILD_tcl/USE_TCL_STUBS!" -#endif #include "tcl.h" -#if TCL_MAJOR_VERSION < 9 && TCL_MINOR_VERSION < 7 +#if TCL_MAJOR_VERSION < 9 +# if defined(BUILD_tcl) || defined(USE_TCL_STUBS) +# error "Don't build with BUILD_tcl/USE_TCL_STUBS!" +# endif +# if TCL_MINOR_VERSION < 7 # define Tcl_LibraryInitProc Tcl_PackageInitProc # define Tcl_StaticLibrary Tcl_StaticPackage +# endif #endif #ifdef TCL_TEST diff --git a/win/tclAppInit.c b/win/tclAppInit.c index 4dd6c6e..53ac274 100644 --- a/win/tclAppInit.c +++ b/win/tclAppInit.c @@ -14,21 +14,15 @@ * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ -#if defined(BUILD_tcl) || defined(USE_TCL_STUBS) -#error "Don't build with BUILD_tcl/USE_TCL_STUBS!" -#endif #include "tcl.h" -#define WIN32_LEAN_AND_MEAN -#define STRICT /* See MSDN Article Q83456 */ -#include -#undef STRICT -#undef WIN32_LEAN_AND_MEAN -#include -#include -#include -#if TCL_MAJOR_VERSION < 9 && TCL_MINOR_VERSION < 7 +#if TCL_MAJOR_VERSION < 9 +# if defined(BUILD_tcl) || defined(USE_TCL_STUBS) +# error "Don't build with BUILD_tcl/USE_TCL_STUBS!" +# endif +# if TCL_MINOR_VERSION < 7 # define Tcl_LibraryInitProc Tcl_PackageInitProc # define Tcl_StaticLibrary Tcl_StaticPackage +# endif #endif #ifdef TCL_TEST @@ -42,6 +36,14 @@ extern Tcl_LibraryInitProc Dde_Init; extern Tcl_LibraryInitProc Dde_SafeInit; #endif +#define WIN32_LEAN_AND_MEAN +#define STRICT /* See MSDN Article Q83456 */ +#include +#undef STRICT +#undef WIN32_LEAN_AND_MEAN +#include +#include +#include #if defined(__GNUC__) || defined(TCL_BROKEN_MAINARGS) int _CRT_glob = 0; #endif /* __GNUC__ || TCL_BROKEN_MAINARGS */ -- cgit v0.12 From d4470195f5fbdfee8e0275b3db694e94078f6a5a Mon Sep 17 00:00:00 2001 From: apnadkarni Date: Mon, 18 Jul 2022 14:20:11 +0000 Subject: Batch of tests for unshared lists with span --- generic/tclListObj.c | 57 +++++++++++++-------- tests/listRep.test | 137 ++++++++++++++++++++++++++++++++++++++++++++++++++- 2 files changed, 172 insertions(+), 22 deletions(-) diff --git a/generic/tclListObj.c b/generic/tclListObj.c index 8419b4e..40e69db 100644 --- a/generic/tclListObj.c +++ b/generic/tclListObj.c @@ -1795,7 +1795,7 @@ Tcl_ListObjAppendList( LIST_ASSERT(toLen == listRep.storePtr->numUsed); if (finalLen > listRep.storePtr->numAllocated) { - /* T:listrep-1.{2,11} */ + /* T:listrep-1.{2,11},3.6 */ ListStore *newStorePtr; newStorePtr = ListStoreReallocate(listRep.storePtr, finalLen); if (newStorePtr == NULL) { @@ -1809,7 +1809,7 @@ Tcl_ListObjAppendList( * different location. Overwrite it to bring it back in sync. */ ListObjStompRep(toObj, &listRep); - } + } /* else T:listrep-3.{4,5} */ LIST_ASSERT(listRep.storePtr->numAllocated >= finalLen); /* Current store big enough */ numTailFree = ListRepNumFreeTail(&listRep); @@ -1817,19 +1817,23 @@ Tcl_ListObjAppendList( >= elemCount); /* Total free */ if (numTailFree < elemCount) { /* Not enough room at back. Move some to front */ + /* T:listrep-3.5 */ ListSizeT shiftCount = elemCount - numTailFree; /* Divide remaining space between front and back */ shiftCount += (listRep.storePtr->numAllocated - finalLen) / 2; LIST_ASSERT(shiftCount <= listRep.storePtr->firstUsed); - if (shiftCount) + if (shiftCount) { + /* T:listrep-3.5 */ ListRepUnsharedShiftDown(&listRep, shiftCount); - } + } + } /* else T:listrep-3.{4,6} */ ObjArrayCopy(&listRep.storePtr->slots[ListRepStart(&listRep) + ListRepLength(&listRep)], elemCount, elemObjv); listRep.storePtr->numUsed = finalLen; if (listRep.spanPtr) { + /* T:listrep-3.{4,5,6} */ LIST_ASSERT(listRep.spanPtr->spanStart == listRep.storePtr->firstUsed); listRep.spanPtr->spanLength = finalLen; @@ -2165,7 +2169,7 @@ Tcl_ListObjReplace( if (numToDelete == 0) { /* Case (2a) - Append to list. */ if (first == origListLen) { - /* T:listrep-1.11,2.9 */ + /* T:listrep-1.11,2.9,3.{5,6} */ return TclListObjAppendElements( interp, listObj, numToInsert, insertObjs); } @@ -2192,6 +2196,7 @@ Tcl_ListObjReplace( newLen = listRep.spanPtr->spanLength + numToInsert; if (listRep.spanPtr && listRep.spanPtr->refCount <= 1) { /* An unshared span record, re-use it */ + /* T:listrep-3.1 */ listRep.spanPtr->spanStart = listRep.storePtr->firstUsed; listRep.spanPtr->spanLength = newLen; } else { @@ -2219,9 +2224,13 @@ Tcl_ListObjReplace( * new allocation below. This avoids expensive ref count manipulation * later by not having to go through the ListRepInit and * ListObjReplaceAndInvalidate below. + * TODO - we could be smarter about the reallocate. Use of realloc + * means all new free space is at the back. Instead, the realloc could + * be an explicit alloc and memmove which would let us redistribute + * free space. */ if (numFreeSlots < lenChange && !ListRepIsShared(&listRep)) { - /* T:listrep-1.{1,3,14,18} */ + /* T:listrep-1.{1,3,14,18,21},3.{3,10,11,14} */ ListStore *newStorePtr = ListStoreReallocate(listRep.storePtr, origListLen + lenChange); if (newStorePtr == NULL) { @@ -2259,11 +2268,11 @@ Tcl_ListObjReplace( &newRep); toObjs = ListRepSlotPtr(&newRep, 0); if (leadSegmentLen > 0) { - /* T:listrep-2.{2,3,13,14,15} */ + /* T:listrep-2.{2,3,13,14,15,16,17,18} */ ObjArrayCopy(toObjs, leadSegmentLen, listObjs); } if (numToInsert > 0) { - /* T:listrep-2.{1,2,3,10,11,12,13,14,15} */ + /* T:listrep-2.{1,2,3,10,11,12,13,14,15,16,17,18} */ ObjArrayCopy(&toObjs[leadSegmentLen], numToInsert, insertObjs); @@ -2276,7 +2285,7 @@ Tcl_ListObjReplace( } newRep.storePtr->numUsed = origListLen + lenChange; if (newRep.spanPtr) { - /* T:listrep-2.{1,2,3,10,11,12,13,14,15} */ + /* T:listrep-2.{1,2,3,10,11,12,13,14,15,16,17,18} */ newRep.spanPtr->spanLength = newRep.storePtr->numUsed; } LISTREP_CHECK(&newRep); @@ -2309,11 +2318,12 @@ Tcl_ListObjReplace( * for objects to be inserted in case there is overlap. T:listobj-11.1 */ if (numToInsert) { - /* T:listrep-1.{1,3,12,13,14,15,16,17,18} */ + /* T:listrep-1.{1,3,12,13,14,15,16,17,18,19,20,21} */ + /* T:listrep-3.{2,3,7,8,9,10,11,12,13,14} */ ObjArrayIncrRefs(insertObjs, 0, numToInsert); } if (numToDelete) { - /* T:listrep-1.{6,7,12,13,14,15,16,17,18} */ + /* T:listrep-1.{6,7,12,13,14,15,16,17,18,19,20,21} */ ObjArrayDecrRefs(listObjs, first, numToDelete); } @@ -2334,7 +2344,7 @@ Tcl_ListObjReplace( */ if (lenChange == 0) { - /* T:listrep-1.{12,15}. Exact fit */ + /* T:listrep-1.{12,15,19}. Exact fit */ leadShift = 0; tailShift = 0; } else if (lenChange < 0) { @@ -2344,7 +2354,7 @@ Tcl_ListObjReplace( */ if (leadSegmentLen > tailSegmentLen) { /* Tail segment smaller. Insert after lead, move tail down */ - /* T:listrep-1.{7,17} */ + /* T:listrep-1.{7,17,20} */ leadShift = 0; tailShift = lenChange; } else { @@ -2386,10 +2396,11 @@ Tcl_ListObjReplace( leadShift -= extraShift; tailShift = -extraShift; /* Move tail to the front as well */ } - } + } /* else T:listrep-3.{7,12} */ LIST_ASSERT(leadShift >= 0 || leadSpace >= -leadShift); } else if (tailSpace >= lenChange) { /* Move only tail segment to the back to make more room. */ + /* T:listrep-3.{8,10,11,14} */ leadShift = 0; tailShift = lenChange; /* @@ -2398,7 +2409,7 @@ Tcl_ListObjReplace( if (finalFreeSpace > 1 && (leadSpace == 0 || leadSegmentLen == 0)) { ListSizeT postShiftTailSpace = tailSpace - lenChange; if (postShiftTailSpace > (finalFreeSpace/2)) { - /* T:listrep-1.{1,3,14,18} */ + /* T:listrep-1.{1,3,14,18,21},3.{2,3} */ ListSizeT extraShift = postShiftTailSpace - (finalFreeSpace / 2); tailShift += extraShift; leadShift = extraShift; /* Move head to the back as well */ @@ -2410,6 +2421,7 @@ Tcl_ListObjReplace( * Both lead and tail need to be shifted to make room. * Divide remaining free space equally between front and back. */ + /* T:listrep-3.{9,13} */ LIST_ASSERT(leadSpace < lenChange); LIST_ASSERT(tailSpace < lenChange); @@ -2442,26 +2454,27 @@ Tcl_ListObjReplace( if (leadShift > 0) { /* Will happen when we have to make room at bottom */ if (tailShift != 0 && tailSegmentLen != 0) { - /* T:listrep-1.{1,3,14,18} */ + /* T:listrep-1.{1,3,14,18},3.{2,3} */ ListSizeT tailStart = leadSegmentLen + numToDelete; memmove(&listObjs[tailStart + tailShift], &listObjs[tailStart], tailSegmentLen * sizeof(Tcl_Obj *)); } if (leadSegmentLen != 0) { - /* T:listrep-1.{3,6,16,18} */ + /* T:listrep-1.{3,6,16,18,21} */ memmove(&listObjs[leadShift], &listObjs[0], leadSegmentLen * sizeof(Tcl_Obj *)); } } else { if (leadShift != 0 && leadSegmentLen != 0) { + /* T:listrep-3.{7,9,12,13} */ memmove(&listObjs[leadShift], &listObjs[0], leadSegmentLen * sizeof(Tcl_Obj *)); } if (tailShift != 0 && tailSegmentLen != 0) { - /* T:listrep-1.{7,17} */ + /* T:listrep-1.{7,17},3.{8,9,10,11,13,14} */ ListSizeT tailStart = leadSegmentLen + numToDelete; memmove(&listObjs[tailStart + tailShift], &listObjs[tailStart], @@ -2470,7 +2483,8 @@ Tcl_ListObjReplace( } if (numToInsert) { /* Do NOT use ObjArrayCopy here since we have already incr'ed ref counts */ - /* T:listrep-1.{1,3,12,13,14,15,16,17,18} */ + /* T:listrep-1.{1,3,12,13,14,15,16,17,18,19,20,21} */ + /* T:listrep-3.{2,3,7,8,9,10,11,12,13,14} */ memmove(&listObjs[leadSegmentLen + leadShift], insertObjs, numToInsert * sizeof(Tcl_Obj *)); @@ -2482,15 +2496,16 @@ Tcl_ListObjReplace( if (listRep.spanPtr && listRep.spanPtr->refCount <= 1) { /* An unshared span record, re-use it, even if not required */ + /* T:listrep-3.{2,3,7,8,9,10,11,12,13,14} */ listRep.spanPtr->spanStart = listRep.storePtr->firstUsed; listRep.spanPtr->spanLength = listRep.storePtr->numUsed; } else { /* Need a new span record */ if (listRep.storePtr->firstUsed == 0) { - /* T:listrep-1.{7,12,15,17} */ + /* T:listrep-1.{7,12,15,17,19,20} */ listRep.spanPtr = NULL; } else { - /* T:listrep-1.{1,3,13,14,16,18} */ + /* T:listrep-1.{1,3,13,14,16,18,21} */ listRep.spanPtr = ListSpanNew(listRep.storePtr->firstUsed, listRep.storePtr->numUsed); } diff --git a/tests/listRep.test b/tests/listRep.test index 203bb39..6f95dc2 100644 --- a/tests/listRep.test +++ b/tests/listRep.test @@ -166,7 +166,15 @@ set four 4 set end end # -# listrep-1.* tests all operate on unshared lists with no free space +# Test sets: +# 1.* - unshared internal rep, no spans, with no free space +# 2.* - shared internal rep, no spans, with no free space +# 3.* - unshared internal rep, spanned +# 4.* - shared internal rep, spanned +# 5.* - shared Tcl_Obj + +# +# listrep-1.* tests all operate on unshared listreps with no free space test listrep-1.1 { Inserts in front of unshared list with no free space should reallocate with @@ -544,6 +552,133 @@ test listrep-2.18 { list [repStoreRefCount $b] $l [tailSpaceMore $l] [repStoreRefCount $l] } -result [list 2 {0 1 2 10} 1 1] +# +# listrep-3.* - tests on unshared spanned listreps + +test listrep-3.1 { + Inserts in front of unshared spanned list with room in front should just + use up the free spots +} -constraints testlistrep -body { + set l [linsert [freeSpaceBoth] $zero -2 -1] + validate $l + list $l [leadSpace $l] [tailSpace $l] [repStoreRefCount $l] +} -result [list [irange -2 7] 1 3 1] + +test listrep-3.2 { + Inserts in front of unshared spanned list with insufficient room in front + but enough total freespace should redistribute free space +} -constraints testlistrep -body { + set l [linsert [freeSpaceBoth 8 1 10] $zero -2 -1] + validate $l + list $l [leadSpace $l] [tailSpace $l] [repStoreRefCount $l] +} -result [list [irange -2 7] 5 4 1] + +test listrep-3.3 { + Inserts in front of unshared spanned list with insufficient total freespace + should reallocate with equal free space +} -constraints testlistrep -body { + set l [linsert [freeSpaceBoth 8 1 1] $zero -3 -2 -1] + validate $l + list $l [leadSpace $l] [tailSpace $l] [repStoreRefCount $l] +} -result [list [irange -3 7] 6 5 1] + +test listrep-3.4 { + Inserts at back of unshared spanned list with room at back should not + reallocate +} -constraints testlistrep -body { + set l [linsert [freeSpaceBoth] $end 8] + validate $l + list $l [leadSpace $l] [tailSpace $l] [repStoreRefCount $l] +} -result [list [irange 0 8] 3 2 1] + +test listrep-3.5 { + Inserts at back of unshared spanned list with insufficient room in back + but enough total freespace should redistribute free space +} -constraints testlistrep -body { + set l [linsert [freeSpaceBoth 8 10 1] $end 8 9] + validate $l + list $l [leadSpace $l] [tailSpace $l] [repStoreRefCount $l] +} -result [list [irange 0 9] 5 4 1] + +test listrep-3.6 { + Inserts in back of unshared spanned list with insufficient total freespace + should reallocate with all *additional* space at back. Note this differs + from the insert in front case because here we can realloc() +} -constraints testlistrep -body { + set l [linsert [freeSpaceBoth 8 1 1] $end 8 9 10] + validate $l + list $l [leadSpace $l] [tailSpace $l] [repStoreRefCount $l] +} -result [list [irange 0 10] 1 10 1] + +test listrep-3.7 { + Inserts in front half of unshared spanned list with room in front should not + reallocate and should move front segment +} -constraints testlistrep -body { + set l [linsert [freeSpaceBoth] $one -2 -1] + validate $l + list $l [leadSpace $l] [tailSpace $l] [repStoreRefCount $l] +} -result [list {0 -2 -1 1 2 3 4 5 6 7} 1 3 1] + +test listrep-3.8 { + Inserts in front half of unshared spanned list with insufficient leading + space but with enough tail space +} -constraints testlistrep -body { + set l [linsert [freeSpaceBoth 8 1 5] $one -2 -1] + validate $l + list $l [leadSpace $l] [tailSpace $l] [repStoreRefCount $l] +} -result [list {0 -2 -1 1 2 3 4 5 6 7} 1 3 1] + +test listrep-3.9 { + Inserts in front half of unshared spanned list with sufficient total free space +} -constraints testlistrep -body { + set l [linsert [freeSpaceBoth 8 2 2] $one -3 -2 -1] + validate $l + list $l [leadSpace $l] [tailSpace $l] [repStoreRefCount $l] +} -result [list {0 -3 -2 -1 1 2 3 4 5 6 7} 0 1 1] + +test listrep-3.10 { + Inserts in front half of unshared spanned list with insufficient total space. + Note use of realloc() means new space will be at the back +} -constraints testlistrep -body { + set l [linsert [freeSpaceBoth 8 1 1] $one -3 -2 -1] + validate $l + list $l [leadSpace $l] [tailSpace $l] [repStoreRefCount $l] +} -result [list {0 -3 -2 -1 1 2 3 4 5 6 7} 1 10 1] + +test listrep-3.11 { + Inserts in back half of unshared spanned list with room in back should not + reallocate and should move back segment +} -constraints testlistrep -body { + set l [linsert [freeSpaceBoth] $end-$one 8 9] + validate $l + list $l [leadSpace $l] [tailSpace $l] [repStoreRefCount $l] +} -result [list {0 1 2 3 4 5 6 8 9 7} 3 1 1] + +test listrep-3.12 { + Inserts in back half of unshared spanned list with insufficient tail + space but with enough leading space +} -constraints testlistrep -body { + set l [linsert [freeSpaceBoth 8 5 1] $end-$one 8 9] + validate $l + list $l [leadSpace $l] [tailSpace $l] [repStoreRefCount $l] +} -result [list {0 1 2 3 4 5 6 8 9 7} 3 1 1] + +test listrep-3.13 { + Inserts in back half of unshared spanned list with sufficient total free space +} -constraints testlistrep -body { + set l [linsert [freeSpaceBoth 8 2 2] $end-$one 8 9 10] + validate $l + list $l [leadSpace $l] [tailSpace $l] [repStoreRefCount $l] +} -result [list {0 1 2 3 4 5 6 8 9 10 7} 0 1 1] + +test listrep-3.14 { + Inserts in back half of unshared spanned list with insufficient total space. + Note use of realloc() means new space will be at the back +} -constraints testlistrep -body { + set l [linsert [freeSpaceBoth 8 1 1] $end-$one 8 9 10] + validate $l + list $l [leadSpace $l] [tailSpace $l] [repStoreRefCount $l] +} -result [list {0 1 2 3 4 5 6 8 9 10 7} 1 10 1] # TBD - tests on spanned lists # TBD - tests when tcl-obj is shared but listrep is not (lappend, lset etc.) -- cgit v0.12 From 34288c7bfbceaa0b797c4332ecd3d42649827c63 Mon Sep 17 00:00:00 2001 From: apnadkarni Date: Mon, 18 Jul 2022 15:23:13 +0000 Subject: Batch of tests for unshared lists with span --- tests/listRep.test | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/tests/listRep.test b/tests/listRep.test index 6f95dc2..5e79e7e 100644 --- a/tests/listRep.test +++ b/tests/listRep.test @@ -680,7 +680,7 @@ test listrep-3.14 { list $l [leadSpace $l] [tailSpace $l] [repStoreRefCount $l] } -result [list {0 1 2 3 4 5 6 8 9 10 7} 1 10 1] -# TBD - tests on spanned lists +# TBD - tests on shared spanned lists # TBD - tests when tcl-obj is shared but listrep is not (lappend, lset etc.) # TBD - range and subrange tests # - spanned and unspanned -- cgit v0.12 From 850b3e24a87d95e1efbabbc401cf1412078e584c Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 19 Jul 2022 08:35:05 +0000 Subject: Make a start converting -1 -> TCL_INDEX_NONE where appropriate --- macosx/tclMacOSXFCmd.c | 12 ++++++------ unix/tclAppInit.c | 10 +++++----- unix/tclLoadDl.c | 10 +++++----- unix/tclLoadDyld.c | 10 +++++----- unix/tclLoadNext.c | 2 +- unix/tclLoadOSF.c | 2 +- unix/tclLoadShl.c | 4 ++-- unix/tclUnixChan.c | 8 +++----- unix/tclUnixFCmd.c | 22 +++++++++++----------- unix/tclUnixFile.c | 28 ++++++++++++++-------------- unix/tclUnixInit.c | 36 ++++++++++++++++++------------------ unix/tclUnixPipe.c | 10 +++++----- unix/tclUnixSock.c | 10 +++++----- win/tclAppInit.c | 6 +++--- win/tclWinFCmd.c | 22 +++++++++++----------- win/tclWinFile.c | 22 +++++++++++----------- win/tclWinInit.c | 10 +++++----- win/tclWinLoad.c | 2 +- win/tclWinPipe.c | 12 ++++++------ win/tclWinSerial.c | 10 +++++----- win/tclWinSock.c | 4 ++-- 21 files changed, 125 insertions(+), 127 deletions(-) diff --git a/macosx/tclMacOSXFCmd.c b/macosx/tclMacOSXFCmd.c index 1717c3c..02e57f1 100644 --- a/macosx/tclMacOSXFCmd.c +++ b/macosx/tclMacOSXFCmd.c @@ -344,8 +344,8 @@ TclMacOSXSetFileAttribute( */ Tcl_DStringInit(&ds); - Tcl_DStringAppend(&ds, native, -1); - Tcl_DStringAppend(&ds, _PATH_RSRCFORKSPEC, -1); + Tcl_DStringAppend(&ds, native, TCL_INDEX_NONE); + Tcl_DStringAppend(&ds, _PATH_RSRCFORKSPEC, TCL_INDEX_NONE); result = truncate(Tcl_DStringValue(&ds), 0); if (result != 0) { @@ -459,11 +459,11 @@ TclMacOSXCopyFileAttributes( */ Tcl_DStringInit(&srcBuf); - Tcl_DStringAppend(&srcBuf, src, -1); - Tcl_DStringAppend(&srcBuf, _PATH_RSRCFORKSPEC, -1); + Tcl_DStringAppend(&srcBuf, src, TCL_INDEX_NONE); + Tcl_DStringAppend(&srcBuf, _PATH_RSRCFORKSPEC, TCL_INDEX_NONE); Tcl_DStringInit(&dstBuf); - Tcl_DStringAppend(&dstBuf, dst, -1); - Tcl_DStringAppend(&dstBuf, _PATH_RSRCFORKSPEC, -1); + Tcl_DStringAppend(&dstBuf, dst, TCL_INDEX_NONE); + Tcl_DStringAppend(&dstBuf, _PATH_RSRCFORKSPEC, TCL_INDEX_NONE); /* * Do the copy. diff --git a/unix/tclAppInit.c b/unix/tclAppInit.c index 552f9e4..29ca4e4 100644 --- a/unix/tclAppInit.c +++ b/unix/tclAppInit.c @@ -88,7 +88,7 @@ main( TclZipfs_AppHook(&argc, &argv); #endif - Tcl_Main(argc, argv, TCL_LOCAL_APPINIT); + Tcl_Main((size_t)argc, argv, TCL_LOCAL_APPINIT); return 0; /* Needed only to prevent compiler warning. */ } @@ -157,11 +157,11 @@ Tcl_AppInit( */ #ifdef DJGPP - (Tcl_ObjSetVar2)(interp, Tcl_NewStringObj("tcl_rcFileName", -1), NULL, - Tcl_NewStringObj("~/tclsh.rc", -1), TCL_GLOBAL_ONLY); + (Tcl_ObjSetVar2)(interp, Tcl_NewStringObj("tcl_rcFileName", TCL_INDEX_NONE), NULL, + Tcl_NewStringObj("~/tclsh.rc", TCL_INDEX_NONE), TCL_GLOBAL_ONLY); #else - (Tcl_ObjSetVar2)(interp, Tcl_NewStringObj("tcl_rcFileName", -1), NULL, - Tcl_NewStringObj("~/.tclshrc", -1), TCL_GLOBAL_ONLY); + (Tcl_ObjSetVar2)(interp, Tcl_NewStringObj("tcl_rcFileName", TCL_INDEX_NONE), NULL, + Tcl_NewStringObj("~/.tclshrc", TCL_INDEX_NONE), TCL_GLOBAL_ONLY); #endif return TCL_OK; diff --git a/unix/tclLoadDl.c b/unix/tclLoadDl.c index 342dff6..5c19ea3 100644 --- a/unix/tclLoadDl.c +++ b/unix/tclLoadDl.c @@ -108,7 +108,7 @@ TclpDlopen( Tcl_DString ds; const char *fileName = Tcl_GetString(pathPtr); - native = Tcl_UtfToExternalDString(NULL, fileName, -1, &ds); + native = Tcl_UtfToExternalDString(NULL, fileName, TCL_INDEX_NONE, &ds); /* * Use (RTLD_NOW|RTLD_LOCAL) as default, see [Bug #3216070] */ @@ -179,12 +179,12 @@ FindSymbol( * the underscore. */ - native = Tcl_UtfToExternalDString(NULL, symbol, -1, &ds); + native = Tcl_UtfToExternalDString(NULL, symbol, TCL_INDEX_NONE, &ds); proc = dlsym(handle, native); /* INTL: Native. */ if (proc == NULL) { Tcl_DStringInit(&newName); TclDStringAppendLiteral(&newName, "_"); - native = Tcl_DStringAppend(&newName, native, -1); + native = Tcl_DStringAppend(&newName, native, TCL_INDEX_NONE); proc = dlsym(handle, native); /* INTL: Native. */ Tcl_DStringFree(&newName); } @@ -194,8 +194,8 @@ FindSymbol( sprintf(buf, "%d", Tcl_DStringLength(&ds)); Tcl_DStringInit(&newName); TclDStringAppendLiteral(&newName, "__Z"); - Tcl_DStringAppend(&newName, buf, -1); - Tcl_DStringAppend(&newName, Tcl_DStringValue(&ds), -1); + Tcl_DStringAppend(&newName, buf, TCL_INDEX_NONE); + Tcl_DStringAppend(&newName, Tcl_DStringValue(&ds), TCL_INDEX_NONE); TclDStringAppendLiteral(&newName, "P10Tcl_Interp"); native = Tcl_DStringValue(&newName); proc = dlsym(handle, native + 1); /* INTL: Native. */ diff --git a/unix/tclLoadDyld.c b/unix/tclLoadDyld.c index 7cd48f2..854d4bd 100644 --- a/unix/tclLoadDyld.c +++ b/unix/tclLoadDyld.c @@ -185,7 +185,7 @@ TclpDlopen( nativePath = (const char *)Tcl_FSGetNativePath(pathPtr); nativeFileName = Tcl_UtfToExternalDString(NULL, Tcl_GetString(pathPtr), - -1, &ds); + TCL_INDEX_NONE, &ds); #if TCL_DYLD_USE_DLFCN /* @@ -296,7 +296,7 @@ TclpDlopen( TclNewObj(errObj); if (errMsg != NULL) { - Tcl_AppendToObj(errObj, errMsg, -1); + Tcl_AppendToObj(errObj, errMsg, TCL_INDEX_NONE); } #if TCL_DYLD_USE_NSMODULE if (objFileImageErrMsg) { @@ -341,7 +341,7 @@ FindSymbol( Tcl_DString ds; const char *native; - native = Tcl_UtfToExternalDString(NULL, symbol, -1, &ds); + native = Tcl_UtfToExternalDString(NULL, symbol, TCL_INDEX_NONE, &ds); if (dyldLoadHandle->dlHandle) { #if TCL_DYLD_USE_DLFCN proc = (Tcl_LibraryInitProc *)dlsym(dyldLoadHandle->dlHandle, native); @@ -360,7 +360,7 @@ FindSymbol( Tcl_DStringInit(&newName); TclDStringAppendLiteral(&newName, "_"); - native = Tcl_DStringAppend(&newName, native, -1); + native = Tcl_DStringAppend(&newName, native, TCL_INDEX_NONE); if (dyldLoadHandle->dyldLibHeader) { nsSymbol = NSLookupSymbolInImage(dyldLoadHandle->dyldLibHeader, native, NSLOOKUPSYMBOLINIMAGE_OPTION_BIND_NOW | @@ -656,7 +656,7 @@ TclpLoadMemory( const char *errorName, *errMsg; NSLinkEditError(&editError, &errorNumber, &errorName, &errMsg); - Tcl_SetObjResult(interp, Tcl_NewStringObj(errMsg, -1)); + Tcl_SetObjResult(interp, Tcl_NewStringObj(errMsg, TCL_INDEX_NONE)); return TCL_ERROR; } diff --git a/unix/tclLoadNext.c b/unix/tclLoadNext.c index 2055210..dc827fc 100644 --- a/unix/tclLoadNext.c +++ b/unix/tclLoadNext.c @@ -83,7 +83,7 @@ TclpDlopen( Tcl_DString ds; - native = Tcl_UtfToExternalDString(NULL, fileName, -1, &ds); + native = Tcl_UtfToExternalDString(NULL, fileName, TCL_INDEX_NONE, &ds); files = {native,NULL}; result = rld_load(errorStream, &header, files, NULL); Tcl_DStringFree(&ds); diff --git a/unix/tclLoadOSF.c b/unix/tclLoadOSF.c index bb58871..03698fa 100644 --- a/unix/tclLoadOSF.c +++ b/unix/tclLoadOSF.c @@ -100,7 +100,7 @@ TclpDlopen( Tcl_DString ds; - native = Tcl_UtfToExternalDString(NULL, fileName, -1, &ds); + native = Tcl_UtfToExternalDString(NULL, fileName, TCL_INDEX_NONE, &ds); lm = (Tcl_LibraryInitProc *) load(native, LDR_NOFLAGS); Tcl_DStringFree(&ds); } diff --git a/unix/tclLoadShl.c b/unix/tclLoadShl.c index 5bf97eb..5cde183 100644 --- a/unix/tclLoadShl.c +++ b/unix/tclLoadShl.c @@ -86,7 +86,7 @@ TclpDlopen( Tcl_DString ds; - native = Tcl_UtfToExternalDString(NULL, fileName, -1, &ds); + native = Tcl_UtfToExternalDString(NULL, fileName, TCL_INDEX_NONE, &ds); handle = shl_load(native, BIND_DEFERRED|BIND_VERBOSE|DYNAMIC_PATH, 0L); Tcl_DStringFree(&ds); } @@ -140,7 +140,7 @@ FindSymbol( (void *) &proc) != 0) { Tcl_DStringInit(&newName); TclDStringAppendLiteral(&newName, "_"); - Tcl_DStringAppend(&newName, symbol, -1); + Tcl_DStringAppend(&newName, symbol, TCL_INDEX_NONE); if (shl_findsym(&handle, Tcl_DStringValue(&newName), (short) TYPE_PROCEDURE, (void *) &proc) != 0) { proc = NULL; diff --git a/unix/tclUnixChan.c b/unix/tclUnixChan.c index 4cb9af0..22e9876 100644 --- a/unix/tclUnixChan.c +++ b/unix/tclUnixChan.c @@ -1860,12 +1860,11 @@ TclpGetDefaultStdChannel( * Some #def's to make the code a little clearer! */ -#define ZERO_OFFSET ((Tcl_SeekOffset) 0) #define ERROR_OFFSET ((Tcl_SeekOffset) -1) switch (type) { case TCL_STDIN: - if ((TclOSseek(0, ZERO_OFFSET, SEEK_CUR) == ERROR_OFFSET) + if ((TclOSseek(0, 0, SEEK_CUR) == ERROR_OFFSET) && (errno == EBADF)) { return NULL; } @@ -1874,7 +1873,7 @@ TclpGetDefaultStdChannel( bufMode = "line"; break; case TCL_STDOUT: - if ((TclOSseek(1, ZERO_OFFSET, SEEK_CUR) == ERROR_OFFSET) + if ((TclOSseek(1, 0, SEEK_CUR) == ERROR_OFFSET) && (errno == EBADF)) { return NULL; } @@ -1883,7 +1882,7 @@ TclpGetDefaultStdChannel( bufMode = "line"; break; case TCL_STDERR: - if ((TclOSseek(2, ZERO_OFFSET, SEEK_CUR) == ERROR_OFFSET) + if ((TclOSseek(2, 0, SEEK_CUR) == ERROR_OFFSET) && (errno == EBADF)) { return NULL; } @@ -1896,7 +1895,6 @@ TclpGetDefaultStdChannel( break; } -#undef ZERO_OFFSET #undef ERROR_OFFSET channel = Tcl_MakeFileChannel(INT2PTR(fd), mode); diff --git a/unix/tclUnixFCmd.c b/unix/tclUnixFCmd.c index a5d6a87..818209d 100644 --- a/unix/tclUnixFCmd.c +++ b/unix/tclUnixFCmd.c @@ -779,7 +779,7 @@ TclpObjCopyDirectory( Tcl_DStringFree(&dstString); if (ret != TCL_OK) { - *errorPtr = Tcl_NewStringObj(Tcl_DStringValue(&ds), -1); + *errorPtr = Tcl_NewStringObj(Tcl_DStringValue(&ds), TCL_INDEX_NONE); Tcl_DStringFree(&ds); Tcl_IncrRefCount(*errorPtr); } @@ -833,7 +833,7 @@ TclpObjRemoveDirectory( Tcl_DStringFree(&pathString); if (ret != TCL_OK) { - *errorPtr = Tcl_NewStringObj(Tcl_DStringValue(&ds), -1); + *errorPtr = Tcl_NewStringObj(Tcl_DStringValue(&ds), TCL_INDEX_NONE); Tcl_DStringFree(&ds); Tcl_IncrRefCount(*errorPtr); } @@ -883,7 +883,7 @@ DoRemoveDirectory( result = TCL_OK; if ((errno != EEXIST) || (recursive == 0)) { if (errorPtr != NULL) { - Tcl_ExternalToUtfDString(NULL, path, -1, errorPtr); + Tcl_ExternalToUtfDString(NULL, path, TCL_INDEX_NONE, errorPtr); } result = TCL_ERROR; } @@ -1015,9 +1015,9 @@ TraverseUnixTree( * Append name after slash, and recurse on the file. */ - Tcl_DStringAppend(sourcePtr, dirEntPtr->d_name, -1); + Tcl_DStringAppend(sourcePtr, dirEntPtr->d_name, TCL_INDEX_NONE); if (targetPtr != NULL) { - Tcl_DStringAppend(targetPtr, dirEntPtr->d_name, -1); + Tcl_DStringAppend(targetPtr, dirEntPtr->d_name, TCL_INDEX_NONE); } result = TraverseUnixTree(traverseProc, sourcePtr, targetPtr, errorPtr, doRewind); @@ -1132,7 +1132,7 @@ TraverseUnixTree( end: if (errfile != NULL) { if (errorPtr != NULL) { - Tcl_ExternalToUtfDString(NULL, errfile, -1, errorPtr); + Tcl_ExternalToUtfDString(NULL, errfile, TCL_INDEX_NONE, errorPtr); } result = TCL_ERROR; } @@ -1368,8 +1368,8 @@ GetGroupAttribute( Tcl_DString ds; const char *utf; - utf = Tcl_ExternalToUtfDString(NULL, groupPtr->gr_name, -1, &ds); - *attributePtrPtr = Tcl_NewStringObj(utf, -1); + utf = Tcl_ExternalToUtfDString(NULL, groupPtr->gr_name, TCL_INDEX_NONE, &ds); + *attributePtrPtr = Tcl_NewStringObj(utf, TCL_INDEX_NONE); Tcl_DStringFree(&ds); } return TCL_OK; @@ -1421,7 +1421,7 @@ GetOwnerAttribute( } else { Tcl_DString ds; - (void) Tcl_ExternalToUtfDString(NULL, pwPtr->pw_name, -1, &ds); + (void) Tcl_ExternalToUtfDString(NULL, pwPtr->pw_name, TCL_INDEX_NONE, &ds); *attributePtrPtr = TclDStringToObj(&ds); } return TCL_OK; @@ -2176,7 +2176,7 @@ TclUnixOpenTemporaryFile( Tcl_UtfToExternalDString(NULL, string, dirObj->length, &templ); } else { Tcl_DStringInit(&templ); - Tcl_DStringAppend(&templ, DefaultTempDir(), -1); /* INTL: native */ + Tcl_DStringAppend(&templ, DefaultTempDir(), TCL_INDEX_NONE); /* INTL: native */ } TclDStringAppendLiteral(&templ, "/"); @@ -2301,7 +2301,7 @@ TclpCreateTemporaryDirectory( Tcl_UtfToExternalDString(NULL, string, dirObj->length, &templ); } else { Tcl_DStringInit(&templ); - Tcl_DStringAppend(&templ, DefaultTempDir(), -1); /* INTL: native */ + Tcl_DStringAppend(&templ, DefaultTempDir(), TCL_INDEX_NONE); /* INTL: native */ } if (Tcl_DStringValue(&templ)[Tcl_DStringLength(&templ) - 1] != '/') { diff --git a/unix/tclUnixFile.c b/unix/tclUnixFile.c index 998614d..d1b656b 100644 --- a/unix/tclUnixFile.c +++ b/unix/tclUnixFile.c @@ -119,7 +119,7 @@ TclpFindExecutable( TclDStringAppendLiteral(&buffer, "/"); } } - name = Tcl_DStringAppend(&buffer, argv0, -1); + name = Tcl_DStringAppend(&buffer, argv0, TCL_INDEX_NONE); /* * INTL: The following calls to access() and stat() should not be @@ -155,9 +155,9 @@ TclpFindExecutable( #endif { encoding = Tcl_GetEncoding(NULL, NULL); - Tcl_ExternalToUtfDString(encoding, name, -1, &utfName); + Tcl_ExternalToUtfDString(encoding, name, TCL_INDEX_NONE, &utfName); TclSetObjNameOfExecutable( - Tcl_NewStringObj(Tcl_DStringValue(&utfName), -1), encoding); + Tcl_NewStringObj(Tcl_DStringValue(&utfName), TCL_INDEX_NONE), encoding); Tcl_DStringFree(&utfName); goto done; } @@ -178,7 +178,7 @@ TclpFindExecutable( } Tcl_DStringInit(&nameString); - Tcl_DStringAppend(&nameString, name, -1); + Tcl_DStringAppend(&nameString, name, TCL_INDEX_NONE); Tcl_DStringFree(&buffer); Tcl_UtfToExternalDString(NULL, Tcl_DStringValue(&cwd), @@ -191,10 +191,10 @@ TclpFindExecutable( Tcl_DStringFree(&nameString); encoding = Tcl_GetEncoding(NULL, NULL); - Tcl_ExternalToUtfDString(encoding, Tcl_DStringValue(&buffer), -1, + Tcl_ExternalToUtfDString(encoding, Tcl_DStringValue(&buffer), TCL_INDEX_NONE, &utfName); TclSetObjNameOfExecutable( - Tcl_NewStringObj(Tcl_DStringValue(&utfName), -1), encoding); + Tcl_NewStringObj(Tcl_DStringValue(&utfName), TCL_INDEX_NONE), encoding); Tcl_DStringFree(&utfName); done: @@ -307,7 +307,7 @@ TclpMatchInDirectory( * Now open the directory for reading and iterate over the contents. */ - native = Tcl_UtfToExternalDString(NULL, dirName, -1, &ds); + native = Tcl_UtfToExternalDString(NULL, dirName, TCL_INDEX_NONE, &ds); if ((TclOSstat(native, &statBuf) != 0) /* INTL: Native. */ || !S_ISDIR(statBuf.st_mode)) { @@ -371,14 +371,14 @@ TclpMatchInDirectory( * and pattern. If so, add the file to the result. */ - utfname = Tcl_ExternalToUtfDString(NULL, entryPtr->d_name, -1, + utfname = Tcl_ExternalToUtfDString(NULL, entryPtr->d_name, TCL_INDEX_NONE, &utfDs); if (Tcl_StringCaseMatch(utfname, pattern, 0)) { int typeOk = 1; if (types != NULL) { Tcl_DStringSetLength(&ds, nativeDirLen); - native = Tcl_DStringAppend(&ds, entryPtr->d_name, -1); + native = Tcl_DStringAppend(&ds, entryPtr->d_name, TCL_INDEX_NONE); matchResult = NativeMatchType(interp, native, entryPtr->d_name, types); typeOk = (matchResult == 1); @@ -598,7 +598,7 @@ TclpGetUserHome( { struct passwd *pwPtr; Tcl_DString ds; - const char *native = Tcl_UtfToExternalDString(NULL, name, -1, &ds); + const char *native = Tcl_UtfToExternalDString(NULL, name, TCL_INDEX_NONE, &ds); pwPtr = TclpGetPwNam(native); /* INTL: Native. */ Tcl_DStringFree(&ds); @@ -606,7 +606,7 @@ TclpGetUserHome( if (pwPtr == NULL) { return NULL; } - Tcl_ExternalToUtfDString(NULL, pwPtr->pw_dir, -1, bufferPtr); + Tcl_ExternalToUtfDString(NULL, pwPtr->pw_dir, TCL_INDEX_NONE, bufferPtr); return Tcl_DStringValue(bufferPtr); } @@ -785,7 +785,7 @@ TclpGetCwd( } return NULL; } - return Tcl_ExternalToUtfDString(NULL, buffer, -1, bufferPtr); + return Tcl_ExternalToUtfDString(NULL, buffer, TCL_INDEX_NONE, bufferPtr); } /* @@ -820,7 +820,7 @@ TclpReadlink( const char *native; Tcl_DString ds; - native = Tcl_UtfToExternalDString(NULL, path, -1, &ds); + native = Tcl_UtfToExternalDString(NULL, path, TCL_INDEX_NONE, &ds); length = readlink(native, link, sizeof(link)); /* INTL: Native. */ Tcl_DStringFree(&ds); @@ -1061,7 +1061,7 @@ TclpNativeToNormalized( { Tcl_DString ds; - Tcl_ExternalToUtfDString(NULL, (const char *) clientData, -1, &ds); + Tcl_ExternalToUtfDString(NULL, (const char *) clientData, TCL_INDEX_NONE, &ds); return TclDStringToObj(&ds); } diff --git a/unix/tclUnixInit.c b/unix/tclUnixInit.c index c480a56..21910e1 100644 --- a/unix/tclUnixInit.c +++ b/unix/tclUnixInit.c @@ -369,13 +369,13 @@ TclpInitPlatform(void) * Make sure, that the standard FDs exist. [Bug 772288] */ - if (TclOSseek(0, (Tcl_SeekOffset) 0, SEEK_CUR) == -1 && errno == EBADF) { + if (TclOSseek(0, 0, SEEK_CUR) == -1 && errno == EBADF) { open("/dev/null", O_RDONLY); } - if (TclOSseek(1, (Tcl_SeekOffset) 0, SEEK_CUR) == -1 && errno == EBADF) { + if (TclOSseek(1, 0, SEEK_CUR) == -1 && errno == EBADF) { open("/dev/null", O_WRONLY); } - if (TclOSseek(2, (Tcl_SeekOffset) 0, SEEK_CUR) == -1 && errno == EBADF) { + if (TclOSseek(2, 0, SEEK_CUR) == -1 && errno == EBADF) { open("/dev/null", O_WRONLY); } @@ -473,7 +473,7 @@ TclpInitLibraryPath( */ str = getenv("TCL_LIBRARY"); /* INTL: Native. */ - Tcl_ExternalToUtfDString(NULL, str, -1, &buffer); + Tcl_ExternalToUtfDString(NULL, str, TCL_INDEX_NONE, &buffer); str = Tcl_DStringValue(&buffer); if ((str != NULL) && (str[0] != '\0')) { @@ -496,7 +496,7 @@ TclpInitLibraryPath( * If TCL_LIBRARY is set, search there. */ - Tcl_ListObjAppendElement(NULL, pathPtr, Tcl_NewStringObj(str, -1)); + Tcl_ListObjAppendElement(NULL, pathPtr, Tcl_NewStringObj(str, TCL_INDEX_NONE)); Tcl_SplitPath(str, &pathc, &pathv); if ((pathc > 0) && (strcasecmp(installLib + 4, pathv[pathc-1]) != 0)) { @@ -537,7 +537,7 @@ TclpInitLibraryPath( str = defaultLibraryDir; } if (str[0] != '\0') { - objPtr = Tcl_NewStringObj(str, -1); + objPtr = Tcl_NewStringObj(str, TCL_INDEX_NONE); Tcl_ListObjAppendElement(NULL, pathPtr, objPtr); } } @@ -635,13 +635,13 @@ Tcl_GetEncodingNameFromEnvironment( */ Tcl_DStringInit(&ds); - encoding = Tcl_DStringAppend(&ds, nl_langinfo(CODESET), -1); + encoding = Tcl_DStringAppend(&ds, nl_langinfo(CODESET), TCL_INDEX_NONE); Tcl_UtfToLower(Tcl_DStringValue(&ds)); knownEncoding = SearchKnownEncodings(encoding); if (knownEncoding != NULL) { - Tcl_DStringAppend(bufPtr, knownEncoding, -1); + Tcl_DStringAppend(bufPtr, knownEncoding, TCL_INDEX_NONE); } else if (NULL != Tcl_GetEncoding(NULL, encoding)) { - Tcl_DStringAppend(bufPtr, encoding, -1); + Tcl_DStringAppend(bufPtr, encoding, TCL_INDEX_NONE); } Tcl_DStringFree(&ds); if (Tcl_DStringLength(bufPtr)) { @@ -673,14 +673,14 @@ Tcl_GetEncodingNameFromEnvironment( Tcl_DStringInit(&ds); p = encoding; - encoding = Tcl_DStringAppend(&ds, p, -1); + encoding = Tcl_DStringAppend(&ds, p, TCL_INDEX_NONE); Tcl_UtfToLower(Tcl_DStringValue(&ds)); knownEncoding = SearchKnownEncodings(encoding); if (knownEncoding != NULL) { - Tcl_DStringAppend(bufPtr, knownEncoding, -1); + Tcl_DStringAppend(bufPtr, knownEncoding, TCL_INDEX_NONE); } else if (NULL != Tcl_GetEncoding(NULL, encoding)) { - Tcl_DStringAppend(bufPtr, encoding, -1); + Tcl_DStringAppend(bufPtr, encoding, TCL_INDEX_NONE); } if (Tcl_DStringLength(bufPtr)) { Tcl_DStringFree(&ds); @@ -701,9 +701,9 @@ Tcl_GetEncodingNameFromEnvironment( if (*p != '\0') { knownEncoding = SearchKnownEncodings(p); if (knownEncoding != NULL) { - Tcl_DStringAppend(bufPtr, knownEncoding, -1); + Tcl_DStringAppend(bufPtr, knownEncoding, TCL_INDEX_NONE); } else if (NULL != Tcl_GetEncoding(NULL, p)) { - Tcl_DStringAppend(bufPtr, p, -1); + Tcl_DStringAppend(bufPtr, p, TCL_INDEX_NONE); } } Tcl_DStringFree(&ds); @@ -711,7 +711,7 @@ Tcl_GetEncodingNameFromEnvironment( return Tcl_DStringValue(bufPtr); } } - return Tcl_DStringAppend(bufPtr, TCL_DEFAULT_ENCODING, -1); + return Tcl_DStringAppend(bufPtr, TCL_DEFAULT_ENCODING, TCL_INDEX_NONE); } /* @@ -901,7 +901,7 @@ TclpSetVariables( unameOK = 1; - native = Tcl_ExternalToUtfDString(NULL, name.sysname, -1, &ds); + native = Tcl_ExternalToUtfDString(NULL, name.sysname, TCL_INDEX_NONE, &ds); Tcl_SetVar2(interp, "tcl_platform", "os", native, TCL_GLOBAL_ONLY); Tcl_DStringFree(&ds); @@ -964,7 +964,7 @@ TclpSetVariables( user = ""; Tcl_DStringInit(&ds); /* ensure cleanliness */ } else { - user = Tcl_ExternalToUtfDString(NULL, pwEnt->pw_name, -1, &ds); + user = Tcl_ExternalToUtfDString(NULL, pwEnt->pw_name, TCL_INDEX_NONE, &ds); } Tcl_SetVar2(interp, "tcl_platform", "user", user, TCL_GLOBAL_ONLY); @@ -1013,7 +1013,7 @@ TclpFindVariable( Tcl_DStringInit(&envString); for (i = 0, env = environ[i]; env != NULL; i++, env = environ[i]) { - p1 = Tcl_ExternalToUtfDString(NULL, env, -1, &envString); + p1 = Tcl_ExternalToUtfDString(NULL, env, TCL_INDEX_NONE, &envString); p2 = name; for (; *p2 == *p1; p1++, p2++) { diff --git a/unix/tclUnixPipe.c b/unix/tclUnixPipe.c index e7199bc..c53360a 100644 --- a/unix/tclUnixPipe.c +++ b/unix/tclUnixPipe.c @@ -141,7 +141,7 @@ TclpOpenFile( const char *native; Tcl_DString ds; - native = Tcl_UtfToExternalDString(NULL, fname, -1, &ds); + native = Tcl_UtfToExternalDString(NULL, fname, TCL_INDEX_NONE, &ds); fd = TclOSopen(native, mode, 0666); /* INTL: Native. */ Tcl_DStringFree(&ds); if (fd != -1) { @@ -153,7 +153,7 @@ TclpOpenFile( */ if ((mode & O_WRONLY) && !(mode & O_APPEND)) { - TclOSseek(fd, (Tcl_SeekOffset) 0, SEEK_END); + TclOSseek(fd, 0, SEEK_END); } /* @@ -198,14 +198,14 @@ TclpCreateTempFile( Tcl_DString dstring; char *native; - native = Tcl_UtfToExternalDString(NULL, contents, -1, &dstring); + native = Tcl_UtfToExternalDString(NULL, contents, TCL_INDEX_NONE, &dstring); if (write(fd, native, Tcl_DStringLength(&dstring)) == -1) { close(fd); Tcl_DStringFree(&dstring); return NULL; } Tcl_DStringFree(&dstring); - TclOSseek(fd, (Tcl_SeekOffset) 0, SEEK_SET); + TclOSseek(fd, 0, SEEK_SET); } return MakeFile(fd); } @@ -436,7 +436,7 @@ TclpCreateProcess( newArgv = (char **)TclStackAlloc(interp, (argc+1) * sizeof(char *)); newArgv[argc] = NULL; for (i = 0; i < argc; i++) { - newArgv[i] = Tcl_UtfToExternalDString(NULL, argv[i], -1, &dsArray[i]); + newArgv[i] = Tcl_UtfToExternalDString(NULL, argv[i], TCL_INDEX_NONE, &dsArray[i]); } #ifdef USE_VFORK diff --git a/unix/tclUnixSock.c b/unix/tclUnixSock.c index 91d84f3..d2068c3 100644 --- a/unix/tclUnixSock.c +++ b/unix/tclUnixSock.c @@ -873,7 +873,7 @@ TcpGetOptionProc( errno = err; } if (errno != 0) { - Tcl_DStringAppend(dsPtr, Tcl_ErrnoMsg(errno), -1); + Tcl_DStringAppend(dsPtr, Tcl_ErrnoMsg(errno), TCL_INDEX_NONE); } return TCL_OK; } @@ -881,7 +881,7 @@ TcpGetOptionProc( if ((len > 1) && (optionName[1] == 'c') && (strncmp(optionName, "-connecting", len) == 0)) { Tcl_DStringAppend(dsPtr, - GOT_BITS(statePtr->flags, TCP_ASYNC_CONNECT) ? "1" : "0", -1); + GOT_BITS(statePtr->flags, TCP_ASYNC_CONNECT) ? "1" : "0", TCL_INDEX_NONE); return TCL_OK; } @@ -1769,13 +1769,13 @@ Tcl_OpenTcpServerEx( return statePtr->channel; } if (interp != NULL) { - Tcl_Obj *errorObj = Tcl_NewStringObj("couldn't open socket: ", -1); + Tcl_Obj *errorObj = Tcl_NewStringObj("couldn't open socket: ", TCL_INDEX_NONE); if (errorMsg == NULL) { errno = my_errno; - Tcl_AppendToObj(errorObj, Tcl_PosixError(interp), -1); + Tcl_AppendToObj(errorObj, Tcl_PosixError(interp), TCL_INDEX_NONE); } else { - Tcl_AppendToObj(errorObj, errorMsg, -1); + Tcl_AppendToObj(errorObj, errorMsg, TCL_INDEX_NONE); } Tcl_SetObjResult(interp, errorObj); } diff --git a/win/tclAppInit.c b/win/tclAppInit.c index be70492..eaa4fb3 100644 --- a/win/tclAppInit.c +++ b/win/tclAppInit.c @@ -136,7 +136,7 @@ _tmain( TclZipfs_AppHook(&argc, &argv); #endif - Tcl_Main(argc, argv, TCL_LOCAL_APPINIT); + Tcl_Main((size_t)argc, argv, TCL_LOCAL_APPINIT); return 0; /* Needed only to prevent compiler warning. */ } @@ -210,8 +210,8 @@ Tcl_AppInit( * user-specific startup file will be run under any conditions. */ - (Tcl_ObjSetVar2)(interp, Tcl_NewStringObj("tcl_rcFileName", -1), NULL, - Tcl_NewStringObj("~/tclshrc.tcl", -1), TCL_GLOBAL_ONLY); + Tcl_ObjSetVar2(interp, Tcl_NewStringObj("tcl_rcFileName", TCL_INDEX_NONE), NULL, + Tcl_NewStringObj("~/tclshrc.tcl", TCL_INDEX_NONE), TCL_GLOBAL_ONLY); return TCL_OK; } diff --git a/win/tclWinFCmd.c b/win/tclWinFCmd.c index 3f6d7f4..2ca041b 100644 --- a/win/tclWinFCmd.c +++ b/win/tclWinFCmd.c @@ -330,8 +330,8 @@ DoRenameFile( Tcl_DStringInit(&srcString); Tcl_DStringInit(&dstString); - src = Tcl_WCharToUtfDString(nativeSrcPath, -1, &srcString); - dst = Tcl_WCharToUtfDString(nativeDstPath, -1, &dstString); + src = Tcl_WCharToUtfDString(nativeSrcPath, TCL_INDEX_NONE, &srcString); + dst = Tcl_WCharToUtfDString(nativeDstPath, TCL_INDEX_NONE, &dstString); /* * Check whether the destination path is actually inside the @@ -929,7 +929,7 @@ TclpObjCopyDirectory( } else if (!strcmp(Tcl_DStringValue(&ds), TclGetString(normDestPtr))) { *errorPtr = destPathPtr; } else { - *errorPtr = Tcl_NewStringObj(Tcl_DStringValue(&ds), -1); + *errorPtr = Tcl_NewStringObj(Tcl_DStringValue(&ds), TCL_INDEX_NONE); } Tcl_DStringFree(&ds); Tcl_IncrRefCount(*errorPtr); @@ -1117,7 +1117,7 @@ DoRemoveJustDirectory( char *p; Tcl_DStringInit(errorPtr); - p = Tcl_WCharToUtfDString(nativePath, -1, errorPtr); + p = Tcl_WCharToUtfDString(nativePath, TCL_INDEX_NONE, errorPtr); for (; *p; ++p) { if (*p == '\\') *p = '/'; } @@ -1332,7 +1332,7 @@ TraverseWinTree( Tcl_WinConvertError(GetLastError()); if (errorPtr != NULL) { Tcl_DStringInit(errorPtr); - Tcl_WCharToUtfDString(nativeErrfile, -1, errorPtr); + Tcl_WCharToUtfDString(nativeErrfile, TCL_INDEX_NONE, errorPtr); } result = TCL_ERROR; } @@ -1398,7 +1398,7 @@ TraversalCopy( if (errorPtr != NULL) { Tcl_DStringInit(errorPtr); - Tcl_WCharToUtfDString(nativeDst, -1, errorPtr); + Tcl_WCharToUtfDString(nativeDst, TCL_INDEX_NONE, errorPtr); } return TCL_ERROR; } @@ -1454,7 +1454,7 @@ TraversalDelete( if (errorPtr != NULL) { Tcl_DStringInit(errorPtr); - Tcl_WCharToUtfDString(nativeSrc, -1, errorPtr); + Tcl_WCharToUtfDString(nativeSrc, TCL_INDEX_NONE, errorPtr); } return TCL_ERROR; } @@ -1712,7 +1712,7 @@ ConvertFileNameFormat( */ Tcl_DStringInit(&dsTemp); - Tcl_WCharToUtfDString(nativeName, -1, &dsTemp); + Tcl_WCharToUtfDString(nativeName, TCL_INDEX_NONE, &dsTemp); Tcl_DStringFree(&ds); /* @@ -1952,14 +1952,14 @@ TclpObjListVolumes(void) buf[0] = (char) ('a' + i); if (GetVolumeInformationA(buf, NULL, 0, NULL, NULL, NULL, NULL, 0) || (GetLastError() == ERROR_NOT_READY)) { - elemPtr = Tcl_NewStringObj(buf, -1); + elemPtr = Tcl_NewStringObj(buf, TCL_INDEX_NONE); Tcl_ListObjAppendElement(NULL, resultPtr, elemPtr); } } } else { for (p = buf; *p != '\0'; p += 4) { p[2] = '/'; - elemPtr = Tcl_NewStringObj(p, -1); + elemPtr = Tcl_NewStringObj(p, TCL_INDEX_NONE); Tcl_ListObjAppendElement(NULL, resultPtr, elemPtr); } } @@ -2078,7 +2078,7 @@ TclpCreateTemporaryDirectory( */ Tcl_DStringInit(&name); - Tcl_WCharToUtfDString((LPCWSTR) Tcl_DStringValue(&base), -1, &name); + Tcl_WCharToUtfDString((LPCWSTR) Tcl_DStringValue(&base), TCL_INDEX_NONE, &name); Tcl_DStringFree(&base); return TclDStringToObj(&name); } diff --git a/win/tclWinFile.c b/win/tclWinFile.c index 4a07f04..56ef8cb 100644 --- a/win/tclWinFile.c +++ b/win/tclWinFile.c @@ -888,7 +888,7 @@ TclpFindExecutable( GetModuleFileNameW(NULL, wName, sizeof(wName)/sizeof(WCHAR)); WideCharToMultiByte(CP_UTF8, 0, wName, -1, name, sizeof(name), NULL, NULL); TclWinNoBackslash(name); - TclSetObjNameOfExecutable(Tcl_NewStringObj(name, -1), NULL); + TclSetObjNameOfExecutable(Tcl_NewStringObj(name, TCL_INDEX_NONE), NULL); } /* @@ -1024,7 +1024,7 @@ TclpMatchInDirectory( * pattern. */ - dirName = Tcl_DStringAppend(&dsOrig, pattern, -1); + dirName = Tcl_DStringAppend(&dsOrig, pattern, TCL_INDEX_NONE); } else { dirName = TclDStringAppendLiteral(&dsOrig, "*.*"); } @@ -1103,7 +1103,7 @@ TclpMatchInDirectory( native = data.cFileName; attr = data.dwFileAttributes; Tcl_DStringInit(&ds); - utfname = Tcl_WCharToUtfDString(native, -1, &ds); + utfname = Tcl_WCharToUtfDString(native, TCL_INDEX_NONE, &ds); if (!matchSpecialDots) { /* @@ -1989,7 +1989,7 @@ TclpGetCwd( native += 2; } Tcl_DStringInit(bufferPtr); - Tcl_WCharToUtfDString(native, -1, bufferPtr); + Tcl_WCharToUtfDString(native, TCL_INDEX_NONE, bufferPtr); /* * Convert to forward slashes for easier use in scripts. @@ -2198,7 +2198,7 @@ NativeDev( GetFullPathNameW(nativePath, MAX_PATH, nativeFullPath, &nativePart); Tcl_DStringInit(&ds); - fullPath = Tcl_WCharToUtfDString(nativeFullPath, -1, &ds); + fullPath = Tcl_WCharToUtfDString(nativeFullPath, TCL_INDEX_NONE, &ds); if ((fullPath[0] == '\\') && (fullPath[1] == '\\')) { const char *p; @@ -2501,7 +2501,7 @@ TclpFilesystemPathType( Tcl_DString ds; Tcl_DStringInit(&ds); - Tcl_WCharToUtfDString(volType, -1, &ds); + Tcl_WCharToUtfDString(volType, TCL_INDEX_NONE, &ds); return TclDStringToObj(&ds); } #undef VOL_BUF_SIZE @@ -2649,7 +2649,7 @@ TclpObjNormalizePath( */ nextCheckpoint = 0; - Tcl_AppendToObj(to, currentPathEndPosition, -1); + Tcl_AppendToObj(to, currentPathEndPosition, TCL_INDEX_NONE); /* * Convert link to forward slashes. @@ -2825,7 +2825,7 @@ TclpObjNormalizePath( tmpPathPtr = Tcl_NewStringObj(Tcl_DStringValue(&ds), nextCheckpoint); - Tcl_AppendToObj(tmpPathPtr, lastValidPathEnd, -1); + Tcl_AppendToObj(tmpPathPtr, lastValidPathEnd, TCL_INDEX_NONE); path = TclGetStringFromObj(tmpPathPtr, &len); Tcl_SetStringObj(pathPtr, path, len); Tcl_DecrRefCount(tmpPathPtr); @@ -2898,7 +2898,7 @@ TclWinVolumeRelativeNormalize( const char *drive = Tcl_GetString(useThisCwd); absolutePath = Tcl_NewStringObj(drive,2); - Tcl_AppendToObj(absolutePath, path, -1); + Tcl_AppendToObj(absolutePath, path, TCL_INDEX_NONE); Tcl_IncrRefCount(absolutePath); /* @@ -2951,7 +2951,7 @@ TclWinVolumeRelativeNormalize( Tcl_AppendToObj(absolutePath, "/", 1); } Tcl_IncrRefCount(absolutePath); - Tcl_AppendToObj(absolutePath, path+2, -1); + Tcl_AppendToObj(absolutePath, path+2, TCL_INDEX_NONE); } *useThisCwdPtr = useThisCwd; return absolutePath; @@ -2988,7 +2988,7 @@ TclpNativeToNormalized( char *copy, *p; Tcl_DStringInit(&ds); - Tcl_WCharToUtfDString((const WCHAR *) clientData, -1, &ds); + Tcl_WCharToUtfDString((const WCHAR *) clientData, TCL_INDEX_NONE, &ds); copy = Tcl_DStringValue(&ds); len = Tcl_DStringLength(&ds); diff --git a/win/tclWinInit.c b/win/tclWinInit.c index 647b870..fdeb0aa 100644 --- a/win/tclWinInit.c +++ b/win/tclWinInit.c @@ -233,7 +233,7 @@ AppendEnvironment( WideCharToMultiByte(CP_UTF8, 0, wBuf, -1, buf, MAX_PATH * 3, NULL, NULL); if (buf[0] != '\0') { - objPtr = Tcl_NewStringObj(buf, -1); + objPtr = Tcl_NewStringObj(buf, TCL_INDEX_NONE); Tcl_ListObjAppendElement(NULL, pathPtr, objPtr); TclWinNoBackslash(buf); @@ -257,7 +257,7 @@ AppendEnvironment( (void) Tcl_JoinPath(pathc, pathv, &ds); objPtr = TclDStringToObj(&ds); } else { - objPtr = Tcl_NewStringObj(buf, -1); + objPtr = Tcl_NewStringObj(buf, TCL_INDEX_NONE); } Tcl_ListObjAppendElement(NULL, pathPtr, objPtr); ckfree(pathv); @@ -517,11 +517,11 @@ TclpSetVariables( if (ptr == NULL) { ptr = Tcl_GetVar2(interp, "env", "HOMEDRIVE", TCL_GLOBAL_ONLY); if (ptr != NULL) { - Tcl_DStringAppend(&ds, ptr, -1); + Tcl_DStringAppend(&ds, ptr, TCL_INDEX_NONE); } ptr = Tcl_GetVar2(interp, "env", "HOMEPATH", TCL_GLOBAL_ONLY); if (ptr != NULL) { - Tcl_DStringAppend(&ds, ptr, -1); + Tcl_DStringAppend(&ds, ptr, TCL_INDEX_NONE); } if (Tcl_DStringLength(&ds) > 0) { Tcl_SetVar2(interp, "env", "HOME", Tcl_DStringValue(&ds), @@ -607,7 +607,7 @@ TclpFindVariable( */ Tcl_DStringInit(&envString); - envUpper = Tcl_WCharToUtfDString(env, -1, &envString); + envUpper = Tcl_WCharToUtfDString(env, TCL_INDEX_NONE, &envString); p1 = strchr(envUpper, '='); if (p1 == NULL) { continue; diff --git a/win/tclWinLoad.c b/win/tclWinLoad.c index 1134e12..2106343 100644 --- a/win/tclWinLoad.c +++ b/win/tclWinLoad.c @@ -220,7 +220,7 @@ FindSymbol( Tcl_DStringInit(&ds); TclDStringAppendLiteral(&ds, "_"); - sym2 = Tcl_DStringAppend(&ds, symbol, -1); + sym2 = Tcl_DStringAppend(&ds, symbol, TCL_INDEX_NONE); proc = (void *)GetProcAddress(hInstance, sym2); Tcl_DStringFree(&ds); } diff --git a/win/tclWinPipe.c b/win/tclWinPipe.c index 29b1c03..4a39e8c 100644 --- a/win/tclWinPipe.c +++ b/win/tclWinPipe.c @@ -679,7 +679,7 @@ TclpCreateTempFile( * Convert the contents from UTF to native encoding */ - native = Tcl_UtfToExternalDString(NULL, contents, -1, &dstring); + native = Tcl_UtfToExternalDString(NULL, contents, TCL_INDEX_NONE, &dstring); toCopy = Tcl_DStringLength(&dstring); for (p = native; toCopy > 0; p++, toCopy--) { @@ -1285,12 +1285,12 @@ ApplicationType( applType = APPL_NONE; Tcl_DStringInit(&nameBuf); - Tcl_DStringAppend(&nameBuf, originalName, -1); + Tcl_DStringAppend(&nameBuf, originalName, TCL_INDEX_NONE); nameLen = Tcl_DStringLength(&nameBuf); for (i = 0; i < (int) (sizeof(extensions) / sizeof(extensions[0])); i++) { Tcl_DStringSetLength(&nameBuf, nameLen); - Tcl_DStringAppend(&nameBuf, extensions[i], -1); + Tcl_DStringAppend(&nameBuf, extensions[i], TCL_INDEX_NONE); Tcl_DStringInit(&ds); nativeName = Tcl_UtfToWCharDString(Tcl_DStringValue(&nameBuf), Tcl_DStringLength(&nameBuf), &ds); @@ -1311,7 +1311,7 @@ ApplicationType( continue; } Tcl_DStringInit(&ds); - strcpy(fullName, Tcl_WCharToUtfDString(nativeFullPath, -1, &ds)); + strcpy(fullName, Tcl_WCharToUtfDString(nativeFullPath, TCL_INDEX_NONE, &ds)); Tcl_DStringFree(&ds); ext = strrchr(fullName, '.'); @@ -1403,7 +1403,7 @@ ApplicationType( GetShortPathNameW(nativeFullPath, nativeFullPath, MAX_PATH); Tcl_DStringInit(&ds); - strcpy(fullName, Tcl_WCharToUtfDString(nativeFullPath, -1, &ds)); + strcpy(fullName, Tcl_WCharToUtfDString(nativeFullPath, TCL_INDEX_NONE, &ds)); Tcl_DStringFree(&ds); } return applType; @@ -1628,7 +1628,7 @@ BuildCommandLine( * Nothing to escape. */ - Tcl_DStringAppend(&ds, arg, -1); + Tcl_DStringAppend(&ds, arg, TCL_INDEX_NONE); } else { start = arg; for (special = arg; *special != '\0'; ) { diff --git a/win/tclWinSerial.c b/win/tclWinSerial.c index 403c9d5..f087d70 100644 --- a/win/tclWinSerial.c +++ b/win/tclWinSerial.c @@ -1678,7 +1678,7 @@ SerialSetOptionProc( goto getStateFailed; } Tcl_DStringInit(&ds); - native = Tcl_UtfToWCharDString(value, -1, &ds); + native = Tcl_UtfToWCharDString(value, TCL_INDEX_NONE, &ds); result = BuildCommDCBW(native, &dcb); Tcl_DStringFree(&ds); @@ -1779,7 +1779,7 @@ SerialSetOptionProc( if (interp != NULL) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "bad value for -xchar: should be a list of" - " two elements with each a single 8-bit character", -1)); + " two elements with each a single 8-bit character", TCL_INDEX_NONE)); Tcl_SetErrorCode(interp, "TCL", "VALUE", "XCHAR", NULL); } ckfree(argv); @@ -1852,7 +1852,7 @@ SerialSetOptionProc( (DWORD) (flag ? SETDTR : CLRDTR))) { if (interp != NULL) { Tcl_SetObjResult(interp, Tcl_NewStringObj( - "can't set DTR signal", -1)); + "can't set DTR signal", TCL_INDEX_NONE)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "FCONFIGURE", "TTY_SIGNAL", NULL); } @@ -1864,7 +1864,7 @@ SerialSetOptionProc( (DWORD) (flag ? SETRTS : CLRRTS))) { if (interp != NULL) { Tcl_SetObjResult(interp, Tcl_NewStringObj( - "can't set RTS signal", -1)); + "can't set RTS signal", TCL_INDEX_NONE)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "FCONFIGURE", "TTY_SIGNAL", NULL); } @@ -1876,7 +1876,7 @@ SerialSetOptionProc( (DWORD) (flag ? SETBREAK : CLRBREAK))) { if (interp != NULL) { Tcl_SetObjResult(interp, Tcl_NewStringObj( - "can't set BREAK signal", -1)); + "can't set BREAK signal", TCL_INDEX_NONE)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "FCONFIGURE", "TTY_SIGNAL", NULL); } diff --git a/win/tclWinSock.c b/win/tclWinSock.c index 60575df..e806423 100644 --- a/win/tclWinSock.c +++ b/win/tclWinSock.c @@ -377,7 +377,7 @@ InitializeHostName( * Convert string from native to UTF then change to lowercase. */ - Tcl_UtfToLower(Tcl_WCharToUtfDString(wbuf, -1, &ds)); + Tcl_UtfToLower(Tcl_WCharToUtfDString(wbuf, TCL_INDEX_NONE, &ds)); } else { if (TclpHasSockets(NULL) == TCL_OK) { @@ -392,7 +392,7 @@ InitializeHostName( Tcl_DStringSetLength(&inDs, 256); if (gethostname(Tcl_DStringValue(&inDs), Tcl_DStringLength(&inDs)) == 0) { - Tcl_ExternalToUtfDString(NULL, Tcl_DStringValue(&inDs), -1, + Tcl_ExternalToUtfDString(NULL, Tcl_DStringValue(&inDs), TCL_INDEX_NONE, &ds); } Tcl_DStringFree(&inDs); -- cgit v0.12 From aefbc875acfc5e238b4d17ec233044a07cf23cca Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 19 Jul 2022 08:38:41 +0000 Subject: Update compat/stdlib.h, prevent conflict with modern signature of those functions. --- compat/stdlib.h | 16 ++++++++++------ 1 file changed, 10 insertions(+), 6 deletions(-) diff --git a/compat/stdlib.h b/compat/stdlib.h index 6900be3..2f7eaf4 100644 --- a/compat/stdlib.h +++ b/compat/stdlib.h @@ -5,7 +5,7 @@ * This file isn't complete in the ANSI-C sense; it only declares things * that are needed by Tcl. This file is needed even on many systems with * their own stdlib.h (e.g. SunOS) because not all stdlib.h files declare - * all the procedures needed here (such as strtod). + * all the procedures needed here (such as strtol/strtoul). * * Copyright (c) 1991 The Regents of the University of California. * Copyright (c) 1994-1998 Sun Microsystems, Inc. @@ -21,14 +21,18 @@ extern void abort(void); extern double atof(const char *string); extern int atoi(const char *string); extern long atol(const char *string); -extern char * calloc(unsigned int numElements, unsigned int size); +extern void * calloc(unsigned long numElements, unsigned long size); extern void exit(int status); -extern int free(char *blockPtr); +extern void free(void *blockPtr); extern char * getenv(const char *name); -extern char * malloc(unsigned int numBytes); -extern void qsort(void *base, int n, int size, int (*compar)( +extern void * malloc(unsigned long numBytes); +extern void qsort(void *base, unsigned long n, unsigned long size, int (*compar)( const void *element1, const void *element2)); -extern char * realloc(char *ptr, unsigned int numBytes); +extern void * realloc(void *ptr, unsigned long numBytes); +extern char * realpath(const char *path, char *resolved_path); +extern int mkstemps(char *templ, int suffixlen); +extern int mkstemp(char *templ); +extern char * mkdtemp(char *templ); extern long strtol(const char *string, char **endPtr, int base); extern unsigned long strtoul(const char *string, char **endPtr, int base); -- cgit v0.12 From 1fc31a71b82cae8f8431f4bdd1e6f8aa925d65ea Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 19 Jul 2022 12:14:21 +0000 Subject: Undo changes in tclDecls.h from previous commit: Tk still needs it --- generic/tclDecls.h | 9 +++++++++ 1 file changed, 9 insertions(+) diff --git a/generic/tclDecls.h b/generic/tclDecls.h index 28696df..b869c97 100644 --- a/generic/tclDecls.h +++ b/generic/tclDecls.h @@ -4069,10 +4069,19 @@ extern const TclStubs *tclStubsPtr; #undef TclUnusedStubEntry #if defined(USE_TCL_STUBS) +# undef Tcl_CreateInterp # undef Tcl_FindExecutable +# undef Tcl_GetStringResult +# undef Tcl_Init # undef Tcl_SetPanicProc # undef Tcl_SetExitProc +# undef Tcl_ObjSetVar2 # undef Tcl_StaticLibrary +# define Tcl_CreateInterp() (tclStubsPtr->tcl_CreateInterp()) +# define Tcl_GetStringResult(interp) (tclStubsPtr->tcl_GetStringResult(interp)) +# 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) -- cgit v0.12 From db9786102c5e3ea4a6f3e6ded69921080bc741c9 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 19 Jul 2022 12:38:33 +0000 Subject: Mark apply-9.1 as "knownBug", since it's failing in a --enable-symbols=mem builds. Still need to be fixed! See [https://github.com/tcltk/tcl/runs/7404340406?check_suite_focus=true] --- tests/apply.test | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/tests/apply.test b/tests/apply.test index e2be172..f1e94b4 100644 --- a/tests/apply.test +++ b/tests/apply.test @@ -257,7 +257,7 @@ test apply-9.1 {leaking internal rep} -setup { lindex $lines 3 3 } set lam [list {} {set a 1}] -} -constraints memory -body { +} -constraints {memory knownBug} -body { set end [getbytes] for {set i 0} {$i < 5} {incr i} { ::apply [lrange $lam 0 end] -- cgit v0.12 From 387ec0ad0a9e786d1bca7053ebd87f1800db9b45 Mon Sep 17 00:00:00 2001 From: apnadkarni Date: Wed, 20 Jul 2022 03:16:16 +0000 Subject: Fixes for listrep-3.15,17. Add tests for spanned intreps --- generic/tclListObj.c | 56 ++++++------ tests/listRep.test | 241 ++++++++++++++++++++++++++++++++++++++++++++++++++- 2 files changed, 269 insertions(+), 28 deletions(-) diff --git a/generic/tclListObj.c b/generic/tclListObj.c index 40e69db..a76760c 100644 --- a/generic/tclListObj.c +++ b/generic/tclListObj.c @@ -1447,7 +1447,7 @@ ListRepRange( /* Take the opportunity to garbage collect */ /* TODO - we probably do not need the preserveSrcRep here unlike later */ if (!preserveSrcRep) { - /* T:listrep-1.{4,5,8,9},2.{4,5,6,7} */ + /* T:listrep-1.{4,5,8,9},2.{4,5,6,7},3.{15,16,17,18} */ ListRepFreeUnreferenced(srcRepPtr); } @@ -1510,6 +1510,7 @@ ListRepRange( if (!preserveSrcRep && srcRepPtr->spanPtr && srcRepPtr->spanPtr->refCount <= 1) { /* If span is not shared reuse it */ + /* T:listrep-3.{16,18} */ srcRepPtr->spanPtr->spanStart = spanStart; srcRepPtr->spanPtr->spanLength = rangeLen; *rangeRepPtr = *srcRepPtr; @@ -1526,7 +1527,7 @@ ListRepRange( * is mandated. */ if (!preserveSrcRep) { - /* T:listrep-2.{5,7} */ + /* T:listrep-2.{5,7},3.{16,18} */ ListRepFreeUnreferenced(rangeRepPtr); } } else if (preserveSrcRep || ListRepIsShared(srcRepPtr)) { @@ -1558,7 +1559,7 @@ ListRepRange( /* Free leading elements outside range */ if (rangeStart != 0) { - /* T:listrep-1.4 */ + /* T:listrep-1.4,3.15 */ ObjArrayDecrRefs(srcElems, 0, rangeStart); } /* Ditto for trailing */ @@ -1566,6 +1567,7 @@ ListRepRange( /* Assert: Because numSrcElems > rangeEnd earlier */ LIST_ASSERT(numAfterRangeEnd >= 0); if (numAfterRangeEnd != 0) { + /* T:listrep-3.17 */ ObjArrayDecrRefs(srcElems, rangeEnd + 1, numAfterRangeEnd); } memmove(&srcRepPtr->storePtr->slots[0], @@ -1576,10 +1578,13 @@ ListRepRange( srcRepPtr->storePtr->numUsed = rangeLen; srcRepPtr->storePtr->flags = 0; if (srcRepPtr->spanPtr) { - ListSpanDecrRefs(srcRepPtr->spanPtr); - srcRepPtr->spanPtr = NULL; + /* In case the source has a span, update it for consistency */ + /* T:listrep-3.{15,17} */ + srcRepPtr->spanPtr->spanStart = srcRepPtr->storePtr->firstUsed; + srcRepPtr->spanPtr->spanLength = srcRepPtr->storePtr->numUsed; } - *rangeRepPtr = *srcRepPtr; /* Note no ref count increments */ + rangeRepPtr->storePtr = srcRepPtr->storePtr; + rangeRepPtr->spanPtr = NULL; } /* TODO - call freezombies here if !preserveSrcRep? */ @@ -2144,14 +2149,14 @@ Tcl_ListObjReplace( } if (first == 0) { /* Delete from front, so return tail. */ - /* T:listrep-1.{4,5},2.{4,5} */ + /* T:listrep-1.{4,5},2.{4,5},3.{15,16} */ ListRep tailRep; ListRepRange(&listRep, numToDelete, origListLen-1, 0, &tailRep); ListObjReplaceRepAndInvalidate(listObj, &tailRep); return TCL_OK; } else if ((first+numToDelete) >= origListLen) { /* Delete from tail, so return head */ - /* T:listrep-1.{8,9},2.{6,7} */ + /* T:listrep-1.{8,9},2.{6,7},3.{17,18} */ ListRep headRep; ListRepRange(&listRep, 0, first-1, 0, &headRep); ListObjReplaceRepAndInvalidate(listObj, &headRep); @@ -2230,7 +2235,7 @@ Tcl_ListObjReplace( * free space. */ if (numFreeSlots < lenChange && !ListRepIsShared(&listRep)) { - /* T:listrep-1.{1,3,14,18,21},3.{3,10,11,14} */ + /* T:listrep-1.{1,3,14,18,21},3.{3,10,11,14,27,32,41} */ ListStore *newStorePtr = ListStoreReallocate(listRep.storePtr, origListLen + lenChange); if (newStorePtr == NULL) { @@ -2318,12 +2323,11 @@ Tcl_ListObjReplace( * for objects to be inserted in case there is overlap. T:listobj-11.1 */ if (numToInsert) { - /* T:listrep-1.{1,3,12,13,14,15,16,17,18,19,20,21} */ - /* T:listrep-3.{2,3,7,8,9,10,11,12,13,14} */ + /* T:listrep-1.{1,3,12:21},3.{2,3,7:14,23:41} */ ObjArrayIncrRefs(insertObjs, 0, numToInsert); } if (numToDelete) { - /* T:listrep-1.{6,7,12,13,14,15,16,17,18,19,20,21} */ + /* T:listrep-1.{6,7,12:21},3.{19:41} */ ObjArrayDecrRefs(listObjs, first, numToDelete); } @@ -2344,7 +2348,7 @@ Tcl_ListObjReplace( */ if (lenChange == 0) { - /* T:listrep-1.{12,15,19}. Exact fit */ + /* T:listrep-1.{12,15,19},3.{23,28,33}. Exact fit */ leadShift = 0; tailShift = 0; } else if (lenChange < 0) { @@ -2354,12 +2358,12 @@ Tcl_ListObjReplace( */ if (leadSegmentLen > tailSegmentLen) { /* Tail segment smaller. Insert after lead, move tail down */ - /* T:listrep-1.{7,17,20} */ + /* T:listrep-1.{7,17,20},3.{21,2229,35} */ leadShift = 0; tailShift = lenChange; } else { /* Lead segment smaller. Insert before tail, move lead up */ - /* T:listrep-1.{6,13,16} */ + /* T:listrep-1.{6,13,16},3.{19,20,24,34} */ leadShift = -lenChange; tailShift = 0; } @@ -2380,6 +2384,7 @@ Tcl_ListObjReplace( if (leadSpace >= lenChange && (leadSegmentLen < tailSegmentLen || tailSpace < lenChange)) { /* Move only lead to the front to make more room */ + /* T:listrep-3.25,36,38, */ leadShift = -lenChange; tailShift = 0; /* @@ -2396,11 +2401,11 @@ Tcl_ListObjReplace( leadShift -= extraShift; tailShift = -extraShift; /* Move tail to the front as well */ } - } /* else T:listrep-3.{7,12} */ + } /* else T:listrep-3.{7,12,25,38} */ LIST_ASSERT(leadShift >= 0 || leadSpace >= -leadShift); } else if (tailSpace >= lenChange) { /* Move only tail segment to the back to make more room. */ - /* T:listrep-3.{8,10,11,14} */ + /* T:listrep-3.{8,10,11,14,26,27,30,32,37,39,41} */ leadShift = 0; tailShift = lenChange; /* @@ -2409,7 +2414,7 @@ Tcl_ListObjReplace( if (finalFreeSpace > 1 && (leadSpace == 0 || leadSegmentLen == 0)) { ListSizeT postShiftTailSpace = tailSpace - lenChange; if (postShiftTailSpace > (finalFreeSpace/2)) { - /* T:listrep-1.{1,3,14,18,21},3.{2,3} */ + /* T:listrep-1.{1,3,14,18,21},3.{2,3,26,27} */ ListSizeT extraShift = postShiftTailSpace - (finalFreeSpace / 2); tailShift += extraShift; leadShift = extraShift; /* Move head to the back as well */ @@ -2421,7 +2426,7 @@ Tcl_ListObjReplace( * Both lead and tail need to be shifted to make room. * Divide remaining free space equally between front and back. */ - /* T:listrep-3.{9,13} */ + /* T:listrep-3.{9,13,31,40} */ LIST_ASSERT(leadSpace < lenChange); LIST_ASSERT(tailSpace < lenChange); @@ -2454,27 +2459,27 @@ Tcl_ListObjReplace( if (leadShift > 0) { /* Will happen when we have to make room at bottom */ if (tailShift != 0 && tailSegmentLen != 0) { - /* T:listrep-1.{1,3,14,18},3.{2,3} */ + /* T:listrep-1.{1,3,14,18},3.{2,3,26,27} */ ListSizeT tailStart = leadSegmentLen + numToDelete; memmove(&listObjs[tailStart + tailShift], &listObjs[tailStart], tailSegmentLen * sizeof(Tcl_Obj *)); } if (leadSegmentLen != 0) { - /* T:listrep-1.{3,6,16,18,21} */ + /* T:listrep-1.{3,6,16,18,21},3.{19,20,34} */ memmove(&listObjs[leadShift], &listObjs[0], leadSegmentLen * sizeof(Tcl_Obj *)); } } else { if (leadShift != 0 && leadSegmentLen != 0) { - /* T:listrep-3.{7,9,12,13} */ + /* T:listrep-3.{7,9,12,13,31,36,38,40} */ memmove(&listObjs[leadShift], &listObjs[0], leadSegmentLen * sizeof(Tcl_Obj *)); } if (tailShift != 0 && tailSegmentLen != 0) { - /* T:listrep-1.{7,17},3.{8,9,10,11,13,14} */ + /* T:listrep-1.{7,17},3.{8:11,13,14,21,22,35,37,39:41} */ ListSizeT tailStart = leadSegmentLen + numToDelete; memmove(&listObjs[tailStart + tailShift], &listObjs[tailStart], @@ -2483,8 +2488,7 @@ Tcl_ListObjReplace( } if (numToInsert) { /* Do NOT use ObjArrayCopy here since we have already incr'ed ref counts */ - /* T:listrep-1.{1,3,12,13,14,15,16,17,18,19,20,21} */ - /* T:listrep-3.{2,3,7,8,9,10,11,12,13,14} */ + /* T:listrep-1.{1,3,12:21},3.{2,3,7:14,23:41} */ memmove(&listObjs[leadSegmentLen + leadShift], insertObjs, numToInsert * sizeof(Tcl_Obj *)); @@ -2496,7 +2500,7 @@ Tcl_ListObjReplace( if (listRep.spanPtr && listRep.spanPtr->refCount <= 1) { /* An unshared span record, re-use it, even if not required */ - /* T:listrep-3.{2,3,7,8,9,10,11,12,13,14} */ + /* T:listrep-3.{2,3,7:14},3.{19:41} */ listRep.spanPtr->spanStart = listRep.storePtr->firstUsed; listRep.spanPtr->spanLength = listRep.storePtr->numUsed; } else { diff --git a/tests/listRep.test b/tests/listRep.test index 5e79e7e..bf5b343 100644 --- a/tests/listRep.test +++ b/tests/listRep.test @@ -557,7 +557,7 @@ test listrep-2.18 { test listrep-3.1 { Inserts in front of unshared spanned list with room in front should just - use up the free spots + shrink the lead space } -constraints testlistrep -body { set l [linsert [freeSpaceBoth] $zero -2 -1] validate $l @@ -680,7 +680,244 @@ test listrep-3.14 { list $l [leadSpace $l] [tailSpace $l] [repStoreRefCount $l] } -result [list {0 1 2 3 4 5 6 8 9 10 7} 1 10 1] -# TBD - tests on shared spanned lists +test listrep-3.15 { + Deletes from front of small unshared span list results in elements + moved up front and span removal +} -constraints testlistrep -body { + set l [lreplace [freeSpaceBoth] $zero $zero] + validate $l + list $l [leadSpace $l] [tailSpace $l] [hasSpan $l] +} -result [list {1 2 3 4 5 6 7} 0 7 0] + +test listrep-3.16 { + Deletes from front of large unshared span list results in another + span +} -constraints testlistrep -body { + set l [lreplace [freeSpaceBoth 1000 10 10] $zero $one] + validate $l + list $l [leadSpace $l] [tailSpace $l] [hasSpan $l 12 998] +} -result [list [irange 2 999] 12 10 1] + +test listrep-3.17 { + Deletes from back of small unshared span list results in new store + without span +} -constraints testlistrep -body { + set l [lreplace [freeSpaceBoth] $end $end] + validate $l + list $l [leadSpace $l] [tailSpace $l] [hasSpan $l] +} -result [list {0 1 2 3 4 5 6} 0 7 0] + +test listrep-3.18 { + Deletes from back of large unshared span list results in another + span +} -constraints testlistrep -body { + set l [lreplace [freeSpaceBoth 1000 10 10] $end-1 $end] + validate $l + list $l [leadSpace $l] [tailSpace $l] [hasSpan $l 10 998] +} -result [list [irange 0 997] 10 12 1] + +test listrep-3.19 { + Deletes from front half of small unshared span list results in + movement of smaller front segment +} -constraints testlistrep -body { + set l [lreplace [freeSpaceBoth] $one $two] + validate $l + list $l [leadSpace $l] [tailSpace $l] [hasSpan $l 5 6] +} -result [list {0 3 4 5 6 7} 5 3 1] + +test listrep-3.20 { + Deletes from front half of large unshared span list results in + movement of smaller front segment +} -constraints testlistrep -body { + set l [lreplace [freeSpaceBoth 1000 10 10] $one $two] + validate $l + list $l [leadSpace $l] [tailSpace $l] [hasSpan $l 12 998] +} -result [list [list 0 {*}[irange 3 999]] 12 10 1] + +test listrep-3.21 { + Deletes from back half of small unshared span list results in + movement of smaller back segment +} -constraints testlistrep -body { + set l [lreplace [freeSpaceBoth] $end-2 $end-1] + validate $l + list $l [leadSpace $l] [tailSpace $l] [hasSpan $l 3 6] +} -result [list {0 1 2 3 4 7} 3 5 1] + +test listrep-3.22 { + Deletes from back half of small unshared span list results in + movement of smaller back segment +} -constraints testlistrep -body { + set l [lreplace [freeSpaceBoth 1000 10 10] $end-2 $end-1] + validate $l + list $l [leadSpace $l] [tailSpace $l] [hasSpan $l 10 998] +} -result [list [list {*}[irange 0 996] 999] 10 12 1] + +test listrep-3.23 { + Replacement of elements at front with same number elements in unshared + spanned list is in-place +} -body { + set l [lreplace [freeSpaceBoth] $zero $one 10 11] + list $l [leadSpace $l] [tailSpace $l] +} -result [list {10 11 2 3 4 5 6 7} 3 3] + +test listrep-3.24 { + Replacement of elements at front with fewer elements in unshared + spanned list expands leading space +} -body { + set l [lreplace [freeSpaceBoth] $zero $four 10] + list $l [leadSpace $l] [tailSpace $l] +} -result [list {10 5 6 7} 7 3] + +test listrep-3.25 { + Replacement of elements at front with more elements in unshared + spanned list with sufficient leading space shrinks leading space +} -body { + set l [lreplace [freeSpaceBoth] $zero $one 10 11 12] + list $l [leadSpace $l] [tailSpace $l] +} -result [list {10 11 12 2 3 4 5 6 7} 2 3] + +test listrep-3.26 { + Replacement of elements at front with more elements in unshared + spanned list with insufficient leading space but sufficient total + free space +} -constraints testlistrep -body { + set l [lreplace [freeSpaceBoth 8 1 10] $zero $one 10 11 12 13] + validate $l + list $l [leadSpace $l] [tailSpace $l] [repStoreRefCount $l] +} -result [list {10 11 12 13 2 3 4 5 6 7} 5 4 1] + +test listrep-3.27 { + Replacement of elements at front in unshared spanned list with insufficient + total freespace should reallocate with equal free space +} -constraints testlistrep -body { + set l [lreplace [freeSpaceBoth 8 1 1] $zero $one 10 11 12 13 14] + validate $l + list $l [leadSpace $l] [tailSpace $l] [repStoreRefCount $l] +} -result [list {10 11 12 13 14 2 3 4 5 6 7} 6 5 1] + +test listrep-3.28 { + Replacement of elements at back with same number of elements in unshared + spanned list is in-place +} -body { + set l [lreplace [freeSpaceBoth] $end-1 $end 10 11] + list $l [leadSpace $l] [tailSpace $l] +} -result [list {0 1 2 3 4 5 10 11} 3 3] + +test listrep-3.29 { + Replacement of elements at back with fewer elements in unshared + spanned list expands tail space +} -body { + set l [lreplace [freeSpaceBoth] $end-2 $end 10] + list $l [leadSpace $l] [tailSpace $l] +} -result [list {0 1 2 3 4 10} 3 5] + +test listrep-3.30 { + Replacement of elements at back with more elements in unshared + spanned list with sufficient tail space shrinks tailspace +} -body { + set l [lreplace [freeSpaceBoth] $end-1 $end 10 11 12] + list $l [leadSpace $l] [tailSpace $l] +} -result [list {0 1 2 3 4 5 10 11 12} 3 2] + +test listrep-3.31 { + Replacement of elements at back with more elements in unshared spanned list + with insufficient tail space but enough total free space moves up the span +} -body { + set l [lreplace [freeSpaceBoth 8 2 2] $end-1 $end 10 11 12 13 14] + list $l [leadSpace $l] [tailSpace $l] +} -result [list {0 1 2 3 4 5 10 11 12 13 14} 0 1] + +test listrep-3.32 { + Replacement of elements at back with more elements in unshared spanned list + with insufficient total space reallocates with more room in the tail because + of realloc() +} -body { + set l [lreplace [freeSpaceBoth 8 1 1] $end-1 $end 10 11 12 13 14] + list $l [leadSpace $l] [tailSpace $l] +} -result [list {0 1 2 3 4 5 10 11 12 13 14} 1 10] + +test listrep-3.33 { + Replacement of elements in the middle in an unshared spanned list with + the same number of elements +} -body { + set l [lreplace [freeSpaceBoth] $two $four 10 11 12] + list $l [leadSpace $l] [tailSpace $l] +} -result [list {0 1 10 11 12 5 6 7} 3 3] + +test listrep-3.34 { + Replacement of elements in an unshared spanned list with fewer elements + in the front half moves the front (smaller) segment +} -body { + set l [lreplace [freeSpaceBoth] $two $four 10 11] + list $l [leadSpace $l] [tailSpace $l] +} -result [list {0 1 10 11 5 6 7} 4 3] + +test listrep-3.35 { + Replacement of elements in an unshared spanned list with fewer elements + in the back half moves the tail (smaller) segment +} -body { + set l [lreplace [freeSpaceBoth] $end-2 $end-1 10] + list $l [leadSpace $l] [tailSpace $l] +} -result [list {0 1 2 3 4 10 7} 3 4] + +test listrep-3.36 { + Replacement of elements in an unshared spanned list with more elements + when both front and back have room should move the smaller segment + (front case) +} -body { + set l [lreplace [freeSpaceBoth] $one $two 8 9 10] + list $l [leadSpace $l] [tailSpace $l] +} -result [list {0 8 9 10 3 4 5 6 7} 2 3] + +test listrep-3.37 { + Replacement of elements in an unshared spanned list with more elements + when both front and back have room should move the smaller segment + (back case) +} -body { + set l [lreplace [freeSpaceBoth] $end-2 $end-1 8 9 10] + list $l [leadSpace $l] [tailSpace $l] +} -result [list {0 1 2 3 4 8 9 10 7} 3 2] + +test listrep-3.38 { + Replacement of elements in an unshared spanned list with more elements + when only front has room +} -body { + set l [lreplace [freeSpaceBoth 8 3 1] $end-1 $end-1 8 9 10] + list $l [leadSpace $l] [tailSpace $l] +} -result [list {0 1 2 3 4 5 8 9 10 7} 1 1] + +test listrep-3.39 { + Replacement of elements in an unshared spanned list with more elements + when only back has room +} -body { + set l [lreplace [freeSpaceBoth 8 1 3] $one $one 8 9 10] + list $l [leadSpace $l] [tailSpace $l] +} -result [list {0 8 9 10 2 3 4 5 6 7} 1 1] + +test listrep-3.40 { + Replacement of elements in an unshared spanned list with more elements + when neither send has enough room by itself +} -body { + set l [lreplace [freeSpaceBoth] $one $one 8 9 10 11 12] + list $l [leadSpace $l] [tailSpace $l] +} -result [list {0 8 9 10 11 12 2 3 4 5 6 7} 1 1] + +test listrep-3.41 { + Replacement of elements in an unshared spanned list with more elements + when there is not enough free space results in new allocation. The back + end has more space because of realloc() +} -body { + set l [lreplace [freeSpaceBoth 8 1 1] $one $one 8 9 10 11 12] + list $l [leadSpace $l] [tailSpace $l] +} -result [list {0 8 9 10 11 12 2 3 4 5 6 7} 1 11] + + + + +# +# 4.* - tests on shared spanned lists + + # TBD - tests when tcl-obj is shared but listrep is not (lappend, lset etc.) # TBD - range and subrange tests # - spanned and unspanned -- cgit v0.12 From 2da45449d7d65cdfffd9e4a055f8f651e17cda66 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 20 Jul 2022 08:32:16 +0000 Subject: Missing "package require tcl::test", this causes test failures on Windows with gcc --- tests/listRep.test | 1 + 1 file changed, 1 insertion(+) diff --git a/tests/listRep.test b/tests/listRep.test index bf5b343..5686597 100644 --- a/tests/listRep.test +++ b/tests/listRep.test @@ -27,6 +27,7 @@ if {"::tcltest" ni [namespace children]} { } ::tcltest::loadTestedCommands +catch [list package require -exact tcl::test [info patchlevel]] testConstraint testlistrep [llength [info commands testlistrep]] interp alias {} describe {} testlistrep describe -- cgit v0.12 From 34a90fef7a0a249dffc99dd44cf2f9bcd0e2b45b Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 20 Jul 2022 16:25:03 +0000 Subject: Wrong escape in encoding.n --- doc/encoding.n | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/doc/encoding.n b/doc/encoding.n index 2277f9d..c1dbf27 100644 --- a/doc/encoding.n +++ b/doc/encoding.n @@ -117,7 +117,7 @@ which is the Hiragana letter HA. 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"] +% set s [\fBencoding convertfrom\fR -failindex i utf-8 "A\exC3"] A % set i 1 @@ -127,7 +127,7 @@ 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"] +% set s [\fBencoding convertto\fR -failindex i utf-8 "A\eu0141"] A % set i 1 -- cgit v0.12 From 57f0eb9556674426578429b0bfe081f563e1ed63 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 21 Jul 2022 14:03:54 +0000 Subject: More TclGetStringFromObj() usage --- generic/tclBasic.c | 34 +++--- generic/tclBinary.c | 22 ++-- generic/tclEnsemble.c | 332 ++++++++++++++++++++++++-------------------------- generic/tclExecute.c | 31 ++--- generic/tclLink.c | 26 ++-- 5 files changed, 219 insertions(+), 226 deletions(-) diff --git a/generic/tclBasic.c b/generic/tclBasic.c index 5f32e7d..a0c5a91 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -1350,11 +1350,11 @@ TclRegisterCommandTypeName( int isNew; hPtr = Tcl_CreateHashEntry(&commandTypeTable, - (void *) implementationProc, &isNew); + implementationProc, &isNew); Tcl_SetHashValue(hPtr, (void *) nameStr); } else { hPtr = Tcl_FindHashEntry(&commandTypeTable, - (void *) implementationProc); + implementationProc); if (hPtr != NULL) { Tcl_DeleteHashEntry(hPtr); } @@ -1865,7 +1865,7 @@ DeleteInterpProc( */ Tcl_MutexLock(&cancelLock); - hPtr = Tcl_FindHashEntry(&cancelTable, (char *) iPtr); + hPtr = Tcl_FindHashEntry(&cancelTable, iPtr); if (hPtr != NULL) { CancelInfo *cancelInfo = (CancelInfo *)Tcl_GetHashValue(hPtr); @@ -4584,7 +4584,7 @@ Tcl_CancelEval( goto done; } - hPtr = Tcl_FindHashEntry(&cancelTable, (char *) interp); + hPtr = Tcl_FindHashEntry(&cancelTable, interp); if (hPtr == NULL) { /* * No CancelInfo record for this interpreter. @@ -5274,8 +5274,8 @@ TEOV_RunEnterTraces( { Interp *iPtr = (Interp *) interp; Command *cmdPtr = *cmdPtrPtr; - int newEpoch, cmdEpoch = cmdPtr->cmdEpoch; - int length, traceCode = TCL_OK; + int length, newEpoch, cmdEpoch = cmdPtr->cmdEpoch; + int traceCode = TCL_OK; const char *command = TclGetStringFromObj(commandPtr, &length); /* @@ -5545,7 +5545,7 @@ TclEvalEx( * TCL_EVAL_GLOBAL was set. */ int allowExceptions = (iPtr->evalFlags & TCL_ALLOW_EXCEPTIONS); int gotParse = 0; - unsigned int i, objectsUsed = 0; + TCL_HASH_TYPE i, objectsUsed = 0; /* These variables keep track of how much * state has been allocated while evaluating * the script, so that it can be freed @@ -5717,7 +5717,7 @@ TclEvalEx( wordStart = tokenPtr->start; lines[objectsUsed] = TclWordKnownAtCompileTime(tokenPtr, NULL) - ? wordLine : TCL_INDEX_NONE; + ? wordLine : -1; if (eeFramePtr->type == TCL_LOCATION_SOURCE) { iPtr->evalFlags |= TCL_EVAL_FILE; @@ -6150,7 +6150,7 @@ TclArgumentRelease( for (i = 1; i < objc; i++) { CFWord *cfwPtr; Tcl_HashEntry *hPtr = - Tcl_FindHashEntry(iPtr->lineLAPtr, (char *) objv[i]); + Tcl_FindHashEntry(iPtr->lineLAPtr, objv[i]); if (!hPtr) { continue; @@ -6202,7 +6202,7 @@ TclArgumentBCEnter( CFWordBC *lastPtr = NULL; Interp *iPtr = (Interp *) interp; Tcl_HashEntry *hePtr = - Tcl_FindHashEntry(iPtr->lineBCPtr, (char *) codePtr); + Tcl_FindHashEntry(iPtr->lineBCPtr, codePtr); if (!hePtr) { return; @@ -6308,7 +6308,7 @@ TclArgumentBCRelease( while (cfwPtr) { CFWordBC *nextPtr = cfwPtr->nextPtr; Tcl_HashEntry *hPtr = - Tcl_FindHashEntry(iPtr->lineLABCPtr, (char *) cfwPtr->obj); + Tcl_FindHashEntry(iPtr->lineLABCPtr, cfwPtr->obj); CFWordBC *xPtr = (CFWordBC *)Tcl_GetHashValue(hPtr); if (xPtr != cfwPtr) { @@ -6373,7 +6373,7 @@ TclArgumentGet( * stack. That is nearest. */ - hPtr = Tcl_FindHashEntry(iPtr->lineLAPtr, (char *) obj); + hPtr = Tcl_FindHashEntry(iPtr->lineLAPtr, obj); if (hPtr) { CFWord *cfwPtr = (CFWord *)Tcl_GetHashValue(hPtr); @@ -6387,7 +6387,7 @@ TclArgumentGet( * that stack. */ - hPtr = Tcl_FindHashEntry(iPtr->lineLABCPtr, (char *) obj); + hPtr = Tcl_FindHashEntry(iPtr->lineLABCPtr, obj); if (hPtr) { CFWordBC *cfwPtr = (CFWordBC *)Tcl_GetHashValue(hPtr); @@ -6430,7 +6430,7 @@ Tcl_Eval( * previous call to Tcl_CreateInterp). */ const char *script) /* Pointer to TCL command to execute. */ { - int code = Tcl_EvalEx(interp, script, -1, 0); + int code = Tcl_EvalEx(interp, script, TCL_INDEX_NONE, 0); /* * For backwards compatibility with old C code that predates the object @@ -7279,10 +7279,11 @@ Tcl_AppendObjToErrorInfo( * pertains. */ Tcl_Obj *objPtr) /* Message to record. */ { - const char *message = TclGetString(objPtr); + int length; + const char *message = TclGetStringFromObj(objPtr, &length); Tcl_IncrRefCount(objPtr); - Tcl_AddObjErrorInfo(interp, message, objPtr->length); + Tcl_AddObjErrorInfo(interp, message, length); Tcl_DecrRefCount(objPtr); } @@ -7454,6 +7455,7 @@ Tcl_VarEvalVA( * *---------------------------------------------------------------------- */ + int Tcl_VarEval( Tcl_Interp *interp, diff --git a/generic/tclBinary.c b/generic/tclBinary.c index bf40924..8b974c1 100644 --- a/generic/tclBinary.c +++ b/generic/tclBinary.c @@ -649,7 +649,7 @@ SetByteArrayFromAny( TCL_UNUSED(Tcl_Interp *), Tcl_Obj *objPtr) /* The object to convert to type ByteArray. */ { - size_t length, bad; + int length, bad; const char *src, *srcEnd; unsigned char *dst; Tcl_UniChar ch = 0; @@ -663,8 +663,8 @@ SetByteArrayFromAny( return TCL_OK; } - src = TclGetString(objPtr); - length = bad = objPtr->length; + src = TclGetStringFromObj(objPtr, &length); + bad = length; srcEnd = src + length; /* Note the allocation is over-sized, possibly by a factor of four, @@ -1001,7 +1001,7 @@ TclInitBinaryCmd( static int BinaryFormatCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ @@ -1506,7 +1506,7 @@ BinaryFormatCmd( static int BinaryScanCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ @@ -2583,7 +2583,7 @@ DeleteScanNumberCache( static int BinaryEncodeHex( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) @@ -2627,7 +2627,7 @@ BinaryEncodeHex( static int BinaryDecodeHex( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) @@ -2751,7 +2751,7 @@ BinaryDecodeHex( static int BinaryEncode64( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) @@ -2873,7 +2873,7 @@ BinaryEncode64( static int BinaryEncodeUu( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) @@ -3022,7 +3022,7 @@ BinaryEncodeUu( static int BinaryDecodeUu( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) @@ -3195,7 +3195,7 @@ BinaryDecodeUu( static int BinaryDecode64( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) diff --git a/generic/tclEnsemble.c b/generic/tclEnsemble.c index 5c30a0b..7a295ba 100644 --- a/generic/tclEnsemble.c +++ b/generic/tclEnsemble.c @@ -21,12 +21,12 @@ static inline Tcl_Obj * NewNsObj(Tcl_Namespace *namespacePtr); static inline int EnsembleUnknownCallback(Tcl_Interp *interp, EnsembleConfig *ensemblePtr, int objc, Tcl_Obj *const objv[], Tcl_Obj **prefixObjPtr); -static int NsEnsembleImplementationCmdNR(ClientData clientData, +static int NsEnsembleImplementationCmdNR(void *clientData, Tcl_Interp *interp,int objc,Tcl_Obj *const objv[]); static void BuildEnsembleConfig(EnsembleConfig *ensemblePtr); static int NsEnsembleStringOrder(const void *strPtr1, const void *strPtr2); -static void DeleteEnsembleConfig(ClientData clientData); +static void DeleteEnsembleConfig(void *clientData); static void MakeCachedEnsembleCommand(Tcl_Obj *objPtr, EnsembleConfig *ensemblePtr, Tcl_HashEntry *hPtr, Tcl_Obj *fix); @@ -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. */ @@ -151,7 +151,7 @@ NewNsObj( int TclNamespaceEnsembleCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) @@ -163,7 +163,8 @@ TclNamespaceEnsembleCmd( Tcl_DictSearch search; Tcl_Obj *listObj; const char *simpleName; - int index, done; + int index; + int done; if (nsPtr == NULL || nsPtr->flags & NS_DEAD) { if (!Tcl_InterpDeleted(interp)) { @@ -187,7 +188,8 @@ TclNamespaceEnsembleCmd( switch ((enum EnsSubcmds) index) { case ENS_CREATE: { const char *name; - int len, allocatedMapFlag = 0; + int len; + int allocatedMapFlag = 0; /* * Defaults */ @@ -498,7 +500,8 @@ TclNamespaceEnsembleCmd( Tcl_SetObjResult(interp, resultObj); } else { - int len, allocatedMapFlag = 0; + int 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 */ @@ -940,7 +943,8 @@ Tcl_SetEnsembleMappingDict( return TCL_ERROR; } if (mapDict != NULL) { - int size, done; + int size; + int done; Tcl_DictSearch search; Tcl_Obj *valuePtr; @@ -1523,7 +1527,8 @@ TclMakeEnsemble( Tcl_DString buf, hiddenBuf; const char **nameParts = NULL; const char *cmdName = NULL; - int i, nameCount = 0, ensembleFlags = 0, hiddenLen; + int i, nameCount = 0; + int ensembleFlags = 0, hiddenLen; /* * Construct the path for the ensemble namespace and create it. @@ -1674,7 +1679,7 @@ TclMakeEnsemble( int TclEnsembleImplementationCmd( - ClientData clientData, + void *clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) @@ -1685,7 +1690,7 @@ TclEnsembleImplementationCmd( static int NsEnsembleImplementationCmdNR( - ClientData clientData, + void *clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) @@ -1704,7 +1709,7 @@ NsEnsembleImplementationCmdNR( int 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 +1717,7 @@ NsEnsembleImplementationCmdNR( subIdx = 1 + ensemblePtr->numParameters; if (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 +1749,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 +1780,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 +1789,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. */ int stringLength, i; int tableLength = ensemblePtr->subcommandTable.numEntries; @@ -1820,10 +1822,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 +1833,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 +1842,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 +1872,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 +1907,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 +1930,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 +1948,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); @@ -1987,7 +1985,7 @@ NsEnsembleImplementationCmdNR( int TclClearRootEnsemble( - TCL_UNUSED(ClientData *), + TCL_UNUSED(void **), Tcl_Interp *interp, int result) { @@ -2000,8 +1998,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 +2077,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: @@ -2093,7 +2091,7 @@ TclResetRewriteEnsemble( static int FreeER( - ClientData data[], + void *data[], TCL_UNUSED(Tcl_Interp *), int result) { @@ -2144,8 +2142,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 +2255,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. * * ---------------------------------------------------------------------- */ @@ -2285,28 +2283,28 @@ EnsembleUnknownCallback( Tcl_Obj *const objv[], Tcl_Obj **prefixObjPtr) { - int paramc, i, result, prefixObjc; + int paramc, i, prefixObjc; + int result; 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); TclNewObj(ensObj); Tcl_GetCommandFullName(interp, ensemblePtr->token, ensObj); Tcl_ListObjAppendElement(NULL, unknownCmd, ensObj); - for (i=1 ; i reparse. + * Empty result => reparse. */ TclDecrRefCount(*prefixObjPtr); @@ -2361,7 +2354,7 @@ EnsembleUnknownCallback( } /* - * Oh no! An exceptional result. Convert to an error. + * Convert exceptional result to an error. */ if (!Tcl_InterpDeleted(interp)) { @@ -2401,16 +2394,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 +2425,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 *)ckalloc(sizeof(EnsembleCmdRep)); @@ -2459,17 +2451,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. * *---------------------------------------------------------------------- */ @@ -2496,15 +2487,12 @@ ClearTable( static void DeleteEnsembleConfig( - ClientData clientData) + void *clientData) { 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 +2518,7 @@ DeleteEnsembleConfig( ensemblePtr->flags |= ENSEMBLE_DEAD; /* - * Kill the pointer-containing fields. + * Release the fields that contain pointers. */ ClearTable(ensemblePtr); @@ -2548,10 +2536,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 +2549,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 +2561,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,10 +2570,10 @@ static void BuildEnsembleConfig( EnsembleConfig *ensemblePtr) { - Tcl_HashSearch search; /* Used for scanning the set of commands in - * the namespace that backs up this - * ensemble. */ - int i, j, isNew; + Tcl_HashSearch search; /* Used for scanning the commands in + * the namespace for this ensemble. */ + int i, j; + int isNew; Tcl_HashTable *hash = &ensemblePtr->subcommandTable; Tcl_HashEntry *hPtr; Tcl_Obj *mapDict = ensemblePtr->subcommandDict; @@ -2602,13 +2589,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. */ TclListObjGetElementsM(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. */ @@ -2657,10 +2644,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); @@ -2671,9 +2658,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; @@ -2692,18 +2679,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); @@ -2748,22 +2732,22 @@ BuildEnsembleConfig( /* * 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 **)ckalloc(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++) { @@ -2771,11 +2755,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; @@ -2801,8 +2785,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, @@ -2930,14 +2913,15 @@ TclCompileEnsemble( Tcl_Obj *replaced, *replacement; Tcl_Command ensemble = (Tcl_Command) cmdPtr; Command *oldCmdPtr = cmdPtr, *newCmdPtr; - int len, result, flags = 0, i, depth = 1, invokeAnyway = 0; + int result, flags = 0, depth = 1, invokeAnyway = 0; int ourResult = TCL_ERROR; - unsigned numBytes; + int i, len; + TCL_HASH_TYPE numBytes; const char *word; TclNewObj(replaced); Tcl_IncrRefCount(replaced); - if (parsePtr->numWords < depth + 1) { + if (parsePtr->numWords <= depth) { goto failed; } if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { @@ -3197,7 +3181,7 @@ TclCompileEnsemble( * Throw out any line information generated by the failed compile attempt. */ - while (mapPtr->nuloc - 1 > eclIndex) { + while (mapPtr->nuloc > eclIndex + 1) { mapPtr->nuloc--; ckfree(mapPtr->loc[mapPtr->nuloc].line); mapPtr->loc[mapPtr->nuloc].line = NULL; @@ -3264,10 +3248,11 @@ TclAttemptCompileProc( CompileEnv *envPtr) /* Holds resulting instructions. */ { DefineLineInformation; - int result, i; + int result; + int i; Tcl_Token *saveTokenPtr = parsePtr->tokenPtr; int savedStackDepth = envPtr->currStackDepth; - unsigned savedCodeNext = envPtr->codeNext - envPtr->codeStart; + TCL_HASH_TYPE savedCodeNext = envPtr->codeNext - envPtr->codeStart; int savedAuxDataArrayNext = envPtr->auxDataArrayNext; int savedExceptArrayNext = envPtr->exceptArrayNext; #ifdef TCL_COMPILE_DEBUG @@ -3400,7 +3385,8 @@ CompileToInvokedCommand( Tcl_Token *tokPtr; Tcl_Obj *objPtr, **words; const char *bytes; - int i, numWords, cmdLit, extraLiteralFlags = LITERAL_CMD_NAME; + int cmdLit, extraLiteralFlags = LITERAL_CMD_NAME; + int i, numWords, length; /* * Push the words of the command. Take care; the command words may be @@ -3411,9 +3397,9 @@ CompileToInvokedCommand( TclListObjGetElementsM(NULL, replacements, &numWords, &words); for (i = 0, tokPtr = parsePtr->tokenPtr; i < parsePtr->numWords; i++, tokPtr = TokenAfter(tokPtr)) { - if (i > 0 && i < numWords+1) { - bytes = TclGetString(words[i-1]); - PushLiteral(envPtr, bytes, words[i-1]->length); + if (i > 0 && i <= numWords) { + bytes = TclGetStringFromObj(words[i-1], &length); + PushLiteral(envPtr, bytes, length); continue; } @@ -3441,11 +3427,11 @@ CompileToInvokedCommand( TclNewObj(objPtr); Tcl_GetCommandFullName(interp, (Tcl_Command) cmdPtr, objPtr); - bytes = TclGetString(objPtr); + bytes = TclGetStringFromObj(objPtr, &length); if ((cmdPtr != NULL) && (cmdPtr->flags & CMD_VIA_RESOLVER)) { extraLiteralFlags |= LITERAL_UNSHARED; } - cmdLit = TclRegisterLiteral(envPtr, bytes, objPtr->length, extraLiteralFlags); + cmdLit = TclRegisterLiteral(envPtr, bytes, length, extraLiteralFlags); TclSetCmdNameObj(interp, TclFetchLiteral(envPtr, cmdLit), cmdPtr); TclEmitPush(cmdLit, envPtr); TclDecrRefCount(objPtr); diff --git a/generic/tclExecute.c b/generic/tclExecute.c index 923aae3..e292537 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -511,13 +511,13 @@ VarHashCreateVar( #define GetNumberFromObj(interp, objPtr, ptrPtr, tPtr) \ ((TclHasInternalRep((objPtr), &tclIntType)) \ ? (*(tPtr) = TCL_NUMBER_INT, \ - *(ptrPtr) = (ClientData) \ + *(ptrPtr) = (void *) \ (&((objPtr)->internalRep.wideValue)), TCL_OK) : \ TclHasInternalRep((objPtr), &tclDoubleType) \ ? (((isnan((objPtr)->internalRep.doubleValue)) \ ? (*(tPtr) = TCL_NUMBER_NAN) \ : (*(tPtr) = TCL_NUMBER_DOUBLE)), \ - *(ptrPtr) = (ClientData) \ + *(ptrPtr) = (void *) \ (&((objPtr)->internalRep.doubleValue)), TCL_OK) : \ (((objPtr)->bytes != NULL) && ((objPtr)->length == 0)) \ ? TCL_ERROR : \ @@ -1348,7 +1348,7 @@ int Tcl_ExprObj( Tcl_Interp *interp, /* Context in which to evaluate the * expression. */ - Tcl_Obj *objPtr, /* Points to Tcl object containing expression + Tcl_Obj *objPtr, /* Points to Tcl object containing expression * to evaluate. */ Tcl_Obj **resultPtrPtr) /* Where the Tcl_Obj* that is the expression * result is stored if no errors occur. */ @@ -1494,10 +1494,11 @@ CompileExprObj( * TIP #280: No invoker (yet) - Expression compilation. */ - const char *string = TclGetString(objPtr); + int length; + const char *string = TclGetStringFromObj(objPtr, &length); - TclInitCompileEnv(interp, &compEnv, string, objPtr->length, NULL, 0); - TclCompileExpr(interp, string, objPtr->length, &compEnv, 0); + TclInitCompileEnv(interp, &compEnv, string, length, NULL, 0); + TclCompileExpr(interp, string, length, &compEnv, 0); /* * Successful compilation. If the expression yielded no instructions, @@ -2105,8 +2106,8 @@ TEBCresume( Tcl_Obj *objPtr, *valuePtr, *value2Ptr, *part1Ptr, *part2Ptr, *tmpPtr; Tcl_Obj **objv = NULL; - int objc = 0; - int opnd, length, pcAdjustment; + int length, objc = 0; + int opnd, pcAdjustment; Var *varPtr, *arrayPtr; #ifdef TCL_COMPILE_DEBUG char cmdNameBuf[21]; @@ -3184,7 +3185,8 @@ TEBCresume( */ { - int storeFlags, len; + int storeFlags; + int len; case INST_STORE_ARRAY4: opnd = TclGetUInt4AtPtr(pc+1); @@ -4660,7 +4662,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 >= 0 ; i--) { miPtr = contextPtr->callPtr->chain + i; if (miPtr->isFilter || miPtr->mPtr->declaringClassPtr != classPtr) { @@ -4829,8 +4831,8 @@ TEBCresume( */ { - int index, numIndices, fromIdx, toIdx; - int nocase, match, length2, cflags, s1len, s2len; + int numIndices, nocase, match, cflags; + int length2, fromIdx, toIdx, index, s1len, s2len; const char *s1, *s2; case INST_LIST: @@ -6866,7 +6868,8 @@ TEBCresume( */ { - int opnd2, allocateDict, done, i, allocdict; + int opnd2, allocateDict, done, allocdict; + int i; Tcl_Obj *dictPtr, *statePtr, *keyPtr, *listPtr, *varNamePtr, *keysPtr; Tcl_Obj *emptyPtr, **keyPtrPtr; Tcl_DictSearch *searchPtr; @@ -10046,7 +10049,7 @@ EvalStatsCmd( #ifdef TCL_MEM_DEBUG Tcl_AppendPrintfToObj(objPtr, "\nHeap Statistics:\n"); - TclDumpMemoryInfo((ClientData) objPtr, 1); + TclDumpMemoryInfo(objPtr, 1); #endif Tcl_AppendPrintfToObj(objPtr, "\n----------------------------------------------------------------\n"); diff --git a/generic/tclLink.c b/generic/tclLink.c index 384fcf3..6bd65fa 100644 --- a/generic/tclLink.c +++ b/generic/tclLink.c @@ -95,7 +95,7 @@ typedef struct Link { * Forward references to functions defined later in this file: */ -static char * LinkTraceProc(ClientData clientData,Tcl_Interp *interp, +static char * LinkTraceProc(void *clientData,Tcl_Interp *interp, const char *name1, const char *name2, int flags); static Tcl_Obj * ObjValue(Link *linkPtr); static void LinkFree(Link *linkPtr); @@ -527,7 +527,7 @@ GetUWide( Tcl_WideUInt *uwidePtr) { Tcl_WideInt *widePtr = (Tcl_WideInt *) uwidePtr; - ClientData clientData; + void *clientData; int type, intValue; if (TclGetNumberFromObj(NULL, objPtr, &clientData, &type) == TCL_OK) { @@ -633,14 +633,15 @@ SetInvalidRealFromAny( { const char *str; const char *endPtr; + int length; - str = TclGetString(objPtr); - if ((objPtr->length == 1) && (str[0] == '.')) { + str = TclGetStringFromObj(objPtr, &length); + if ((length == 1) && (str[0] == '.')) { objPtr->typePtr = &invalidRealType; objPtr->internalRep.doubleValue = 0.0; return TCL_OK; } - if (TclParseNumber(NULL, objPtr, NULL, str, objPtr->length, &endPtr, + if (TclParseNumber(NULL, objPtr, NULL, str, length, &endPtr, TCL_PARSE_DECIMAL_ONLY) == TCL_OK) { /* * If number is followed by [eE][+-]?, then it is an invalid @@ -678,13 +679,14 @@ GetInvalidIntFromObj( Tcl_Obj *objPtr, int *intPtr) { - const char *str = TclGetString(objPtr); + int length; + const char *str = TclGetStringFromObj(objPtr, &length); - if ((objPtr->length == 0) || ((objPtr->length == 2) && (str[0] == '0') + if ((length == 0) || ((length == 2) && (str[0] == '0') && strchr("xXbBoOdD", str[1]))) { *intPtr = 0; return TCL_OK; - } else if ((objPtr->length == 1) && strchr("+-", str[0])) { + } else if ((length == 1) && strchr("+-", str[0])) { *intPtr = (str[0] == '+'); return TCL_OK; } @@ -743,7 +745,7 @@ GetInvalidDoubleFromObj( static char * LinkTraceProc( - ClientData clientData, /* Contains information about the link. */ + void *clientData, /* Contains information about the link. */ Tcl_Interp *interp, /* Interpreter containing Tcl variable. */ TCL_UNUSED(const char *) /*name1*/, TCL_UNUSED(const char *) /*name2*/, @@ -896,8 +898,8 @@ LinkTraceProc( switch (linkPtr->type) { case TCL_LINK_STRING: - value = TclGetString(valueObj); - valueLength = valueObj->length + 1; + value = TclGetStringFromObj(valueObj, &valueLength); + valueLength++; /* include end of string char */ pp = (char **) linkPtr->addr; *pp = (char *)ckrealloc(*pp, valueLength); @@ -905,7 +907,7 @@ LinkTraceProc( return NULL; case TCL_LINK_CHARS: - value = (char *) Tcl_GetStringFromObj(valueObj, &valueLength); + value = (char *) TclGetStringFromObj(valueObj, &valueLength); valueLength++; /* include end of string char */ if (valueLength > linkPtr->bytes) { return (char *) "wrong size of char* value"; -- cgit v0.12 -- cgit v0.12 From 7af0d34d1f3f2c97eb05aca168447160d61dfcc8 Mon Sep 17 00:00:00 2001 From: sebres Date: Thu, 21 Jul 2022 18:55:30 +0000 Subject: added tests illustrating bug [b3977d199b] --- tests/io.test | 89 +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 89 insertions(+) diff --git a/tests/io.test b/tests/io.test index fe1052a..866d199 100644 --- a/tests/io.test +++ b/tests/io.test @@ -2984,6 +2984,95 @@ test io-29.35 {Tcl_Close vs fileevent vs multiple interpreters} {socket tempNotM interp delete y } "" +test io-29.36.1 {gets on translation auto with "\r" in QA communication mode, possible regression, bug [b3977d199b]} -constraints { + socket tempNotMac fileevent +} -setup { + set s [open "|[list [interpreter] << { + proc accept {so args} { + fconfigure $so -translation binary + puts -nonewline $so "who are you?\r"; flush $so + set a [gets $so] + puts -nonewline $so "really $a?\r"; flush $so + set a [gets $so] + close $so + set ::done $a + } + set s [socket -server [namespace code accept] -myaddr 127.0.0.1 0] + puts [lindex [fconfigure $s -sockname] 2] + foreach c {1 2} { + vwait ::done + puts $::done + } + }]" r] + set c {} + set result {} +} -body { + set port [gets $s] + foreach t {{cr lf} auto} { + set c [socket 127.0.0.1 $port] + fconfigure $c -buffering line -translation $t + lappend result $t + while {1} { + set q [gets $c] + switch -- $q { + "who are you?" {puts $c "client"} + "really client?" {puts $c "yes"; lappend result $q; break} + default {puts $c "wrong"; lappend result "unexpected input \"$q\""; break} + } + } + lappend result [gets $s] + close $c; set c {} + } + set result +} -cleanup { + close $s + if {$c ne {}} { close $c } + unset -nocomplain s c port t q +} -result [list {cr lf} "really client?" yes auto "really client?" yes] +test io-29.36.2 {gets on translation auto with "\r\n" in different buffers, bug [b3977d199b]} -constraints { + socket tempNotMac fileevent +} -setup { + set s [socket -server [namespace code accept] -myaddr 127.0.0.1 0] + set c {} +} -body { + set ::cnt 0 + proc accept {so args} { + fconfigure $so -translation binary + puts -nonewline $so "1 line\r" + puts -nonewline $so "\n2 li" + flush $so + # now force separate packets + puts -nonewline $so "ne\r" + flush $so + if {$::cnt & 1} { + vwait ::cli; # simulate short delay (so client can process events, just wait for it) + } else { + # we don't have a delay, so client would get the lines as single chunk + } + puts -nonewline $so "\n3 line" + flush $so + close $so + } + while {$::cnt < 4} { incr ::cnt + set c [socket 127.0.0.1 [lindex [fconfigure $s -sockname] 2]] + fconfigure $c -blocking 0 -buffering line -translation auto + fileevent $c readable [list apply {c { + if {[gets $c line] >= 0} { + lappend ::cli <$line> + } elseif {[eof $c]} { + set ::done 1 + } + }} $c] + vwait ::done + close $c; set c {} + } + set ::cli +} -cleanup { + close $s + if {$c ne {}} { close $c } + unset -nocomplain ::done ::cli ::cnt s c +} -result [lrepeat 4 {<1 line>} {<2 line>} {<3 line>}] + # Test end of line translations. Procedures tested are Tcl_Write, Tcl_Read. test io-30.1 {Tcl_Write lf, Tcl_Read lf} { -- cgit v0.12 From 951e955d2c89cad1bd96d2e9ec08233d1a14f2f1 Mon Sep 17 00:00:00 2001 From: apnadkarni Date: Fri, 22 Jul 2022 06:32:40 +0000 Subject: Added testapplylambda to illustrate bug in apply when the passed argument does NOT have Lambda internal representation but the body of the lambda DOES have an internal ByteCode representation. --- generic/tclTest.c | 84 ++++++++++++++++++++++++++++++++++++++++++++++++++++++- 1 file changed, 83 insertions(+), 1 deletion(-) diff --git a/generic/tclTest.c b/generic/tclTest.c index e3c6663..77540e2 100644 --- a/generic/tclTest.c +++ b/generic/tclTest.c @@ -342,6 +342,7 @@ static Tcl_ObjCmdProc TestInterpResolverCmd; #if defined(HAVE_CPUID) && !defined(MAC_OSX_TCL) static Tcl_ObjCmdProc TestcpuidCmd; #endif +static Tcl_ObjCmdProc TestApplyLambdaObjCmd; static const Tcl_Filesystem testReportingFilesystem = { "reporting", @@ -715,6 +716,8 @@ Tcltest_Init( NULL, NULL); Tcl_CreateObjCommand(interp, "testsetencpath", TestsetencpathObjCmd, NULL, NULL); + Tcl_CreateObjCommand(interp, "testapplylambda", TestApplyLambdaObjCmd, + NULL, NULL); if (TclObjTest_Init(interp) != TCL_OK) { return TCL_ERROR; @@ -8120,7 +8123,85 @@ TestInterpResolverCmd( } return TCL_OK; } - + +/* + *------------------------------------------------------------------------ + * + * TestApplyLambdaObjCmd -- + * + * Implements the Tcl command testapplylambda. This tests the apply + * implementation handling of a lambda where the lambda has a list + * internal representation where the second element's internal + * representation is already a byte code object. + * + * Results: + * TCL_OK - Success. Caller should check result is 42 + * TCL_ERROR - Error. + * + * Side effects: + * In the presence of the apply bug, may panic. Otherwise + * Interpreter result holds result or error message. + * + *------------------------------------------------------------------------ + */ +int TestApplyLambdaObjCmd ( + ClientData notUsed, + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ + Tcl_Obj *lambdaObjs[2]; + Tcl_Obj *evalObjs[2]; + Tcl_Obj *lambdaObj; + int result; + + /* Create a lambda {{} {set a 42}} */ + lambdaObjs[0] = Tcl_NewObj(); /* No parameters */ + lambdaObjs[1] = Tcl_NewStringObj("set a 42", -1); /* Body */ + lambdaObj = Tcl_NewListObj(2, lambdaObjs); + Tcl_IncrRefCount(lambdaObj); + + /* Create the command "apply {{} {set a 42}" */ + evalObjs[0] = Tcl_NewStringObj("apply", -1); + Tcl_IncrRefCount(evalObjs[0]); + /* + * NOTE: IMPORTANT TO EXHIBIT THE BUG. We duplicate the lambda because + * it will get shimmered to a Lambda internal representation but we + * want to hold on to our list representation. + */ + evalObjs[1] = Tcl_DuplicateObj(lambdaObj); + Tcl_IncrRefCount(evalObjs[1]); + + /* Evaluate it */ + result = Tcl_EvalObjv(interp, 2, evalObjs, TCL_EVAL_GLOBAL); + if (result != TCL_OK) { + Tcl_DecrRefCount(evalObjs[0]); + Tcl_DecrRefCount(evalObjs[1]); + return result; + } + /* + * So far so good. At this point, + * - evalObjs[1] has an internal representation of Lambda + * - lambdaObj[1] ({set a 42}) has been shimmered to + * an internal representation of ByteCode. + */ + Tcl_DecrRefCount(evalObjs[1]); /* Don't need this anymore */ + /* + * The bug trigger. Repeating the command but: + * - we are calling apply with a lambda that is a list (as BEFORE), + * BUT + * - The body of the lambda (lambdaObjs[1]) ALREADY has internal + * representation of ByteCode and thus will not be compiled again + */ + evalObjs[1] = lambdaObj; /* lambdaObj already has a ref count so + no need for IncrRef */ + result = Tcl_EvalObjv(interp, 2, evalObjs, TCL_EVAL_GLOBAL); + Tcl_DecrRefCount(evalObjs[0]); + Tcl_DecrRefCount(lambdaObj); + + return result; +} + /* * Local Variables: * mode: c @@ -8130,3 +8211,4 @@ TestInterpResolverCmd( * indent-tabs-mode: nil * End: */ + -- cgit v0.12 From 5f5c1bf7f1f0c4fb33e50301c87ad228cc1cc366 Mon Sep 17 00:00:00 2001 From: apnadkarni Date: Fri, 22 Jul 2022 11:10:15 +0000 Subject: Fix and test crash using apply when the passed argument does NOT have already Lambda internal representation but the body of the lambda DOES have an internal ByteCode representation. --- generic/tclProc.c | 8 ++++++++ tests/apply.test | 9 +++++++++ 2 files changed, 17 insertions(+) diff --git a/generic/tclProc.c b/generic/tclProc.c index 17635e7..9677f02 100644 --- a/generic/tclProc.c +++ b/generic/tclProc.c @@ -2457,6 +2457,14 @@ SetLambdaFromAny( argsPtr = objv[0]; bodyPtr = objv[1]; + /* + * Bugfix for testapplylambda. If we are constructing a new lambda, + * the body must be recompiled even if it is already a ByteCode object. + * Otherwise the procPtr->numCompiledLocals will not get updated causing + * a crash as local variable space is not allocated. + */ + (void) TclGetString(bodyPtr); /* Ensure string representation exists */ + TclFreeInternalRep(bodyPtr); /* * Create and initialize the Proc struct. The cmdPtr field is set to NULL diff --git a/tests/apply.test b/tests/apply.test index e2be172..32dff08 100644 --- a/tests/apply.test +++ b/tests/apply.test @@ -22,6 +22,8 @@ if {[info commands ::apply] eq {}} { } testConstraint memory [llength [info commands memory]] +testConstraint applylambda [llength [info commands testapplylambda]] + # Tests for wrong number of arguments @@ -306,6 +308,13 @@ test apply-9.3 {leaking internal rep} -setup { unset -nocomplain end i x tmp leakedBytes } -result 0 +# Tests for specific bugs +test apply-10.1 {Test for precompiled bytecode body} -constraints { + applylambda +} -body { + testapplylambda +} -result 42 + # Tests for the avoidance of recompilation # cleanup -- cgit v0.12 From b69f262ad8aca1cb0d2e9d3a3c906b0eea06bb6c Mon Sep 17 00:00:00 2001 From: sebres Date: Fri, 22 Jul 2022 13:10:32 +0000 Subject: amend to [f3db59139e] (fix [713653b951]) - i386 only, resolve mixed declarations and code (forbiddeen in ISO C) --- generic/tclStrToD.c | 45 ++++++++++++++++++++++++--------------------- 1 file changed, 24 insertions(+), 21 deletions(-) diff --git a/generic/tclStrToD.c b/generic/tclStrToD.c index 375746d..557eaa1 100644 --- a/generic/tclStrToD.c +++ b/generic/tclStrToD.c @@ -51,44 +51,43 @@ * file exists only on Linux; it is missing on Cygwin and MinGW. Most gcc-isms * and ix86-isms are factored out here. */ - -#if defined(__GNUC__) +# if defined(__GNUC__) typedef unsigned int fpu_control_t __attribute__ ((__mode__ (__HI__))); -#define _FPU_GETCW(cw) __asm__ __volatile__ ("fnstcw %0" : "=m" (*&cw)) -#define _FPU_SETCW(cw) __asm__ __volatile__ ("fldcw %0" : : "m" (*&cw)) -# define FPU_IEEE_ROUNDING 0x027F -# define ADJUST_FPU_CONTROL_WORD -#define TCL_IEEE_DOUBLE_ROUNDING \ +# define _FPU_GETCW(cw) __asm__ __volatile__ ("fnstcw %0" : "=m" (*&cw)) +# define _FPU_SETCW(cw) __asm__ __volatile__ ("fldcw %0" : : "m" (*&cw)) +# define FPU_IEEE_ROUNDING 0x027F +# define ADJUST_FPU_CONTROL_WORD +# define TCL_IEEE_DOUBLE_ROUNDING_DECL \ fpu_control_t roundTo53Bits = FPU_IEEE_ROUNDING; \ - fpu_control_t oldRoundingMode; \ + fpu_control_t oldRoundingMode; +# define TCL_IEEE_DOUBLE_ROUNDING \ _FPU_GETCW(oldRoundingMode); \ _FPU_SETCW(roundTo53Bits) -#define TCL_DEFAULT_DOUBLE_ROUNDING \ +# define TCL_DEFAULT_DOUBLE_ROUNDING \ _FPU_SETCW(oldRoundingMode) /* * Sun ProC needs sunmath for rounding control on x86 like gcc above. */ -#elif defined(__sun) -#include -#define TCL_IEEE_DOUBLE_ROUNDING \ +# elif defined(__sun) +# include +# define TCL_IEEE_DOUBLE_ROUNDING_DECL +# define TCL_IEEE_DOUBLE_ROUNDING \ ieee_flags("set","precision","double",NULL) -#define TCL_DEFAULT_DOUBLE_ROUNDING \ +# define TCL_DEFAULT_DOUBLE_ROUNDING \ ieee_flags("clear","precision",NULL,NULL) +# endif +#endif /* * Other platforms are assumed to always operate in full IEEE mode, so we make * the macros to go in and out of that mode do nothing. */ - -#else /* !__GNUC__ && !__sun */ -#define TCL_IEEE_DOUBLE_ROUNDING ((void) 0) -#define TCL_DEFAULT_DOUBLE_ROUNDING ((void) 0) -#endif -#else /* !__i386 */ -#define TCL_IEEE_DOUBLE_ROUNDING ((void) 0) -#define TCL_DEFAULT_DOUBLE_ROUNDING ((void) 0) +#ifndef TCL_IEEE_DOUBLE_ROUNDING /* !__i386 || (!__GNUC__ && !__sun) */ +# define TCL_IEEE_DOUBLE_ROUNDING_DECL +# define TCL_IEEE_DOUBLE_ROUNDING ((void) 0) +# define TCL_DEFAULT_DOUBLE_ROUNDING ((void) 0) #endif /* @@ -1627,6 +1626,8 @@ MakeLowPrecisionDouble( int numSigDigs, /* Number of digits in the significand */ long exponent) /* Power of ten */ { + TCL_IEEE_DOUBLE_ROUNDING_DECL + mp_int significandBig; /* Significand expressed as a bignum. */ /* @@ -1750,6 +1751,8 @@ MakeHighPrecisionDouble( int numSigDigs, /* Number of significant digits */ long exponent) /* Power of 10 by which to multiply */ { + TCL_IEEE_DOUBLE_ROUNDING_DECL + int machexp; /* Machine exponent of a power of 10. */ /* -- cgit v0.12 From c3cc26df50b8e700e15a735e75defe3b0e7c1275 Mon Sep 17 00:00:00 2001 From: sebres Date: Fri, 22 Jul 2022 16:22:22 +0000 Subject: fixes logical error in test io-29.36.1 (translation {auto} causes that answer "client" reaches the server-side as "client\r\n", and `gets` by translation {binary} behaves nearly identical to {lf} mode, so sends "really client\r?\r" in the next question), switching to {auto lf} now --- tests/io.test | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/tests/io.test b/tests/io.test index f75f111..8df28ba 100644 --- a/tests/io.test +++ b/tests/io.test @@ -3013,7 +3013,7 @@ test io-29.36.1 {gets on translation auto with "\r" in QA communication mode, po set result {} } -body { set port [gets $s] - foreach t {{cr lf} auto} { + foreach t {{cr lf} {auto lf}} { set c [socket 127.0.0.1 $port] fconfigure $c -buffering line -translation $t lappend result $t @@ -3033,7 +3033,7 @@ test io-29.36.1 {gets on translation auto with "\r" in QA communication mode, po close $s if {$c ne {}} { close $c } unset -nocomplain s c port t q -} -result [list {cr lf} "really client?" yes auto "really client?" yes] +} -result [list {cr lf} "really client?" yes {auto lf} "really client?" yes] test io-29.36.2 {gets on translation auto with "\r\n" in different buffers, bug [b3977d199b]} -constraints { socket tempNotMac fileevent } -setup { -- cgit v0.12 From 49f09ae8c228ad19029f35a4f40ba6dc6c5d5fff Mon Sep 17 00:00:00 2001 From: sebres Date: Fri, 22 Jul 2022 17:36:57 +0000 Subject: extends test io-29.36.2 for better illustration when we'll get extra NL - if no "\r" in last buffer, so only EOF causes exit from gets (flag INPUT_SAW_CR gets reset incorrectly) --- tests/io.test | 8 ++++++-- 1 file changed, 6 insertions(+), 2 deletions(-) diff --git a/tests/io.test b/tests/io.test index 8df28ba..3b374c1 100644 --- a/tests/io.test +++ b/tests/io.test @@ -3054,11 +3054,15 @@ test io-29.36.2 {gets on translation auto with "\r\n" in different buffers, bug } else { # we don't have a delay, so client would get the lines as single chunk } + # we'll try with "\r" and without "\r" (to cover both branches, where "\r" and "eof" causes exit from [gets] by 3rd line) puts -nonewline $so "\n3 line" + if {!($::cnt % 3)} { + puts -nonewline $so "\r" + } flush $so close $so } - while {$::cnt < 4} { incr ::cnt + while {$::cnt < 6} { incr ::cnt set c [socket 127.0.0.1 [lindex [fconfigure $s -sockname] 2]] fconfigure $c -blocking 0 -buffering line -translation auto fileevent $c readable [list apply {c { @@ -3076,7 +3080,7 @@ test io-29.36.2 {gets on translation auto with "\r\n" in different buffers, bug close $s if {$c ne {}} { close $c } unset -nocomplain ::done ::cli ::cnt s c -} -result [lrepeat 4 {<1 line>} {<2 line>} {<3 line>}] +} -result [lrepeat 6 {<1 line>} {<2 line>} {<3 line>}] # Test end of line translations. Procedures tested are Tcl_Write, Tcl_Read. -- cgit v0.12 From 255250308e8dba52bc7e154ed96e6b15859b064f Mon Sep 17 00:00:00 2001 From: sebres Date: Fri, 22 Jul 2022 17:41:48 +0000 Subject: fixes [b3977d199b] - don't reset INPUT_SAW_CR unless the buffer get really translated (missing "\r" caused that flag got reset too early, because the translation takes place at next round by EOF) --- generic/tclIO.c | 390 +++++++++++++++++++++++++++++++++++++------------------- 1 file changed, 260 insertions(+), 130 deletions(-) diff --git a/generic/tclIO.c b/generic/tclIO.c index 108114c..e102675 100644 --- a/generic/tclIO.c +++ b/generic/tclIO.c @@ -340,7 +340,8 @@ static const Tcl_ObjType chanObjType = { (((st)->csPtrW) && ((fl) & TCL_WRITABLE))) #define MAX_CHANNEL_BUFFER_SIZE (1024*1024) - + + /* *--------------------------------------------------------------------------- * @@ -510,7 +511,8 @@ ChanWrite( return chanPtr->typePtr->outputProc(chanPtr->instanceData, src, srcLen, errnoPtr); } - + + /* *--------------------------------------------------------------------------- * @@ -538,7 +540,8 @@ TclInitIOSubsystem(void) (void) TCL_TSD_INIT(&dataKey); } - + + /* *------------------------------------------------------------------------- * @@ -684,7 +687,8 @@ TclFinalizeIOSubsystem(void) TclpFinalizeSockets(); TclpFinalizePipes(); } - + + /* *---------------------------------------------------------------------- * @@ -725,7 +729,8 @@ Tcl_SetStdChannel( break; } } - + + /* *---------------------------------------------------------------------- * @@ -801,7 +806,8 @@ Tcl_GetStdChannel( } return channel; } - + + /* *---------------------------------------------------------------------- * @@ -839,7 +845,8 @@ Tcl_CreateCloseHandler( cbPtr->nextPtr = statePtr->closeCbPtr; statePtr->closeCbPtr = cbPtr; } - + + /* *---------------------------------------------------------------------- * @@ -884,7 +891,8 @@ Tcl_DeleteCloseHandler( cbPrevPtr = cbPtr; } } - + + /* *---------------------------------------------------------------------- * @@ -940,7 +948,8 @@ GetChannelTable( } return hTblPtr; } - + + /* *---------------------------------------------------------------------- * @@ -1030,7 +1039,8 @@ DeleteChannelTable( Tcl_DeleteHashTable(hTblPtr); ckfree(hTblPtr); } - + + /* *---------------------------------------------------------------------- * @@ -1086,7 +1096,8 @@ CheckForStdChannelsBeingClosed( } } } - + + /* *---------------------------------------------------------------------- * @@ -1119,7 +1130,8 @@ Tcl_IsStandardChannel( return 0; } } - + + /* *---------------------------------------------------------------------- * @@ -1176,7 +1188,8 @@ Tcl_RegisterChannel( } statePtr->refCount++; } - + + /* *---------------------------------------------------------------------- * @@ -1261,7 +1274,8 @@ Tcl_UnregisterChannel( } return TCL_OK; } - + + /* *---------------------------------------------------------------------- * @@ -1307,7 +1321,8 @@ Tcl_DetachChannel( return DetachChannel(interp, chan); } - + + /* *---------------------------------------------------------------------- * @@ -1380,7 +1395,8 @@ DetachChannel( return TCL_OK; } - + + /* *--------------------------------------------------------------------------- * @@ -1462,7 +1478,8 @@ Tcl_GetChannel( return (Tcl_Channel) chanPtr; } - + + /* *--------------------------------------------------------------------------- * @@ -1558,7 +1575,8 @@ TclGetChannelFromObj( return TCL_OK; } - + + /* *---------------------------------------------------------------------- * @@ -1766,7 +1784,8 @@ Tcl_CreateChannel( } return (Tcl_Channel) chanPtr; } - + + /* *---------------------------------------------------------------------- * @@ -1995,7 +2014,8 @@ ChannelFree( } chanPtr->typePtr = NULL; } - + + /* *---------------------------------------------------------------------- * @@ -2183,7 +2203,8 @@ Tcl_UnstackChannel( return TCL_OK; } - + + /* *---------------------------------------------------------------------- * @@ -2211,7 +2232,8 @@ Tcl_GetStackedChannel( return (Tcl_Channel) chanPtr->downChanPtr; } - + + /* *---------------------------------------------------------------------- * @@ -2239,7 +2261,8 @@ Tcl_GetTopChannel( return (Tcl_Channel) chanPtr->state->topChanPtr; } - + + /* *---------------------------------------------------------------------- * @@ -2265,7 +2288,8 @@ Tcl_GetChannelInstanceData( return chanPtr->instanceData; } - + + /* *---------------------------------------------------------------------- * @@ -2292,7 +2316,8 @@ Tcl_GetChannelThread( return chanPtr->state->managingThread; } - + + /* *---------------------------------------------------------------------- * @@ -2318,7 +2343,8 @@ Tcl_GetChannelType( return chanPtr->typePtr; } - + + /* *---------------------------------------------------------------------- * @@ -2346,7 +2372,8 @@ Tcl_GetChannelMode( return (statePtr->flags & (TCL_READABLE | TCL_WRITABLE)); } - + + /* *---------------------------------------------------------------------- * @@ -2373,7 +2400,8 @@ Tcl_GetChannelName( return statePtr->channelName; } - + + /* *---------------------------------------------------------------------- * @@ -2415,7 +2443,8 @@ Tcl_GetChannelHandle( } return result; } - + + /* *--------------------------------------------------------------------------- * @@ -2483,7 +2512,8 @@ IsShared( { return bufPtr->refCount > 1; } - + + /* *---------------------------------------------------------------------- * @@ -2572,7 +2602,8 @@ RecycleBuffer( bufPtr->nextAdded = BUFFER_PADDING; bufPtr->nextPtr = NULL; } - + + /* *---------------------------------------------------------------------- * @@ -2608,7 +2639,8 @@ DiscardOutputQueued( RecycleBuffer(statePtr, bufPtr, 0); } } - + + /* *---------------------------------------------------------------------- * @@ -2642,7 +2674,8 @@ CheckForDeadChannel( } return 1; } - + + /* *---------------------------------------------------------------------- * @@ -2944,7 +2977,8 @@ FlushChannel( TclChannelRelease((Tcl_Channel)chanPtr); return errorCode; } - + + /* *---------------------------------------------------------------------- * @@ -3125,7 +3159,8 @@ CloseChannel( return errorCode; } - + + /* *---------------------------------------------------------------------- * @@ -3240,7 +3275,8 @@ Tcl_CutChannel( /* Channel is not managed by any thread */ statePtr->managingThread = NULL; } - + + /* *---------------------------------------------------------------------- * @@ -3330,7 +3366,8 @@ Tcl_SpliceChannel( ChanThreadAction(chanPtr, TCL_CHANNEL_THREAD_INSERT); } } - + + /* *---------------------------------------------------------------------- * @@ -3524,7 +3561,8 @@ Tcl_Close( } return TCL_OK; } - + + /* *---------------------------------------------------------------------- * @@ -3658,7 +3696,8 @@ Tcl_CloseEx( return TCL_OK; } - + + /* *---------------------------------------------------------------------- * @@ -3734,7 +3773,8 @@ CloseWrite( return TCL_OK; } - + + /* *---------------------------------------------------------------------- * @@ -3870,7 +3910,8 @@ CloseChannelPart( ResetFlag(statePtr, flags & (TCL_READABLE | TCL_WRITABLE)); return TCL_OK; } - + + /* *---------------------------------------------------------------------- * @@ -3964,7 +4005,8 @@ Tcl_ClearChannelHandlers( } statePtr->scriptRecordPtr = NULL; } - + + /* *---------------------------------------------------------------------- * @@ -4018,7 +4060,8 @@ Tcl_Write( } return srcLen; } - + + /* *---------------------------------------------------------------------- * @@ -4075,7 +4118,8 @@ Tcl_WriteRaw( return written; } - + + /* *--------------------------------------------------------------------------- * @@ -4142,7 +4186,8 @@ Tcl_WriteChars( TclDecrRefCount(objPtr); return result; } - + + /* *--------------------------------------------------------------------------- * @@ -4196,7 +4241,8 @@ Tcl_WriteObj( return WriteChars(chanPtr, src, srcLen); } } - + + static void WillWrite( Channel *chanPtr) @@ -4211,7 +4257,8 @@ WillWrite( ChanSeek(chanPtr, -inputBuffered, SEEK_CUR, &ignore); } } - + + static int WillRead( Channel *chanPtr) @@ -4244,7 +4291,8 @@ WillRead( } return 0; } - + + /* *---------------------------------------------------------------------- * @@ -4444,7 +4492,8 @@ Write( return total; } - + + /* *--------------------------------------------------------------------------- * @@ -4483,7 +4532,8 @@ Tcl_Gets( TclDecrRefCount(objPtr); return charsStored; } - + + /* *--------------------------------------------------------------------------- * @@ -4694,7 +4744,6 @@ Tcl_GetsObj( eol = dst; skip = 1; if (GotFlag(statePtr, INPUT_SAW_CR)) { - ResetFlag(statePtr, INPUT_SAW_CR); if ((eol < dstEnd) && (*eol == '\n')) { /* * Skip the raw bytes that make up the '\n'. @@ -4744,8 +4793,10 @@ Tcl_GetsObj( skip++; } eol--; + ResetFlag(statePtr, INPUT_SAW_CR); goto gotEOL; } else if (*eol == '\n') { + ResetFlag(statePtr, INPUT_SAW_CR); goto gotEOL; } } @@ -4895,7 +4946,8 @@ Tcl_GetsObj( TclChannelRelease((Tcl_Channel)chanPtr); return copiedTotal; } - + + /* *--------------------------------------------------------------------------- * @@ -5169,7 +5221,8 @@ TclGetsObjBinary( TclChannelRelease((Tcl_Channel)chanPtr); return copiedTotal; } - + + /* *--------------------------------------------------------------------------- * @@ -5211,7 +5264,8 @@ GetBinaryEncoding() } return tsdPtr->binaryEncoding; } - + + /* *--------------------------------------------------------------------------- * @@ -5404,7 +5458,8 @@ FilterInputBytes( gsPtr->bufPtr = bufPtr; return 0; } - + + /* *--------------------------------------------------------------------------- * @@ -5489,7 +5544,8 @@ PeekAhead( gsPtr->bytesWrote = 0; gsPtr->charsWrote = 0; } - + + /* *--------------------------------------------------------------------------- * @@ -5552,7 +5608,8 @@ CommonGetsCleanup( } } } - + + /* *---------------------------------------------------------------------- * @@ -5597,7 +5654,8 @@ Tcl_Read( return DoRead(chanPtr, dst, bytesToRead, 0); } - + + /* *---------------------------------------------------------------------- * @@ -5715,7 +5773,8 @@ Tcl_ReadRaw( } return copied; } - + + /* *--------------------------------------------------------------------------- * @@ -5970,7 +6029,8 @@ DoReadChars( TclChannelRelease((Tcl_Channel)chanPtr); return copied; } - + + /* *--------------------------------------------------------------------------- * @@ -6019,7 +6079,8 @@ ReadBytes( bufPtr->nextRemoved += toRead; return toRead; } - + + /* *--------------------------------------------------------------------------- * @@ -6422,7 +6483,8 @@ ReadChars( return numChars; } } - + + /* *--------------------------------------------------------------------------- * @@ -6598,7 +6660,8 @@ TranslateInputEOL( ResetFlag(statePtr, CHANNEL_BLOCKED|INPUT_SAW_CR); } } - + + /* *---------------------------------------------------------------------- * @@ -6686,7 +6749,8 @@ Tcl_Ungets( UpdateInterest(chanPtr); return len; } - + + /* *---------------------------------------------------------------------- * @@ -6730,7 +6794,8 @@ Tcl_Flush( return TCL_OK; } - + + /* *---------------------------------------------------------------------- * @@ -6777,7 +6842,8 @@ DiscardInputQueued( statePtr->saveInBufPtr = NULL; } } - + + /* *--------------------------------------------------------------------------- * @@ -6926,7 +6992,8 @@ GetInput( ReleaseChannelBuffer(bufPtr); return result; } - + + /* *---------------------------------------------------------------------- * @@ -7094,7 +7161,8 @@ Tcl_Seek( return curPos; } - + + /* *---------------------------------------------------------------------- * @@ -7183,7 +7251,8 @@ Tcl_Tell( } return curPos + outputBuffered; } - + + /* *--------------------------------------------------------------------------- * @@ -7224,7 +7293,8 @@ Tcl_TellOld( return (int) Tcl_WideAsLong(wResult); } - + + /* *--------------------------------------------------------------------------- * @@ -7296,7 +7366,8 @@ Tcl_TruncateChannel( } return TCL_OK; } - + + /* *--------------------------------------------------------------------------- * @@ -7384,7 +7455,8 @@ CheckChannelErrors( return 0; } - + + /* *---------------------------------------------------------------------- * @@ -7410,7 +7482,8 @@ Tcl_Eof( return GotFlag(statePtr, CHANNEL_EOF) ? 1 : 0; } - + + /* *---------------------------------------------------------------------- * @@ -7436,7 +7509,8 @@ Tcl_InputBlocked( return GotFlag(statePtr, CHANNEL_BLOCKED) ? 1 : 0; } - + + /* *---------------------------------------------------------------------- * @@ -7480,7 +7554,8 @@ Tcl_InputBuffered( return bytesBuffered; } - + + /* *---------------------------------------------------------------------- * @@ -7522,7 +7597,8 @@ Tcl_OutputBuffered( return bytesBuffered; } - + + /* *---------------------------------------------------------------------- * @@ -7557,7 +7633,8 @@ Tcl_ChannelBuffered( return bytesBuffered; } - + + /* *---------------------------------------------------------------------- * @@ -7615,7 +7692,8 @@ Tcl_SetChannelBufferSize( statePtr->inQueueTail = NULL; } } - + + /* *---------------------------------------------------------------------- * @@ -7642,7 +7720,8 @@ Tcl_GetChannelBufferSize( return statePtr->bufSize; } - + + /* *---------------------------------------------------------------------- * @@ -7713,7 +7792,8 @@ Tcl_BadChannelOption( Tcl_SetErrno(EINVAL); return TCL_ERROR; } - + + /* *---------------------------------------------------------------------- * @@ -7945,7 +8025,8 @@ Tcl_GetChannelOption( return Tcl_BadChannelOption(interp, optionName, NULL); } } - + + /* *--------------------------------------------------------------------------- * @@ -8247,7 +8328,8 @@ Tcl_SetChannelOption( return TCL_OK; } - + + /* *---------------------------------------------------------------------- * @@ -8301,7 +8383,8 @@ CleanupChannelHandlers( } } } - + + /* *---------------------------------------------------------------------- * @@ -8459,7 +8542,8 @@ done: tsdPtr->nestedHandlerPtr = nh.nestedHandlerPtr; } - + + /* *---------------------------------------------------------------------- * @@ -8560,7 +8644,8 @@ UpdateInterest( } ChanWatch(chanPtr, mask); } - + + /* *---------------------------------------------------------------------- * @@ -8605,7 +8690,8 @@ ChannelTimerProc( UpdateInterest(chanPtr); } } - + + /* *---------------------------------------------------------------------- * @@ -8685,7 +8771,8 @@ Tcl_CreateChannelHandler( UpdateInterest(statePtr->topChanPtr); } - + + /* *---------------------------------------------------------------------- * @@ -8775,7 +8862,8 @@ Tcl_DeleteChannelHandler( UpdateInterest(statePtr->topChanPtr); } - + + /* *---------------------------------------------------------------------- * @@ -8826,7 +8914,8 @@ DeleteScriptRecord( } } } - + + /* *---------------------------------------------------------------------- * @@ -8894,7 +8983,8 @@ CreateScriptRecord( TclChannelEventScriptInvoker, esPtr); } } - + + /* *---------------------------------------------------------------------- * @@ -8962,7 +9052,8 @@ TclChannelEventScriptInvoker( TclChannelRelease((Tcl_Channel)chanPtr); Tcl_Release(interp); } - + + /* *---------------------------------------------------------------------- * @@ -9060,7 +9151,8 @@ Tcl_FileEventObjCmd( return TCL_OK; } - + + /* *---------------------------------------------------------------------- * @@ -9087,7 +9179,8 @@ ZeroTransferTimerProc( */ CopyData((CopyState *)clientData, 0); } - + + /* *---------------------------------------------------------------------- * @@ -9240,7 +9333,8 @@ TclCopyChannel( return CopyData(csPtr, 0); } - + + /* *---------------------------------------------------------------------- * @@ -9791,7 +9885,8 @@ CopyData( } return result; } - + + /* *---------------------------------------------------------------------- * @@ -10037,7 +10132,8 @@ DoRead( TclChannelRelease((Tcl_Channel)chanPtr); return (int)(p - dst); } - + + /* *---------------------------------------------------------------------- * @@ -10063,7 +10159,8 @@ CopyEventProc( { (void) CopyData((CopyState *)clientData, mask); } - + + /* *---------------------------------------------------------------------- * @@ -10132,7 +10229,8 @@ StopCopy( outStatePtr->csPtrW = NULL; ckfree(csPtr); } - + + /* *---------------------------------------------------------------------- * @@ -10181,7 +10279,8 @@ StackSetBlockMode( } return 0; } - + + /* *---------------------------------------------------------------------- * @@ -10249,7 +10348,8 @@ SetBlockMode( } return TCL_OK; } - + + /* *---------------------------------------------------------------------- * @@ -10272,7 +10372,8 @@ Tcl_GetChannelNames( { return Tcl_GetChannelNamesEx(interp, NULL); } - + + /* *---------------------------------------------------------------------- * @@ -10358,7 +10459,8 @@ Tcl_GetChannelNamesEx( Tcl_SetObjResult(interp, resultPtr); return TCL_OK; } - + + /* *---------------------------------------------------------------------- * @@ -10408,7 +10510,8 @@ Tcl_IsChannelRegistered( return 1; } - + + /* *---------------------------------------------------------------------- * @@ -10434,7 +10537,8 @@ Tcl_IsChannelShared( return ((statePtr->refCount > 1) ? 1 : 0); } - + + /* *---------------------------------------------------------------------- * @@ -10483,7 +10587,8 @@ Tcl_IsChannelExisting( return 0; } - + + /* *---------------------------------------------------------------------- * @@ -10506,7 +10611,8 @@ Tcl_ChannelName( { return chanTypePtr->typeName; } - + + /* *---------------------------------------------------------------------- * @@ -10538,7 +10644,8 @@ Tcl_ChannelVersion( } return chanTypePtr->version; } - + + /* *---------------------------------------------------------------------- * @@ -10568,7 +10675,8 @@ Tcl_ChannelBlockModeProc( return chanTypePtr->blockModeProc; } - + + /* *---------------------------------------------------------------------- * @@ -10592,7 +10700,8 @@ Tcl_ChannelCloseProc( { return chanTypePtr->closeProc; } - + + /* *---------------------------------------------------------------------- * @@ -10616,7 +10725,8 @@ Tcl_ChannelClose2Proc( { return chanTypePtr->close2Proc; } - + + /* *---------------------------------------------------------------------- * @@ -10640,7 +10750,8 @@ Tcl_ChannelInputProc( { return chanTypePtr->inputProc; } - + + /* *---------------------------------------------------------------------- * @@ -10664,7 +10775,8 @@ Tcl_ChannelOutputProc( { return chanTypePtr->outputProc; } - + + /* *---------------------------------------------------------------------- * @@ -10688,7 +10800,8 @@ Tcl_ChannelSeekProc( { return chanTypePtr->seekProc; } - + + /* *---------------------------------------------------------------------- * @@ -10712,7 +10825,8 @@ Tcl_ChannelSetOptionProc( { return chanTypePtr->setOptionProc; } - + + /* *---------------------------------------------------------------------- * @@ -10736,7 +10850,8 @@ Tcl_ChannelGetOptionProc( { return chanTypePtr->getOptionProc; } - + + /* *---------------------------------------------------------------------- * @@ -10760,7 +10875,8 @@ Tcl_ChannelWatchProc( { return chanTypePtr->watchProc; } - + + /* *---------------------------------------------------------------------- * @@ -10784,7 +10900,8 @@ Tcl_ChannelGetHandleProc( { return chanTypePtr->getHandleProc; } - + + /* *---------------------------------------------------------------------- * @@ -10811,7 +10928,8 @@ Tcl_ChannelFlushProc( } return chanTypePtr->flushProc; } - + + /* *---------------------------------------------------------------------- * @@ -10838,7 +10956,8 @@ Tcl_ChannelHandlerProc( } return chanTypePtr->handlerProc; } - + + /* *---------------------------------------------------------------------- * @@ -10865,7 +10984,8 @@ Tcl_ChannelWideSeekProc( } return chanTypePtr->wideSeekProc; } - + + /* *---------------------------------------------------------------------- * @@ -10893,7 +11013,8 @@ Tcl_ChannelThreadActionProc( } return chanTypePtr->threadActionProc; } - + + /* *---------------------------------------------------------------------- * @@ -10929,7 +11050,8 @@ Tcl_SetChannelErrorInterp( } return; } - + + /* *---------------------------------------------------------------------- * @@ -10965,7 +11087,8 @@ Tcl_SetChannelError( } return; } - + + /* *---------------------------------------------------------------------- * @@ -11124,7 +11247,8 @@ FixLevelCode( ckfree(lvn); return msg; } - + + /* *---------------------------------------------------------------------- * @@ -11152,7 +11276,8 @@ Tcl_GetChannelErrorInterp( *msg = iPtr->chanMsg; iPtr->chanMsg = NULL; } - + + /* *---------------------------------------------------------------------- * @@ -11180,7 +11305,8 @@ Tcl_GetChannelError( *msg = statePtr->chanMsg; statePtr->chanMsg = NULL; } - + + /* *---------------------------------------------------------------------- * @@ -11208,7 +11334,8 @@ Tcl_ChannelTruncateProc( } return chanTypePtr->truncateProc; } - + + /* *---------------------------------------------------------------------- * @@ -11240,7 +11367,8 @@ DupChannelInternalRep( copyPtr->internalRep.twoPtrValue.ptr1 = resPtr; copyPtr->typePtr = srcPtr->typePtr; } - + + /* *---------------------------------------------------------------------- * @@ -11270,7 +11398,8 @@ FreeChannelInternalRep( Tcl_Release(resPtr->statePtr); ckfree(resPtr); } - + + #if 0 /* * For future debugging work, a simple function to print the flags of a @@ -11308,7 +11437,8 @@ DumpFlags( return 0; } #endif - + + /* * Local Variables: * mode: c -- cgit v0.12 From 47699b8fff2e41463af41ad4aaece58038550955 Mon Sep 17 00:00:00 2001 From: sebres Date: Fri, 22 Jul 2022 18:38:30 +0000 Subject: EOF seemed to reset INPUT_SAW_CR previously, so do it now explicitely (satisfying the test ?chan?io-6.46) --- generic/tclIO.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/generic/tclIO.c b/generic/tclIO.c index e102675..e03b9c5 100644 --- a/generic/tclIO.c +++ b/generic/tclIO.c @@ -4825,7 +4825,7 @@ Tcl_GetsObj( Tcl_SetObjLength(objPtr, oldLength); CommonGetsCleanup(chanPtr); copiedTotal = -1; - ResetFlag(statePtr, CHANNEL_BLOCKED); + ResetFlag(statePtr, CHANNEL_BLOCKED|INPUT_SAW_CR); goto done; } goto gotEOL; -- cgit v0.12 From f7aabfbd54bdcb775c6a96d9ca20548c7dc8f360 Mon Sep 17 00:00:00 2001 From: sebres Date: Fri, 22 Jul 2022 18:49:27 +0000 Subject: restore FF-char (fossil seems to loss form feed if commits with convertion from CRLF to LF) --- generic/tclIO.c | 387 +++++++++++++++++++------------------------------------- 1 file changed, 129 insertions(+), 258 deletions(-) diff --git a/generic/tclIO.c b/generic/tclIO.c index e03b9c5..376ab36 100644 --- a/generic/tclIO.c +++ b/generic/tclIO.c @@ -340,8 +340,7 @@ static const Tcl_ObjType chanObjType = { (((st)->csPtrW) && ((fl) & TCL_WRITABLE))) #define MAX_CHANNEL_BUFFER_SIZE (1024*1024) - - + /* *--------------------------------------------------------------------------- * @@ -511,8 +510,7 @@ ChanWrite( return chanPtr->typePtr->outputProc(chanPtr->instanceData, src, srcLen, errnoPtr); } - - + /* *--------------------------------------------------------------------------- * @@ -540,8 +538,7 @@ TclInitIOSubsystem(void) (void) TCL_TSD_INIT(&dataKey); } - - + /* *------------------------------------------------------------------------- * @@ -687,8 +684,7 @@ TclFinalizeIOSubsystem(void) TclpFinalizeSockets(); TclpFinalizePipes(); } - - + /* *---------------------------------------------------------------------- * @@ -729,8 +725,7 @@ Tcl_SetStdChannel( break; } } - - + /* *---------------------------------------------------------------------- * @@ -806,8 +801,7 @@ Tcl_GetStdChannel( } return channel; } - - + /* *---------------------------------------------------------------------- * @@ -845,8 +839,7 @@ Tcl_CreateCloseHandler( cbPtr->nextPtr = statePtr->closeCbPtr; statePtr->closeCbPtr = cbPtr; } - - + /* *---------------------------------------------------------------------- * @@ -891,8 +884,7 @@ Tcl_DeleteCloseHandler( cbPrevPtr = cbPtr; } } - - + /* *---------------------------------------------------------------------- * @@ -948,8 +940,7 @@ GetChannelTable( } return hTblPtr; } - - + /* *---------------------------------------------------------------------- * @@ -1039,8 +1030,7 @@ DeleteChannelTable( Tcl_DeleteHashTable(hTblPtr); ckfree(hTblPtr); } - - + /* *---------------------------------------------------------------------- * @@ -1096,8 +1086,7 @@ CheckForStdChannelsBeingClosed( } } } - - + /* *---------------------------------------------------------------------- * @@ -1130,8 +1119,7 @@ Tcl_IsStandardChannel( return 0; } } - - + /* *---------------------------------------------------------------------- * @@ -1188,8 +1176,7 @@ Tcl_RegisterChannel( } statePtr->refCount++; } - - + /* *---------------------------------------------------------------------- * @@ -1274,8 +1261,7 @@ Tcl_UnregisterChannel( } return TCL_OK; } - - + /* *---------------------------------------------------------------------- * @@ -1321,8 +1307,7 @@ Tcl_DetachChannel( return DetachChannel(interp, chan); } - - + /* *---------------------------------------------------------------------- * @@ -1395,8 +1380,7 @@ DetachChannel( return TCL_OK; } - - + /* *--------------------------------------------------------------------------- * @@ -1478,8 +1462,7 @@ Tcl_GetChannel( return (Tcl_Channel) chanPtr; } - - + /* *--------------------------------------------------------------------------- * @@ -1575,8 +1558,7 @@ TclGetChannelFromObj( return TCL_OK; } - - + /* *---------------------------------------------------------------------- * @@ -1784,8 +1766,7 @@ Tcl_CreateChannel( } return (Tcl_Channel) chanPtr; } - - + /* *---------------------------------------------------------------------- * @@ -2014,8 +1995,7 @@ ChannelFree( } chanPtr->typePtr = NULL; } - - + /* *---------------------------------------------------------------------- * @@ -2203,8 +2183,7 @@ Tcl_UnstackChannel( return TCL_OK; } - - + /* *---------------------------------------------------------------------- * @@ -2232,8 +2211,7 @@ Tcl_GetStackedChannel( return (Tcl_Channel) chanPtr->downChanPtr; } - - + /* *---------------------------------------------------------------------- * @@ -2261,8 +2239,7 @@ Tcl_GetTopChannel( return (Tcl_Channel) chanPtr->state->topChanPtr; } - - + /* *---------------------------------------------------------------------- * @@ -2288,8 +2265,7 @@ Tcl_GetChannelInstanceData( return chanPtr->instanceData; } - - + /* *---------------------------------------------------------------------- * @@ -2316,8 +2292,7 @@ Tcl_GetChannelThread( return chanPtr->state->managingThread; } - - + /* *---------------------------------------------------------------------- * @@ -2343,8 +2318,7 @@ Tcl_GetChannelType( return chanPtr->typePtr; } - - + /* *---------------------------------------------------------------------- * @@ -2372,8 +2346,7 @@ Tcl_GetChannelMode( return (statePtr->flags & (TCL_READABLE | TCL_WRITABLE)); } - - + /* *---------------------------------------------------------------------- * @@ -2400,8 +2373,7 @@ Tcl_GetChannelName( return statePtr->channelName; } - - + /* *---------------------------------------------------------------------- * @@ -2443,8 +2415,7 @@ Tcl_GetChannelHandle( } return result; } - - + /* *--------------------------------------------------------------------------- * @@ -2512,8 +2483,7 @@ IsShared( { return bufPtr->refCount > 1; } - - + /* *---------------------------------------------------------------------- * @@ -2602,8 +2572,7 @@ RecycleBuffer( bufPtr->nextAdded = BUFFER_PADDING; bufPtr->nextPtr = NULL; } - - + /* *---------------------------------------------------------------------- * @@ -2639,8 +2608,7 @@ DiscardOutputQueued( RecycleBuffer(statePtr, bufPtr, 0); } } - - + /* *---------------------------------------------------------------------- * @@ -2674,8 +2642,7 @@ CheckForDeadChannel( } return 1; } - - + /* *---------------------------------------------------------------------- * @@ -2977,8 +2944,7 @@ FlushChannel( TclChannelRelease((Tcl_Channel)chanPtr); return errorCode; } - - + /* *---------------------------------------------------------------------- * @@ -3159,8 +3125,7 @@ CloseChannel( return errorCode; } - - + /* *---------------------------------------------------------------------- * @@ -3275,8 +3240,7 @@ Tcl_CutChannel( /* Channel is not managed by any thread */ statePtr->managingThread = NULL; } - - + /* *---------------------------------------------------------------------- * @@ -3366,8 +3330,7 @@ Tcl_SpliceChannel( ChanThreadAction(chanPtr, TCL_CHANNEL_THREAD_INSERT); } } - - + /* *---------------------------------------------------------------------- * @@ -3561,8 +3524,7 @@ Tcl_Close( } return TCL_OK; } - - + /* *---------------------------------------------------------------------- * @@ -3696,8 +3658,7 @@ Tcl_CloseEx( return TCL_OK; } - - + /* *---------------------------------------------------------------------- * @@ -3773,8 +3734,7 @@ CloseWrite( return TCL_OK; } - - + /* *---------------------------------------------------------------------- * @@ -3910,8 +3870,7 @@ CloseChannelPart( ResetFlag(statePtr, flags & (TCL_READABLE | TCL_WRITABLE)); return TCL_OK; } - - + /* *---------------------------------------------------------------------- * @@ -4005,8 +3964,7 @@ Tcl_ClearChannelHandlers( } statePtr->scriptRecordPtr = NULL; } - - + /* *---------------------------------------------------------------------- * @@ -4060,8 +4018,7 @@ Tcl_Write( } return srcLen; } - - + /* *---------------------------------------------------------------------- * @@ -4118,8 +4075,7 @@ Tcl_WriteRaw( return written; } - - + /* *--------------------------------------------------------------------------- * @@ -4186,8 +4142,7 @@ Tcl_WriteChars( TclDecrRefCount(objPtr); return result; } - - + /* *--------------------------------------------------------------------------- * @@ -4241,8 +4196,7 @@ Tcl_WriteObj( return WriteChars(chanPtr, src, srcLen); } } - - + static void WillWrite( Channel *chanPtr) @@ -4257,8 +4211,7 @@ WillWrite( ChanSeek(chanPtr, -inputBuffered, SEEK_CUR, &ignore); } } - - + static int WillRead( Channel *chanPtr) @@ -4291,8 +4244,7 @@ WillRead( } return 0; } - - + /* *---------------------------------------------------------------------- * @@ -4492,8 +4444,7 @@ Write( return total; } - - + /* *--------------------------------------------------------------------------- * @@ -4532,8 +4483,7 @@ Tcl_Gets( TclDecrRefCount(objPtr); return charsStored; } - - + /* *--------------------------------------------------------------------------- * @@ -4946,8 +4896,7 @@ Tcl_GetsObj( TclChannelRelease((Tcl_Channel)chanPtr); return copiedTotal; } - - + /* *--------------------------------------------------------------------------- * @@ -5221,8 +5170,7 @@ TclGetsObjBinary( TclChannelRelease((Tcl_Channel)chanPtr); return copiedTotal; } - - + /* *--------------------------------------------------------------------------- * @@ -5264,8 +5212,7 @@ GetBinaryEncoding() } return tsdPtr->binaryEncoding; } - - + /* *--------------------------------------------------------------------------- * @@ -5458,8 +5405,7 @@ FilterInputBytes( gsPtr->bufPtr = bufPtr; return 0; } - - + /* *--------------------------------------------------------------------------- * @@ -5544,8 +5490,7 @@ PeekAhead( gsPtr->bytesWrote = 0; gsPtr->charsWrote = 0; } - - + /* *--------------------------------------------------------------------------- * @@ -5608,8 +5553,7 @@ CommonGetsCleanup( } } } - - + /* *---------------------------------------------------------------------- * @@ -5654,8 +5598,7 @@ Tcl_Read( return DoRead(chanPtr, dst, bytesToRead, 0); } - - + /* *---------------------------------------------------------------------- * @@ -5773,8 +5716,7 @@ Tcl_ReadRaw( } return copied; } - - + /* *--------------------------------------------------------------------------- * @@ -6029,8 +5971,7 @@ DoReadChars( TclChannelRelease((Tcl_Channel)chanPtr); return copied; } - - + /* *--------------------------------------------------------------------------- * @@ -6079,8 +6020,7 @@ ReadBytes( bufPtr->nextRemoved += toRead; return toRead; } - - + /* *--------------------------------------------------------------------------- * @@ -6483,8 +6423,7 @@ ReadChars( return numChars; } } - - + /* *--------------------------------------------------------------------------- * @@ -6660,8 +6599,7 @@ TranslateInputEOL( ResetFlag(statePtr, CHANNEL_BLOCKED|INPUT_SAW_CR); } } - - + /* *---------------------------------------------------------------------- * @@ -6749,8 +6687,7 @@ Tcl_Ungets( UpdateInterest(chanPtr); return len; } - - + /* *---------------------------------------------------------------------- * @@ -6794,8 +6731,7 @@ Tcl_Flush( return TCL_OK; } - - + /* *---------------------------------------------------------------------- * @@ -6842,8 +6778,7 @@ DiscardInputQueued( statePtr->saveInBufPtr = NULL; } } - - + /* *--------------------------------------------------------------------------- * @@ -6992,8 +6927,7 @@ GetInput( ReleaseChannelBuffer(bufPtr); return result; } - - + /* *---------------------------------------------------------------------- * @@ -7161,8 +7095,7 @@ Tcl_Seek( return curPos; } - - + /* *---------------------------------------------------------------------- * @@ -7251,8 +7184,7 @@ Tcl_Tell( } return curPos + outputBuffered; } - - + /* *--------------------------------------------------------------------------- * @@ -7293,8 +7225,7 @@ Tcl_TellOld( return (int) Tcl_WideAsLong(wResult); } - - + /* *--------------------------------------------------------------------------- * @@ -7366,8 +7297,7 @@ Tcl_TruncateChannel( } return TCL_OK; } - - + /* *--------------------------------------------------------------------------- * @@ -7455,8 +7385,7 @@ CheckChannelErrors( return 0; } - - + /* *---------------------------------------------------------------------- * @@ -7482,8 +7411,7 @@ Tcl_Eof( return GotFlag(statePtr, CHANNEL_EOF) ? 1 : 0; } - - + /* *---------------------------------------------------------------------- * @@ -7509,8 +7437,7 @@ Tcl_InputBlocked( return GotFlag(statePtr, CHANNEL_BLOCKED) ? 1 : 0; } - - + /* *---------------------------------------------------------------------- * @@ -7554,8 +7481,7 @@ Tcl_InputBuffered( return bytesBuffered; } - - + /* *---------------------------------------------------------------------- * @@ -7597,8 +7523,7 @@ Tcl_OutputBuffered( return bytesBuffered; } - - + /* *---------------------------------------------------------------------- * @@ -7633,8 +7558,7 @@ Tcl_ChannelBuffered( return bytesBuffered; } - - + /* *---------------------------------------------------------------------- * @@ -7692,8 +7616,7 @@ Tcl_SetChannelBufferSize( statePtr->inQueueTail = NULL; } } - - + /* *---------------------------------------------------------------------- * @@ -7720,8 +7643,7 @@ Tcl_GetChannelBufferSize( return statePtr->bufSize; } - - + /* *---------------------------------------------------------------------- * @@ -7792,8 +7714,7 @@ Tcl_BadChannelOption( Tcl_SetErrno(EINVAL); return TCL_ERROR; } - - + /* *---------------------------------------------------------------------- * @@ -8025,8 +7946,7 @@ Tcl_GetChannelOption( return Tcl_BadChannelOption(interp, optionName, NULL); } } - - + /* *--------------------------------------------------------------------------- * @@ -8328,8 +8248,7 @@ Tcl_SetChannelOption( return TCL_OK; } - - + /* *---------------------------------------------------------------------- * @@ -8383,8 +8302,7 @@ CleanupChannelHandlers( } } } - - + /* *---------------------------------------------------------------------- * @@ -8542,8 +8460,7 @@ done: tsdPtr->nestedHandlerPtr = nh.nestedHandlerPtr; } - - + /* *---------------------------------------------------------------------- * @@ -8644,8 +8561,7 @@ UpdateInterest( } ChanWatch(chanPtr, mask); } - - + /* *---------------------------------------------------------------------- * @@ -8690,8 +8606,7 @@ ChannelTimerProc( UpdateInterest(chanPtr); } } - - + /* *---------------------------------------------------------------------- * @@ -8771,8 +8686,7 @@ Tcl_CreateChannelHandler( UpdateInterest(statePtr->topChanPtr); } - - + /* *---------------------------------------------------------------------- * @@ -8862,8 +8776,7 @@ Tcl_DeleteChannelHandler( UpdateInterest(statePtr->topChanPtr); } - - + /* *---------------------------------------------------------------------- * @@ -8914,8 +8827,7 @@ DeleteScriptRecord( } } } - - + /* *---------------------------------------------------------------------- * @@ -8983,8 +8895,7 @@ CreateScriptRecord( TclChannelEventScriptInvoker, esPtr); } } - - + /* *---------------------------------------------------------------------- * @@ -9052,8 +8963,7 @@ TclChannelEventScriptInvoker( TclChannelRelease((Tcl_Channel)chanPtr); Tcl_Release(interp); } - - + /* *---------------------------------------------------------------------- * @@ -9151,8 +9061,7 @@ Tcl_FileEventObjCmd( return TCL_OK; } - - + /* *---------------------------------------------------------------------- * @@ -9179,8 +9088,7 @@ ZeroTransferTimerProc( */ CopyData((CopyState *)clientData, 0); } - - + /* *---------------------------------------------------------------------- * @@ -9333,8 +9241,7 @@ TclCopyChannel( return CopyData(csPtr, 0); } - - + /* *---------------------------------------------------------------------- * @@ -9885,8 +9792,7 @@ CopyData( } return result; } - - + /* *---------------------------------------------------------------------- * @@ -10132,8 +10038,7 @@ DoRead( TclChannelRelease((Tcl_Channel)chanPtr); return (int)(p - dst); } - - + /* *---------------------------------------------------------------------- * @@ -10159,8 +10064,7 @@ CopyEventProc( { (void) CopyData((CopyState *)clientData, mask); } - - + /* *---------------------------------------------------------------------- * @@ -10229,8 +10133,7 @@ StopCopy( outStatePtr->csPtrW = NULL; ckfree(csPtr); } - - + /* *---------------------------------------------------------------------- * @@ -10279,8 +10182,7 @@ StackSetBlockMode( } return 0; } - - + /* *---------------------------------------------------------------------- * @@ -10348,8 +10250,7 @@ SetBlockMode( } return TCL_OK; } - - + /* *---------------------------------------------------------------------- * @@ -10372,8 +10273,7 @@ Tcl_GetChannelNames( { return Tcl_GetChannelNamesEx(interp, NULL); } - - + /* *---------------------------------------------------------------------- * @@ -10459,8 +10359,7 @@ Tcl_GetChannelNamesEx( Tcl_SetObjResult(interp, resultPtr); return TCL_OK; } - - + /* *---------------------------------------------------------------------- * @@ -10510,8 +10409,7 @@ Tcl_IsChannelRegistered( return 1; } - - + /* *---------------------------------------------------------------------- * @@ -10537,8 +10435,7 @@ Tcl_IsChannelShared( return ((statePtr->refCount > 1) ? 1 : 0); } - - + /* *---------------------------------------------------------------------- * @@ -10587,8 +10484,7 @@ Tcl_IsChannelExisting( return 0; } - - + /* *---------------------------------------------------------------------- * @@ -10611,8 +10507,7 @@ Tcl_ChannelName( { return chanTypePtr->typeName; } - - + /* *---------------------------------------------------------------------- * @@ -10644,8 +10539,7 @@ Tcl_ChannelVersion( } return chanTypePtr->version; } - - + /* *---------------------------------------------------------------------- * @@ -10675,8 +10569,7 @@ Tcl_ChannelBlockModeProc( return chanTypePtr->blockModeProc; } - - + /* *---------------------------------------------------------------------- * @@ -10700,8 +10593,7 @@ Tcl_ChannelCloseProc( { return chanTypePtr->closeProc; } - - + /* *---------------------------------------------------------------------- * @@ -10725,8 +10617,7 @@ Tcl_ChannelClose2Proc( { return chanTypePtr->close2Proc; } - - + /* *---------------------------------------------------------------------- * @@ -10750,8 +10641,7 @@ Tcl_ChannelInputProc( { return chanTypePtr->inputProc; } - - + /* *---------------------------------------------------------------------- * @@ -10775,8 +10665,7 @@ Tcl_ChannelOutputProc( { return chanTypePtr->outputProc; } - - + /* *---------------------------------------------------------------------- * @@ -10800,8 +10689,7 @@ Tcl_ChannelSeekProc( { return chanTypePtr->seekProc; } - - + /* *---------------------------------------------------------------------- * @@ -10825,8 +10713,7 @@ Tcl_ChannelSetOptionProc( { return chanTypePtr->setOptionProc; } - - + /* *---------------------------------------------------------------------- * @@ -10850,8 +10737,7 @@ Tcl_ChannelGetOptionProc( { return chanTypePtr->getOptionProc; } - - + /* *---------------------------------------------------------------------- * @@ -10875,8 +10761,7 @@ Tcl_ChannelWatchProc( { return chanTypePtr->watchProc; } - - + /* *---------------------------------------------------------------------- * @@ -10900,8 +10785,7 @@ Tcl_ChannelGetHandleProc( { return chanTypePtr->getHandleProc; } - - + /* *---------------------------------------------------------------------- * @@ -10928,8 +10812,7 @@ Tcl_ChannelFlushProc( } return chanTypePtr->flushProc; } - - + /* *---------------------------------------------------------------------- * @@ -10956,8 +10839,7 @@ Tcl_ChannelHandlerProc( } return chanTypePtr->handlerProc; } - - + /* *---------------------------------------------------------------------- * @@ -10984,8 +10866,7 @@ Tcl_ChannelWideSeekProc( } return chanTypePtr->wideSeekProc; } - - + /* *---------------------------------------------------------------------- * @@ -11013,8 +10894,7 @@ Tcl_ChannelThreadActionProc( } return chanTypePtr->threadActionProc; } - - + /* *---------------------------------------------------------------------- * @@ -11050,8 +10930,7 @@ Tcl_SetChannelErrorInterp( } return; } - - + /* *---------------------------------------------------------------------- * @@ -11087,8 +10966,7 @@ Tcl_SetChannelError( } return; } - - + /* *---------------------------------------------------------------------- * @@ -11247,8 +11125,7 @@ FixLevelCode( ckfree(lvn); return msg; } - - + /* *---------------------------------------------------------------------- * @@ -11276,8 +11153,7 @@ Tcl_GetChannelErrorInterp( *msg = iPtr->chanMsg; iPtr->chanMsg = NULL; } - - + /* *---------------------------------------------------------------------- * @@ -11305,8 +11181,7 @@ Tcl_GetChannelError( *msg = statePtr->chanMsg; statePtr->chanMsg = NULL; } - - + /* *---------------------------------------------------------------------- * @@ -11334,8 +11209,7 @@ Tcl_ChannelTruncateProc( } return chanTypePtr->truncateProc; } - - + /* *---------------------------------------------------------------------- * @@ -11367,8 +11241,7 @@ DupChannelInternalRep( copyPtr->internalRep.twoPtrValue.ptr1 = resPtr; copyPtr->typePtr = srcPtr->typePtr; } - - + /* *---------------------------------------------------------------------- * @@ -11398,8 +11271,7 @@ FreeChannelInternalRep( Tcl_Release(resPtr->statePtr); ckfree(resPtr); } - - + #if 0 /* * For future debugging work, a simple function to print the flags of a @@ -11437,8 +11309,7 @@ DumpFlags( return 0; } #endif - - + /* * Local Variables: * mode: c -- cgit v0.12 From 49867f2fd30037c8b87e75e9bef5c7424edfe15f Mon Sep 17 00:00:00 2001 From: sebres Date: Fri, 22 Jul 2022 19:19:26 +0000 Subject: =?UTF-8?q?correctly=20show=20the=20execution=20time=20unit=20by?= =?UTF-8?q?=20usec=20(=C2=B5s)=20if=20testing=20on=20systems=20with=20not?= =?UTF-8?q?=20utf-8=20default=20system=20encoding=20(e.=20g.=20windows)?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- library/tcltest/tcltest.tcl | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/library/tcltest/tcltest.tcl b/library/tcltest/tcltest.tcl index 72c7b94..9124699 100644 --- a/library/tcltest/tcltest.tcl +++ b/library/tcltest/tcltest.tcl @@ -2141,7 +2141,7 @@ proc tcltest::test {name description args} { if {[IsVerbose msec] || [IsVerbose usec]} { set t [expr {[clock microseconds] - $timeStart}] if {[IsVerbose usec]} { - puts [outputChannel] "++++ $name took $t μs" + puts [outputChannel] "++++ $name took $t \xB5s" } if {[IsVerbose msec]} { puts [outputChannel] "++++ $name took [expr {round($t/1000.)}] ms" -- cgit v0.12 From 518ff0b0d9cbf5887984531c88f896be53454d2e Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 22 Jul 2022 21:42:24 +0000 Subject: tcltest 2.5.4 -> 2.5.5 --- library/tcltest/pkgIndex.tcl | 2 +- library/tcltest/tcltest.tcl | 2 +- unix/Makefile.in | 4 ++-- win/Makefile.in | 4 ++-- 4 files changed, 6 insertions(+), 6 deletions(-) diff --git a/library/tcltest/pkgIndex.tcl b/library/tcltest/pkgIndex.tcl index da78df0..18b05e5 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.4 [list source [file join $dir tcltest.tcl]] +package ifneeded tcltest 2.5.5 [list source [file join $dir tcltest.tcl]] diff --git a/library/tcltest/tcltest.tcl b/library/tcltest/tcltest.tcl index 9124699..7344f9f 100644 --- a/library/tcltest/tcltest.tcl +++ b/library/tcltest/tcltest.tcl @@ -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.4 + variable Version 2.5.5 # Compatibility support for dumb variables defined in tcltest 1 # Do not use these. Call [package provide Tcl] and [info patchlevel] diff --git a/unix/Makefile.in b/unix/Makefile.in index 23383cd..316ec22 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.4 as a Tcl Module" + @echo "Installing package tcltest 2.5.5 as a Tcl Module" @$(INSTALL_DATA) $(TOP_DIR)/library/tcltest/tcltest.tcl \ - "$(MODULE_INSTALL_DIR)/8.5/tcltest-2.5.4.tm" + "$(MODULE_INSTALL_DIR)/8.5/tcltest-2.5.5.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 08fb1b5..73387e3 100644 --- a/win/Makefile.in +++ b/win/Makefile.in @@ -744,8 +744,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.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 tcltest 2.5.5 as a Tcl Module"; + @$(COPY) $(ROOT_DIR)/library/tcltest/tcltest.tcl "$(MODULE_INSTALL_DIR)/8.5/tcltest-2.5.5.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 f0c979fba7afa5d2a2d9b3c9be2f2fdd6a5ed7f7 Mon Sep 17 00:00:00 2001 From: apnadkarni Date: Mon, 25 Jul 2022 06:51:54 +0000 Subject: Tests for spanned lists with shared reps --- generic/tclListObj.c | 22 +++--- tests/listRep.test | 208 +++++++++++++++++++++++++++++++++++++++++++++++++-- 2 files changed, 215 insertions(+), 15 deletions(-) diff --git a/generic/tclListObj.c b/generic/tclListObj.c index a76760c..529a790 100644 --- a/generic/tclListObj.c +++ b/generic/tclListObj.c @@ -1447,7 +1447,7 @@ ListRepRange( /* Take the opportunity to garbage collect */ /* TODO - we probably do not need the preserveSrcRep here unlike later */ if (!preserveSrcRep) { - /* T:listrep-1.{4,5,8,9},2.{4,5,6,7},3.{15,16,17,18} */ + /* T:listrep-1.{4,5,8,9},2.{4,5,6,7},3.{15,16,17,18},4.{7,8} */ ListRepFreeUnreferenced(srcRepPtr); } @@ -1516,7 +1516,7 @@ ListRepRange( *rangeRepPtr = *srcRepPtr; } else { /* Span not present or is shared. */ - /* T:listrep-1.5,2.{5,7} */ + /* T:listrep-1.5,2.{5,7},4.{7,8} */ rangeRepPtr->storePtr = srcRepPtr->storePtr; rangeRepPtr->spanPtr = ListSpanNew(spanStart, rangeLen); } @@ -1527,7 +1527,7 @@ ListRepRange( * is mandated. */ if (!preserveSrcRep) { - /* T:listrep-2.{5,7},3.{16,18} */ + /* T:listrep-2.{5,7},3.{16,18},4.{7,8} */ ListRepFreeUnreferenced(rangeRepPtr); } } else if (preserveSrcRep || ListRepIsShared(srcRepPtr)) { @@ -1868,12 +1868,13 @@ Tcl_ListObjAppendList( LIST_ASSERT(listRep.storePtr->numAllocated >= finalLen); if (toLen) { - /* T:listrep-2.{2,9} */ + /* T:listrep-2.{2,9},4.5 */ ObjArrayCopy(ListRepSlotPtr(&listRep, 0), toLen, toObjv); } ObjArrayCopy(ListRepSlotPtr(&listRep, toLen), elemCount, elemObjv); listRep.storePtr->numUsed = finalLen; if (listRep.spanPtr) { + /* T:listrep-4.5 */ LIST_ASSERT(listRep.spanPtr->spanStart == listRep.storePtr->firstUsed); listRep.spanPtr->spanLength = finalLen; } @@ -2149,14 +2150,14 @@ Tcl_ListObjReplace( } if (first == 0) { /* Delete from front, so return tail. */ - /* T:listrep-1.{4,5},2.{4,5},3.{15,16} */ + /* T:listrep-1.{4,5},2.{4,5},3.{15,16},4.7 */ ListRep tailRep; ListRepRange(&listRep, numToDelete, origListLen-1, 0, &tailRep); ListObjReplaceRepAndInvalidate(listObj, &tailRep); return TCL_OK; } else if ((first+numToDelete) >= origListLen) { /* Delete from tail, so return head */ - /* T:listrep-1.{8,9},2.{6,7},3.{17,18} */ + /* T:listrep-1.{8,9},2.{6,7},3.{17,18},4.8 */ ListRep headRep; ListRepRange(&listRep, 0, first-1, 0, &headRep); ListObjReplaceRepAndInvalidate(listObj, &headRep); @@ -2209,6 +2210,7 @@ Tcl_ListObjReplace( if (listRep.storePtr->firstUsed == 0) { listRep.spanPtr = NULL; } else { + /* T:listrep-4.3 */ listRep.spanPtr = ListSpanNew(listRep.storePtr->firstUsed, newLen); } @@ -2273,24 +2275,24 @@ Tcl_ListObjReplace( &newRep); toObjs = ListRepSlotPtr(&newRep, 0); if (leadSegmentLen > 0) { - /* T:listrep-2.{2,3,13,14,15,16,17,18} */ + /* T:listrep-2.{2,3,13:18},4.{6,9,13:18} */ ObjArrayCopy(toObjs, leadSegmentLen, listObjs); } if (numToInsert > 0) { - /* T:listrep-2.{1,2,3,10,11,12,13,14,15,16,17,18} */ + /* T:listrep-2.{1,2,3,10:18},4.{1,2,4,6,10:18} */ ObjArrayCopy(&toObjs[leadSegmentLen], numToInsert, insertObjs); } if (tailSegmentLen > 0) { - /* T:listrep-2.{1,2,3,10,11,12,13,14,15} */ + /* T:listrep-2.{1,2,3,10:15},4.{1,2,4,6,9:12,16:18} */ ObjArrayCopy(&toObjs[leadSegmentLen + numToInsert], tailSegmentLen, &listObjs[leadSegmentLen+numToDelete]); } newRep.storePtr->numUsed = origListLen + lenChange; if (newRep.spanPtr) { - /* T:listrep-2.{1,2,3,10,11,12,13,14,15,16,17,18} */ + /* T:listrep-2.{1,2,3,10:18},4.{1,2,4,6,9:18} */ newRep.spanPtr->spanLength = newRep.storePtr->numUsed; } LISTREP_CHECK(&newRep); diff --git a/tests/listRep.test b/tests/listRep.test index 5686597..9937f3c 100644 --- a/tests/listRep.test +++ b/tests/listRep.test @@ -30,7 +30,8 @@ if {"::tcltest" ni [namespace children]} { catch [list package require -exact tcl::test [info patchlevel]] testConstraint testlistrep [llength [info commands testlistrep]] -interp alias {} describe {} testlistrep describe + +proc describe {l args} {dict get [testlistrep describe $l] {*}$args} proc irange {first last} { set l {} @@ -82,6 +83,9 @@ proc spaceEqual {l} { set diff [expr {$leadSpace - $tailSpace}] return [expr {$diff >= -1 && $diff <= 1}] } +proc sameStore {l1 l2} { + expr {[describe $l1 store memoryAddress] == [describe $l2 store memoryAddress]} +} proc hasSpan {l args} { # Returns 1 if list has a span. If args are specified, they are checked with # span values (start and length) @@ -149,6 +153,13 @@ proc freeSpaceTail {{len 8} {tail 3}} {return [testlistrep new $len 0 $tail]} proc freeSpaceBoth {{len 8} {lead 3} {tail 3}} { return [testlistrep new $len $lead $tail] } +proc listWithZombies {{len 1000} {leadZombies 100} {tailZombies 100}} { + # Returns an unshared listrep with zombies in front and back + + # DON'T COMBINE NEXT TWO STATEMENTS ELSE ZOMBIES ARE FREED + set l [freeSpaceNone [expr {$len+$leadZombies+$tailZombies}]] + return [lrange $l $leadZombies [expr {$leadZombies+$len-1}]] +} # Just ensure above stubs return what's expected if {[testConstraint testlistrep]} { @@ -156,6 +167,10 @@ if {[testConstraint testlistrep]} { assertListrep [freeSpaceLead] 8 11 3 0 1 assertListrep [freeSpaceTail] 8 11 0 3 1 assertListrep [freeSpaceBoth] 8 14 3 3 1 + assertListrep [listWithZombies] 1000 1200 0 0 1 + if {![hasSpan [listWithZombies]] || [dict get [testlistrep describe [listWithZombies]] span spanStart] == 0} { + error "listWithZombies span missing or span start is at 0." + } } # Define some variables for some indices because the Tcl compiler will do some @@ -912,18 +927,201 @@ test listrep-3.41 { list $l [leadSpace $l] [tailSpace $l] } -result [list {0 8 9 10 11 12 2 3 4 5 6 7} 1 11] - - - # # 4.* - tests on shared spanned lists +test listrep-4.1 { + Inserts in front of shared spanned list with used elements in lead space + creates a new list rep without more lead space than tail space. +} -constraints testlistrep -body { + set master [freeSpaceNone 1000] + set spanl [lrange $master $two $end-2] + set l [linsert $spanl $zero -1] + list $master $spanl $l [leadSpaceMore $l] [hasSpan $l] [repStoreRefCount $master] [repStoreRefCount $spanl] [repStoreRefCount $l] +} -result [list [irange 0 999] [irange 2 997] [list -1 {*}[irange 2 997]] 1 1 2 2 1] + +test listrep-4.2 { + Inserts in front of shared spanned list with orphaned leading elements + allocate a new list rep with more lead space than tail space. + TODO - ideally this should garbage collect the orphans and reuse the lead space + but that needs a "lprepend" command else the listrep operand is shared and hence + orphans cannot be freed +} -constraints testlistrep -body { + set master [freeSpaceLead 1000 100] + set spanl [lrange $master $two $end-2] + unset master; # So elements at 0, 1 are not used + set l [linsert $spanl $zero -1] + list $spanl $l [sameStore $spanl $l] [leadSpaceMore $l] [hasSpan $l] [repStoreRefCount $spanl] [repStoreRefCount $l] +} -result [list [irange 2 997] [list -1 {*}[irange 2 997]] 0 1 1 1 1] + +test listrep-4.3 { + Inserts in front of shared spanned list where span is at front of used + space reuses the same list store. +} -constraints testlistrep -body { + set master [freeSpaceLead 1000 100] + set spanl [lrange $master $zero $end-2] + set l [linsert $spanl $zero -1] + list $spanl $l [sameStore $spanl $l] [leadSpace $l] [tailSpace $l] [hasSpan $l] [repStoreRefCount $spanl] [repStoreRefCount $l] +} -result [list [irange 0 997] [irange -1 997] 1 99 0 1 3 3] + +test listrep-4.4 { + Inserts in front of shared spanned list where span is at front of used + space allocates new listrep if lead space insufficient even if total free space + is sufficient. New listrep should have more lead space than tail space. +} -constraints testlistrep -body { + set master [freeSpaceBoth 1000 2] + set spanl [lrange $master $zero $end-2] + set l [linsert $spanl $zero -3 -2 -1] + list $spanl $l [sameStore $spanl $l] [leadSpaceMore $l] [hasSpan $l] [repStoreRefCount $spanl] [repStoreRefCount $l] +} -result [list [irange 0 997] [irange -3 997] 0 1 1 2 1] + +test listrep-4.5 { + Inserts in back of shared spanned list where span is at end of used space + still allocates a new listrep and trailing space is more than leading space +} -constraints testlistrep -body { + set master [freeSpaceBoth 1000 2] + set spanl [lrange $master $two $end] + set l [linsert $spanl $end 1000] + list $spanl $l [sameStore $spanl $l] [tailSpaceMore $l] [hasSpan $l] [repStoreRefCount $spanl] [repStoreRefCount $l] +} -result [list [irange 2 999] [irange 2 1000] 0 1 1 2 1] + +test listrep-4.6 { + Inserts in middle of shared spanned list allocates a new listrep with equal + lead and tail space +} -constraints testlistrep -body { + set master [freeSpaceBoth 1000 2] + set spanl [lrange $master $two $end-2] + set i 200 + set l [linsert $spanl $i 1000] + list $spanl $l [sameStore $spanl $l] [spaceEqual $l] [hasSpan $l] [repStoreRefCount $spanl] [repStoreRefCount $l] +} -result [list [irange 2 997] [concat [irange 2 201] 1000 [irange 202 997]] 0 1 1 2 1] + +test listrep-4.7 { + Deletes from front of shared spanned list do not create a new allocation +} -constraints testlistrep -body { + set master [freeSpaceNone 1000] + set spanl [lrange $master $two $end-2] + set l [lreplace $spanl $zero $one] + list $spanl $l [sameStore $spanl $l] [hasSpan $l] [repStoreRefCount $spanl] [repStoreRefCount $l] +} -result [list [irange 2 997] [irange 4 997] 1 1 3 3] + +test listrep-4.8 { + Deletes from end of shared spanned list do not create a new allocation +} -constraints testlistrep -body { + set master [freeSpaceNone 1000] + set spanl [lrange $master $two $end-2] + set l [lreplace $spanl $end-1 $end] + list $spanl $l [sameStore $spanl $l] [hasSpan $l] [repStoreRefCount $spanl] [repStoreRefCount $l] +} -result [list [irange 2 997] [irange 2 995] 1 1 3 3] + +test listrep-4.9 { + Deletes from middle of shared spanned list creates a new allocation with + equal free space at front and back +} -constraints testlistrep -body { + set master [freeSpaceNone 1000] + set spanl [lrange $master $two $end-2] + set i 500 + set l [lreplace $spanl $i $i] + list $spanl $l [sameStore $spanl $l] [hasSpan $l] [spaceEqual $l] [repStoreRefCount $spanl] [repStoreRefCount $l] +} -result [list [irange 2 997] [concat [irange 2 501] [irange 503 997]] 0 1 1 2 1] + +test listrep-4.10 { + Replacements with same number of elements at front of shared spanned list + create a new allocation with more space in front +} -constraints testlistrep -body { + set master [freeSpaceNone 1000] + set spanl [lrange $master $two $end-2] + set l [lreplace $spanl $zero $one -2 -1] + list $spanl $l [sameStore $spanl $l] [leadSpaceMore $l] [hasSpan $l] [repStoreRefCount $spanl] [repStoreRefCount $l] +} -result [list [irange 2 997] [concat {-2 -1} [irange 4 997]] 0 1 1 2 1] + +test listrep-4.11 { + Replacements with fewer elements at front of shared spanned list + create a new allocation with more space in front +} -constraints testlistrep -body { + set master [freeSpaceNone 1000] + set spanl [lrange $master $two $end-2] + set l [lreplace $spanl $zero $one -1] + list $spanl $l [sameStore $spanl $l] [leadSpaceMore $l] [hasSpan $l] [repStoreRefCount $spanl] [repStoreRefCount $l] +} -result [list [irange 2 997] [concat {-1} [irange 4 997]] 0 1 1 2 1] + +test listrep-4.12 { + Replacements with more elements at front of shared spanned list + create a new allocation with more space in front +} -constraints testlistrep -body { + set master [freeSpaceNone 1000] + set spanl [lrange $master $two $end-2] + set l [lreplace $spanl $zero $one -3 -2 -1] + list $spanl $l [sameStore $spanl $l] [leadSpaceMore $l] [hasSpan $l] [repStoreRefCount $spanl] [repStoreRefCount $l] +} -result [list [irange 2 997] [concat {-3 -2 -1} [irange 4 997]] 0 1 1 2 1] + +test listrep-4.13 { + Replacements with same number of elements at back of shared spanned list + create a new allocation with more space in back +} -constraints testlistrep -body { + set master [freeSpaceNone 1000] + set spanl [lrange $master $two $end-2] + set l [lreplace $spanl $end-1 $end 1000 1001] + list $spanl $l [sameStore $spanl $l] [tailSpaceMore $l] [hasSpan $l] [repStoreRefCount $spanl] [repStoreRefCount $l] +} -result [list [irange 2 997] [concat [irange 2 995] {1000 1001}] 0 1 1 2 1] + +test listrep-4.14 { + Replacements with fewer elements at back of shared spanned list + create a new allocation with more space in back +} -constraints testlistrep -body { + set master [freeSpaceNone 1000] + set spanl [lrange $master $two $end-2] + set l [lreplace $spanl $end-1 $end 1000] + list $spanl $l [sameStore $spanl $l] [tailSpaceMore $l] [hasSpan $l] [repStoreRefCount $spanl] [repStoreRefCount $l] +} -result [list [irange 2 997] [concat [irange 2 995] {1000}] 0 1 1 2 1] + +test listrep-4.15 { + Replacements with more elements at back of shared spanned list + create a new allocation with more space in back +} -constraints testlistrep -body { + set master [freeSpaceNone 1000] + set spanl [lrange $master $two $end-2] + set l [lreplace $spanl $end-1 $end 1000 1001 1002] + list $spanl $l [sameStore $spanl $l] [tailSpaceMore $l] [hasSpan $l] [repStoreRefCount $spanl] [repStoreRefCount $l] +} -result [list [irange 2 997] [concat [irange 2 995] {1000 1001 1002}] 0 1 1 2 1] + +test listrep-4.16 { + Replacements with same number of elements in middle of shared spanned list + create a new allocation with equal lead and tail sapce +} -constraints testlistrep -body { + set master [freeSpaceNone 1000] + set spanl [lrange $master $two $end-2] + set l [lreplace $spanl $one $two -2 -1] + list $spanl $l [sameStore $spanl $l] [spaceEqual $l] [hasSpan $l] [repStoreRefCount $spanl] [repStoreRefCount $l] +} -result [list [irange 2 997] [concat {2 -2 -1} [irange 5 997]] 0 1 1 2 1] + +test listrep-4.17 { + Replacements with fewer elements in middle of shared spanned list + create a new allocation with equal lead and tail sapce +} -constraints testlistrep -body { + set master [freeSpaceNone 1000] + set spanl [lrange $master $two $end-2] + set l [lreplace $spanl $end-2 $end-1 1000] + list $spanl $l [sameStore $spanl $l] [spaceEqual $l] [hasSpan $l] [repStoreRefCount $spanl] [repStoreRefCount $l] +} -result [list [irange 2 997] [concat [irange 2 994] {1000 997}] 0 1 1 2 1] + +test listrep-4.18 { + Replacements with more elements in middle of shared spanned list + create a new allocation with equal lead and tail sapce +} -constraints testlistrep -body { + set master [freeSpaceNone 1000] + set spanl [lrange $master $two $end-2] + set l [lreplace $spanl $end-2 $end-1 1000 1001 1002] + list $spanl $l [sameStore $spanl $l] [spaceEqual $l] [hasSpan $l] [repStoreRefCount $spanl] [repStoreRefCount $l] +} -result [list [irange 2 997] [concat [irange 2 994] {1000 1001 1002 997}] 0 1 1 2 1] + # TBD - tests when tcl-obj is shared but listrep is not (lappend, lset etc.) # TBD - range and subrange tests # - spanned and unspanned +# TBD - zombie tests # -# Special case - nested lremove (does seem tested even in 8.6) +# Special case - nested lremove (does not seem tested in 8.6) ::tcltest::cleanupTests return -- cgit v0.12 From 62e24a0269129ae00a2ad1aab8ed9667af46f0b8 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 25 Jul 2022 13:57:37 +0000 Subject: execvpw/seteuidw don't exist. Fix some other signatures in compat/unistd.h --- compat/unistd.h | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/compat/unistd.h b/compat/unistd.h index a8f14f2..1725590 100644 --- a/compat/unistd.h +++ b/compat/unistd.h @@ -17,7 +17,7 @@ #include #ifndef NULL -#define NULL 0 +# define NULL 0 #endif /* @@ -35,9 +35,9 @@ extern int dup2(int oldfd, int newfd); extern int execl(const char *path, ...); extern int execle(const char *path, ...); extern int execlp(const char *file, ...); -extern int execv(const char *path, char **argv); -extern int execve(const char *path, char **argv, char **envp); -extern int execvpw(const char *file, char **argv); +extern int execv(const char *path, char *const argv[]); +extern int execve(const char *path, char *const argv[], char *const *envp); +extern int execvp(const char *file, char *const argv[]); extern pid_t fork(void); extern char * getcwd(char *buf, size_t size); extern gid_t getegid(void); @@ -65,7 +65,7 @@ extern int ftruncate(int fd, unsigned long length); extern int ioctl(int fd, int request, ...); extern int readlink(const char *path, char *buf, int bufsize); extern int setegid(gid_t group); -extern int seteuidw(uid_t user); +extern int seteuid(uid_t user); extern int setreuid(int ruid, int euid); extern int symlink(const char *, const char *); extern int ttyslot(void); -- cgit v0.12 From 856edbc25be9401b87ea00c346b7bea728e8c0dd Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 25 Jul 2022 21:12:10 +0000 Subject: Make testapplylambda work on Windows with gcc too --- tests/apply.test | 2 ++ 1 file changed, 2 insertions(+) diff --git a/tests/apply.test b/tests/apply.test index 32dff08..a5f1f8f 100644 --- a/tests/apply.test +++ b/tests/apply.test @@ -16,6 +16,8 @@ if {"::tcltest" ni [namespace children]} { package require tcltest 2.5 namespace import -force ::tcltest::* } +::tcltest::loadTestedCommands +catch [list package require -exact tcl::test [info patchlevel]] if {[info commands ::apply] eq {}} { return -- cgit v0.12 From 9e77fc653dc92b552b78bc64523cfaf1a2166d04 Mon Sep 17 00:00:00 2001 From: apnadkarni Date: Tue, 26 Jul 2022 17:20:16 +0000 Subject: List rep tests for lappend,lset,lassign,lremove,lrange,lpop --- generic/tclListObj.c | 18 +- tests/listRep.test | 1377 ++++++++++++++++++++++++++++++++++++++++++++++---- 2 files changed, 1299 insertions(+), 96 deletions(-) diff --git a/generic/tclListObj.c b/generic/tclListObj.c index 529a790..6e195e3 100644 --- a/generic/tclListObj.c +++ b/generic/tclListObj.c @@ -385,6 +385,7 @@ static inline void ListRepFreeUnreferenced(const ListRep *repPtr) { if (! ListRepIsShared(repPtr) && repPtr->spanPtr) { + /* T:listrep-1.5.1 */ ListRepUnsharedFreeUnreferenced(repPtr); } } @@ -1058,6 +1059,7 @@ static void ListRepUnsharedFreeUnreferenced(const ListRep *repPtr) count = spanPtr->spanStart - storePtr->firstUsed; LIST_COUNT_ASSERT(count); if (count > 0) { + /* T:listrep-1.5.1 */ ObjArrayDecrRefs(storePtr->slots, storePtr->firstUsed, count); storePtr->firstUsed = spanPtr->spanStart; LIST_ASSERT(storePtr->numUsed >= count); @@ -1447,7 +1449,7 @@ ListRepRange( /* Take the opportunity to garbage collect */ /* TODO - we probably do not need the preserveSrcRep here unlike later */ if (!preserveSrcRep) { - /* T:listrep-1.{4,5,8,9},2.{4,5,6,7},3.{15,16,17,18},4.{7,8} */ + /* T:listrep-1.{4,5,8,9},2.{4:7},3.{15:18},4.{7,8} */ ListRepFreeUnreferenced(srcRepPtr); } @@ -1484,6 +1486,7 @@ ListRepRange( */ if (rangeStart == 0 && rangeEnd == (numSrcElems-1)) { /* Option 0 - entire list. This may be used to canonicalize */ + /* T:listrep-1.10.1 */ *rangeRepPtr = *srcRepPtr; /* Not ref counts not incremented */ } else if (rangeStart == 0 && (!preserveSrcRep) && (!ListRepIsShared(srcRepPtr) && srcRepPtr->spanPtr == NULL)) { @@ -1527,7 +1530,7 @@ ListRepRange( * is mandated. */ if (!preserveSrcRep) { - /* T:listrep-2.{5,7},3.{16,18},4.{7,8} */ + /* T:listrep-1.{5.1,5.2,5.4},2.{5,7},3.{16,18},4.{7,8} */ ListRepFreeUnreferenced(rangeRepPtr); } } else if (preserveSrcRep || ListRepIsShared(srcRepPtr)) { @@ -1633,8 +1636,9 @@ TclListObjRange( ListRepRange(&listRep, rangeStart, rangeEnd, isShared, &resultRep); if (isShared) { + /* T:listrep-1.10.1 */ TclNewObj(listObj); - } + } /* T:listrep-1.{4.3,5.1,5.2} */ ListObjReplaceRepAndInvalidate(listObj, &resultRep); return listObj; } @@ -2511,7 +2515,7 @@ Tcl_ListObjReplace( /* T:listrep-1.{7,12,15,17,19,20} */ listRep.spanPtr = NULL; } else { - /* T:listrep-1.{1,3,13,14,16,18,21} */ + /* T:listrep-1.{1,3,6.1,13,14,16,18,21} */ listRep.spanPtr = ListSpanNew(listRep.storePtr->firstUsed, listRep.storePtr->numUsed); } @@ -2736,6 +2740,7 @@ TclLsetList( && TclGetIntForIndexM(NULL, indexArgObj, ListSizeT_MAX - 1, &index) == TCL_OK) { /* indexArgPtr designates a single index. */ + /* T:listrep-1.{2.1,12.1,15.1,19.1} */ return TclLsetFlat(interp, listObj, 1, &indexArgObj, valueObj); } @@ -3018,10 +3023,13 @@ TclLsetFlat( len = -1; TclListObjLengthM(NULL, subListObj, &len); if (valueObj == NULL) { + /* T:listrep-1.{4.2,5.4,6.1,7.1,8.3} */ Tcl_ListObjReplace(NULL, subListObj, index, 1, 0, NULL); } else if (index == len) { + /* T:listrep-1.2.1 */ Tcl_ListObjAppendElement(NULL, subListObj, valueObj); } else { + /* T:listrep-1.{12.1,15.1,19.1} */ TclListObjSetElement(NULL, subListObj, index, valueObj); TclInvalidateStringRep(subListObj); } @@ -3097,7 +3105,7 @@ TclListObjSetElement( /* TODO - leave extra space? */ ListRepClone(&listRep, &newInternalRep, LISTREP_PANIC_ON_FAIL); listRep = newInternalRep; - } + } /* else T:listrep-1.{12.1,15.1,19.1} */ /* Retrieve element array AFTER potential cloning above */ ListRepElements(&listRep, elemCount, elemPtrs); diff --git a/tests/listRep.test b/tests/listRep.test index 9937f3c..9cfaeb2 100644 --- a/tests/listRep.test +++ b/tests/listRep.test @@ -194,110 +194,334 @@ set end end test listrep-1.1 { Inserts in front of unshared list with no free space should reallocate with - equal free space at front and back + equal free space at front and back -- linsert version } -constraints testlistrep -body { set l [linsert [freeSpaceNone] $zero 99] validate $l list $l [spaceEqual $l] } -result [list {99 0 1 2 3 4 5 6 7} 1] +test listrep-1.1.1 { + Inserts in front of unshared list with no free space should reallocate with + equal free space at front and back -- lreplace version +} -constraints testlistrep -body { + set l [lreplace [freeSpaceNone] $zero -1 99] + validate $l + list $l [spaceEqual $l] +} -result [list {99 0 1 2 3 4 5 6 7} 1] + test listrep-1.2 { Inserts at back of unshared list with no free space should allocate all - space at back (essentially old lappend behavior) + space at back -- linsert version } -constraints testlistrep -body { set l [linsert [freeSpaceNone] $end 99] validate $l list $l [leadSpace $l] [tailSpace $l] } -result [list {0 1 2 3 4 5 6 7 99} 0 9] +test listrep-1.2.1 { + Inserts at back of unshared list with no free space should allocate all + space at back -- lset version +} -constraints testlistrep -body { + set l [freeSpaceNone] + lset l $end+1 99 + validate $l + list $l [leadSpace $l] [tailSpace $l] +} -result [list {0 1 2 3 4 5 6 7 99} 0 9] + +test listrep-1.2.2 { + Inserts at back of unshared list with no free space should allocate all + space at back -- lappend version +} -constraints testlistrep -body { + set l [freeSpaceNone] + lappend l 99 + validate $l + list $l [leadSpace $l] [tailSpace $l] +} -result [list {0 1 2 3 4 5 6 7 99} 0 9] + test listrep-1.3 { Inserts in middle of unshared list with no free space should reallocate with - equal free space at front and back + equal free space at front and back - linsert version } -constraints testlistrep -body { set l [linsert [freeSpaceNone] $four 99] validate $l list $l [spaceEqual $l] } -result [list {0 1 2 3 99 4 5 6 7} 1] +test listrep-1.3.1 { + Inserts in middle of unshared list with no free space should reallocate with + equal free space at front and back - lreplace version +} -constraints testlistrep -body { + set l [lreplace [freeSpaceNone] $four $four-1 99] + validate $l + list $l [spaceEqual $l] +} -result [list {0 1 2 3 99 4 5 6 7} 1] + test listrep-1.4 { Deletes from front of small unshared list with no free space should - just shift up leaving room at back + just shift up leaving room at back - lreplace version } -constraints testlistrep -body { set l [lreplace [freeSpaceNone] $zero $zero] validate $l list $l [leadSpace $l] [tailSpace $l] } -result [list {1 2 3 4 5 6 7} 0 1] +test listrep-1.4.1 { + Deletes from front of small unshared list with no free space should + just shift up leaving room at back - lassign version +} -constraints testlistrep -body { + set l [lassign [freeSpaceNone] e] + validate $l + list $e $l [leadSpace $l] [tailSpace $l] +} -result [list 0 {1 2 3 4 5 6 7} 0 1] + +test listrep-1.4.2 { + Deletes from front of small unshared list with no free space should + just shift up leaving room at back - lpop version +} -constraints testlistrep -body { + set l [freeSpaceNone] + set e [lpop l $zero] + validate $l + list $e $l [leadSpace $l] [tailSpace $l] +} -result [list 0 {1 2 3 4 5 6 7} 0 1] + +test listrep-1.4.3 { + Deletes from front of small unshared list with no free space should + just shift up leaving room at back - lrange version +} -constraints testlistrep -body { + set l [lrange [freeSpaceNone] $one $end] + validate $l + list $l [leadSpace $l] [tailSpace $l] +} -result [list {1 2 3 4 5 6 7} 0 1] + +test listrep-1.4.4 { + Deletes from front of small unshared list with no free space should + just shift up leaving room at back - lremove version +} -constraints testlistrep -body { + set l [lremove [freeSpaceNone] $zero] + validate $l + list $l [leadSpace $l] [tailSpace $l] +} -result [list {1 2 3 4 5 6 7} 0 1] + test listrep-1.5 { Deletes from front of large unshared list with no free space should - create a span + create a span - lreplace version } -constraints testlistrep -body { set l [lreplace [freeSpaceNone 1000] $zero $one] validate $l list $l [leadSpace $l] [tailSpace $l] [hasSpan $l 2 998] } -result [list [irange 2 999] 2 0 1] +test listrep-1.5.1 { + Deletes from front of large unshared list with no free space should + create a span - lassign version +} -constraints testlistrep -body { + set l [lassign [freeSpaceNone 1000] e] + validate $l + list $e $l [leadSpace $l] [tailSpace $l] [hasSpan $l 1 999] +} -result [list 0 [irange 1 999] 1 0 1] + +test listrep-1.5.2 { + Deletes from front of large unshared list with no free space should + create a span - lrange version +} -constraints testlistrep -body { + set l [lrange [freeSpaceNone 1000] $two end] + validate $l + list $l [leadSpace $l] [tailSpace $l] [hasSpan $l 2 998] +} -result [list [irange 2 999] 2 0 1] + +test listrep-1.5.3 { + Deletes from front of large unshared list with no free space should + create a span - lremove version +} -constraints testlistrep -body { + set l [lremove [freeSpaceNone 1000] $zero] + validate $l + list $l [leadSpace $l] [tailSpace $l] [hasSpan $l 1 999] +} -result [list [irange 1 999] 1 0 1] + +test listrep-1.5.4 { + Deletes from front of large unshared list with no free space should + create a span - lpop version +} -constraints testlistrep -body { + set l [freeSpaceNone 1000] + set e [lpop l 0] + validate $l + list $e $l [leadSpace $l] [tailSpace $l] [hasSpan $l 1 999] +} -result [list 0 [irange 1 999] 1 0 1] + test listrep-1.6 { Deletes closer to front of large list should move (smaller) front segment + -- lreplace version } -constraints testlistrep -body { set l [lreplace [freeSpaceNone 1000] $four $four] validate $l list $l [leadSpace $l] [tailSpace $l] [hasSpan $l 1 999] } -result [list [concat [irange 0 3] [irange 5 999]] 1 0 1] +test listrep-1.6.1 { + Deletes closer to front of large list should move (smaller) front segment + -- lpop version +} -constraints testlistrep -body { + set l [freeSpaceNone 1000] + set e [lpop l $four] + validate $l + list $e $l [leadSpace $l] [tailSpace $l] [hasSpan $l 1 999] +} -result [list 4 [concat [irange 0 3] [irange 5 999]] 1 0 1] + test listrep-1.7 { Deletes closer to back of large list should move (smaller) back segment - and will not need a span + and will not need a span - lreplace version } -constraints testlistrep -body { set l [lreplace [freeSpaceNone 1000] end-$four end-$four] validate $l list $l [leadSpace $l] [tailSpace $l] [hasSpan $l] } -result [list [concat [irange 0 994] [irange 996 999]] 0 1 0] +test listrep-1.7.1 { + Deletes closer to back of large list should move (smaller) back segment + and will not need a span - lpop version +} -constraints testlistrep -body { + set l [freeSpaceNone 1000] + set e [lpop l $end-4] + validate $l + list $e $l [leadSpace $l] [tailSpace $l] [hasSpan $l] +} -result [list 995 [concat [irange 0 994] [irange 996 999]] 0 1 0] + test listrep-1.8 { - Deletes at back of small unshared list should not need a span + Deletes at back of small unshared list should not need a span - lreplace version } -constraints testlistrep -body { set l [lreplace [freeSpaceNone] end-$one end] validate $l list $l [leadSpace $l] [tailSpace $l] [hasSpan $l] } -result [list {0 1 2 3 4 5} 0 2 0] +test listrep-1.8.1 { + Deletes at back of small unshared list should not need a span - lrange version +} -constraints testlistrep -body { + set l [lrange [freeSpaceNone] $zero end-$two] + validate $l + list $l [leadSpace $l] [tailSpace $l] [hasSpan $l] +} -result [list {0 1 2 3 4 5} 0 2 0] + +test listrep-1.8.2 { + Deletes at back of small unshared list should not need a span - lremove version +} -constraints testlistrep -body { + set l [lremove [freeSpaceNone] $end-1 $end] + validate $l + list $l [leadSpace $l] [tailSpace $l] [hasSpan $l] +} -result [list {0 1 2 3 4 5} 0 2 0] + +test listrep-1.8.3 { + Deletes at back of small unshared list should not need a span - lpop version +} -constraints testlistrep -body { + set l [freeSpaceNone] + set e [lpop l $end] + validate $l + list $e $l [leadSpace $l] [tailSpace $l] [hasSpan $l] +} -result [list 7 {0 1 2 3 4 5 6} 0 1 0] + test listrep-1.9 { - Deletes at back of large unshared list should not need a span + Deletes at back of large unshared list should not need a span - lreplace version } -constraints testlistrep -body { set l [lreplace [freeSpaceNone 1000] end-$four end] validate $l list $l [leadSpace $l] [tailSpace $l] [hasSpan $l] } -result [list [irange 0 994] 0 5 0] +test listrep-1.9.1 { + Deletes at back of large unshared list should not need a span - lrange version +} -constraints testlistrep -body { + set l [lrange [freeSpaceNone 1000] 0 $end-5] + validate $l + list $l [leadSpace $l] [tailSpace $l] [hasSpan $l] +} -result [list [irange 0 994] 0 5 0] + +test listrep-1.9.2 { + Deletes at back of large unshared list should not need a span - lremove version +} -constraints testlistrep -body { + set l [lremove [freeSpaceNone 1000] end-$four $end-3 end-$two $end-1 $end] + validate $l + list $l [leadSpace $l] [tailSpace $l] [hasSpan $l] +} -result [list [irange 0 994] 0 5 0] + +test listrep-1.9.3 { + Deletes at back of large unshared list should not need a span - lpop version +} -constraints testlistrep -body { + set l [freeSpaceNone 1000] + set e [lpop l $end] + validate $l + list $e $l [leadSpace $l] [tailSpace $l] [hasSpan $l] +} -result [list 999 [irange 0 998] 0 1 0] + test listrep-1.10 { - lreplace no-op on unshared list should force a canonical list representation + no-op on unshared list should force a canonical list string - lreplace version } -body { lreplace { 1 2 3 4 } $zero -1 } -result {1 2 3 4} +test listrep-1.10.1 { + no-op on unshared list should force a canonical list string - lrange version +} -body { + lrange { 1 2 3 4 } $zero $end +} -result {1 2 3 4} + test listrep-1.11 { - Append elements to large unshared list using lreplace is optimized as lappend - so no free space in front + Append elements to large unshared list is optimized as lappend + so no free space in front - lreplace version } -body { # Note $end, not end else byte code compiler short-cuts set l [lreplace [freeSpaceNone 1000] $end+1 $end+1 1000] + validate $l + list $l [leadSpace $l] [expr {[tailSpace $l] > 0}] [hasSpan $l] +} -result [list [irange 0 1000] 0 1 0] + +test listrep-1.11.1 { + Append elements to large unshared list is optimized as lappend + so no free space in front - linsert version +} -body { + # Note $end, not end else byte code compiler short-cuts + set l [linsert [freeSpaceNone 1000] $end+1 1000] + validate $l list $l [leadSpace $l] [expr {[tailSpace $l] > 0}] [hasSpan $l] } -result [list [irange 0 1000] 0 1 0] +test listrep-1.11.2 { + Append elements to large unshared list leaves no free space in front + - lappend version +} -body { + # Note $end, not end else byte code compiler short-cuts + set l [freeSpaceNone 1000] + lappend l 1000 1001 + validate $l + list $l [leadSpace $l] [expr {[tailSpace $l] > 0}] [hasSpan $l] +} -result [list [irange 0 1001] 0 1 0] + + test listrep-1.12 { Replacement of elements at front with same number elements in unshared list - is in-place + is in-place - lreplace version } -body { set l [lreplace [freeSpaceNone] $zero $one 10 11] + validate $l list $l [leadSpace $l] [tailSpace $l] } -result [list {10 11 2 3 4 5 6 7} 0 0] +test listrep-1.12.1 { + Replacement of elements at front with same number elements in unshared list + is in-place - lset version +} -body { + set l [freeSpaceNone] + lset l 0 -1 + validate $l + list $l [leadSpace $l] [tailSpace $l] +} -result [list {-1 1 2 3 4 5 6 7} 0 0] + test listrep-1.13 { Replacement of elements at front with fewer elements in unshared list results in a spanned list with space only in front } -body { set l [lreplace [freeSpaceNone] $zero $four 10] + validate $l list $l [leadSpace $l] [tailSpace $l] } -result [list {10 5 6 7} 4 0] @@ -306,22 +530,35 @@ test listrep-1.14 { results in a reallocated spanned list with space at front and back } -body { set l [lreplace [freeSpaceNone] $zero $one 10 11 12] + validate $l list $l [spaceEqual $l] } -result [list {10 11 12 2 3 4 5 6 7} 1] test listrep-1.15 { Replacement of elements in middle with same number elements in unshared list - is in-place + is in-place - lreplace version } -body { set l [lreplace [freeSpaceNone] $one $two 10 11] + validate $l list $l [leadSpace $l] [tailSpace $l] } -result [list {0 10 11 3 4 5 6 7} 0 0] +test listrep-1.15.1 { + Replacement of elements in middle with same number elements in unshared list + is in-place - lset version +} -body { + set l [freeSpaceNone] + lset l $two -1 + validate $l + list $l [leadSpace $l] [tailSpace $l] +} -result [list {0 1 -1 3 4 5 6 7} 0 0] + test listrep-1.16 { Replacement of elements in front half with fewer elements in unshared list results in a spanned list with space only in front since smaller segment moved } -body { set l [lreplace [freeSpaceNone] $one $four 10] + validate $l list $l [leadSpace $l] [tailSpace $l] } -result [list {0 10 5 6 7} 3 0] @@ -330,6 +567,7 @@ test listrep-1.17 { results in a spanned list with space only at back } -body { set l [lreplace [freeSpaceNone] end-$four end-$one 10] + validate $l list $l [leadSpace $l] [tailSpace $l] } -result [list {0 1 2 10 7} 0 3] @@ -338,22 +576,35 @@ test listrep-1.18 { results in a reallocated spanned list with space at front and back } -body { set l [lreplace [freeSpaceNone] $one $two 10 11 12] + validate $l list $l [spaceEqual $l] } -result [list {0 10 11 12 3 4 5 6 7} 1] test listrep-1.19 { Replacement of elements at back with same number elements in unshared list - is in-place + is in-place - lreplace version } -body { set l [lreplace [freeSpaceNone] $end-1 $end 10 11] + validate $l list $l [leadSpace $l] [tailSpace $l] } -result [list {0 1 2 3 4 5 10 11} 0 0] +test listrep-1.19.1 { + Replacement of elements at back with same number elements in unshared list + is in-place - lset version +} -body { + set l [freeSpaceNone] + lset l $end 10 + validate $l + list $l [leadSpace $l] [tailSpace $l] +} -result [list {0 1 2 3 4 5 6 10} 0 0] + test listrep-1.20 { Replacement of elements at back with fewer elements in unshared list is in-place with space only at the back } -body { set l [lreplace [freeSpaceNone] $end-2 $end 10] + validate $l list $l [leadSpace $l] [tailSpace $l] } -result [list {0 1 2 3 4 10} 0 2] @@ -362,6 +613,7 @@ test listrep-1.21 { allocates new representation with equal space at front and back } -body { set l [lreplace [freeSpaceNone] $end-1 $end 10 11 12] + validate $l list $l [spaceEqual $l] } -result [list {0 1 2 3 4 5 10 11 12} 1] @@ -373,119 +625,387 @@ test listrep-1.21 { test listrep-2.1 { Inserts in front of shared list with no free space should reallocate with - more leading space in front + more leading space in front - linsert version } -constraints testlistrep -body { set a [freeSpaceNone] - set b [lrange $a 0 end]; # Ensure shared listrep + set b [lrange $a $zero end]; # Ensure shared listrep set l [linsert $b $zero 99] validate $l list [repStoreRefCount $b] $l [leadSpaceMore $l] [repStoreRefCount $l] } -result [list 2 {99 0 1 2 3 4 5 6 7} 1 1] +test listrep-2.1.1 { + Inserts in front of shared list with no free space should reallocate with + more leading space in front - lreplace version +} -constraints testlistrep -body { + set a [freeSpaceNone] + set b [lrange $a $zero end]; # Ensure shared listrep + set l [lreplace $b $zero -1 99] + validate $l + list [repStoreRefCount $b] $l [leadSpaceMore $l] [repStoreRefCount $l] +} -result [list 2 {99 0 1 2 3 4 5 6 7} 1 1] + test listrep-2.2 { Inserts at back of shared list with no free space should reallocate with - more leading space in back + more leading space in back - linsert version } -constraints testlistrep -body { set a [freeSpaceNone] - set b [lrange $a 0 end]; # Ensure shared listrep + set b [lrange $a $zero end]; # Ensure shared listrep set l [linsert $b $end 99] validate $l list [repStoreRefCount $b] $l [tailSpaceMore $l] [repStoreRefCount $l] } -result [list 2 {0 1 2 3 4 5 6 7 99} 1 1] +test listrep-2.2.1 { + Inserts at back of shared list with no free space should reallocate with + more leading space in back - lreplace version +} -constraints testlistrep -body { + set a [freeSpaceNone] + set b [lrange $a $zero end]; # Ensure shared listrep + set l [lreplace $b $end+1 end+$one 99] + validate $l + list [repStoreRefCount $b] $l [tailSpaceMore $l] [repStoreRefCount $l] +} -result [list 2 {0 1 2 3 4 5 6 7 99} 1 1] + +test listrep-2.2.2 { + Inserts at back of shared list with no free space should reallocate with + more leading space in back - lappend version +} -constraints testlistrep -body { + set a [freeSpaceNone] + set b [lrange $a $zero end]; # Ensure shared listrep + set l [lappend b 99] + validate $l + list [repStoreRefCount $b] $l [tailSpaceMore $l] [repStoreRefCount $l] +} -result [list 1 {0 1 2 3 4 5 6 7 99} 1 1] + +test listrep-2.2.3 { + Inserts at back of shared list with no free space should reallocate with + more leading space in back - lset version +} -constraints testlistrep -body { + set a [freeSpaceNone] + set b [lrange $a $zero end]; # Ensure shared listrep + set l [lset b $end+1 99] + validate $l + list [repStoreRefCount $b] $l [tailSpaceMore $l] [repStoreRefCount $l] +} -result [list 1 {0 1 2 3 4 5 6 7 99} 1 1] + test listrep-2.3 { Inserts in middle of shared list with no free space should reallocate with - equal spacing + equal spacing - linsert version } -constraints testlistrep -body { set a [freeSpaceNone] - set b [lrange $a 0 end]; # Ensure shared listrep + set b [lrange $a $zero end]; # Ensure shared listrep set l [linsert $b $four 99] validate $l list [repStoreRefCount $b] $l [spaceEqual $l] [repStoreRefCount $l] } -result [list 2 {0 1 2 3 99 4 5 6 7} 1 1] +test listrep-2.3.1 { + Inserts in middle of shared list with no free space should reallocate with + equal spacing - lreplace version +} -constraints testlistrep -body { + set a [freeSpaceNone] + set b [lrange $a $zero end]; # Ensure shared listrep + set l [lreplace $b $four $four-1 99] + validate $l + list [repStoreRefCount $b] $l [spaceEqual $l] [repStoreRefCount $l] +} -result [list 2 {0 1 2 3 99 4 5 6 7} 1 1] + test listrep-2.4 { Deletes from front of small shared list with no free space should - allocate new list of exact size + allocate new list of exact size - lreplace version } -constraints testlistrep -body { set a [freeSpaceNone] - set b [lrange $a 0 end]; # Ensure shared listrep + set b [lrange $a $zero end]; # Ensure shared listrep set l [lreplace $b $zero $zero] validate $l list [repStoreRefCount $b] $l [leadSpace $l] [tailSpace $l] [repStoreRefCount $l] } -result [list 2 {1 2 3 4 5 6 7} 0 0 1] +test listrep-2.4.1 { + Deletes from front of small shared list with no free space should + allocate new list of exact size - lremove version +} -constraints testlistrep -body { + set a [freeSpaceNone] + set b [lrange $a $zero end]; # Ensure shared listrep + set l [lremove $b $zero $one] + validate $l + list [repStoreRefCount $b] $l [leadSpace $l] [tailSpace $l] [repStoreRefCount $l] +} -result [list 2 {2 3 4 5 6 7} 0 0 1] + +test listrep-2.4.2 { + Deletes from front of small shared list with no free space should + allocate new list of exact size - lrange version +} -constraints testlistrep -body { + set a [freeSpaceNone] + set b [lrange $a $zero end]; # Ensure shared listrep + set l [lrange $b $one $end] + validate $l + list [repStoreRefCount $b] $l [leadSpace $l] [tailSpace $l] [repStoreRefCount $l] +} -result [list 2 {1 2 3 4 5 6 7} 0 0 1] + +test listrep-2.4.3 { + Deletes from front of small shared list with no free space should + allocate new list of exact size - lassign version +} -constraints testlistrep -body { + set a [freeSpaceNone] + set b [lrange $a $zero end]; # Ensure shared listrep + set l [lassign $b e] + validate $l + list $e [repStoreRefCount $b] $l [leadSpace $l] [tailSpace $l] [repStoreRefCount $l] +} -result [list 0 2 {1 2 3 4 5 6 7} 0 0 1] + +test listrep-2.4.4 { + Deletes from front of small shared list with no free space should + allocate new list of exact size - lpop version +} -constraints testlistrep -body { + set a [freeSpaceNone] + set l [lrange $a $zero end]; # Ensure shared listrep + set e [lpop l $zero] + validate $l + list $e $l [leadSpace $l] [tailSpace $l] [repStoreRefCount $l] +} -result [list 0 {1 2 3 4 5 6 7} 0 0 1] + test listrep-2.5 { Deletes from front of large shared list with no free space should - create span + create span - lreplace version } -constraints testlistrep -body { set a [freeSpaceNone 1000] - set b [lrange $a 0 end]; # Ensure shared listrep + set b [lrange $a $zero end]; # Ensure shared listrep set l [lreplace $b $zero $zero] validate $l # The listrep store should be shared among a, b, l (3 refs) - list [repStoreRefCount $b] $l [hasSpan $l] [leadSpace $l] [tailSpace $l] [repStoreRefCount $l] -} -result [list 3 [irange 1 999] 1 0 0 3] + list [sameStore $b $l] [repStoreRefCount $b] $l [hasSpan $l] [leadSpace $l] [tailSpace $l] [repStoreRefCount $l] +} -result [list 1 3 [irange 1 999] 1 0 0 3] + +test listrep-2.5.1 { + Deletes from front of large shared list with no free space should + create span - lremove version +} -constraints testlistrep -body { + set a [freeSpaceNone 1000] + set b [lrange $a $zero end]; # Ensure shared listrep + set l [lremove $b $zero $one] + validate $l + # The listrep store should be shared among a, b, l (3 refs) + list [sameStore $b $l] [repStoreRefCount $b] $l [hasSpan $l] [leadSpace $l] [tailSpace $l] [repStoreRefCount $l] +} -result [list 1 3 [irange 2 999] 1 0 0 3] + +test listrep-2.5.2 { + Deletes from front of large shared list with no free space should + create span - lrange version +} -constraints testlistrep -body { + set a [freeSpaceNone 1000] + set b [lrange $a $zero end]; # Ensure shared listrep + set l [lrange $b $two $end] + validate $l + # The listrep store should be shared among a, b, l (3 refs) + list [sameStore $b $l] [repStoreRefCount $b] $l [hasSpan $l] [leadSpace $l] [tailSpace $l] [repStoreRefCount $l] +} -result [list 1 3 [irange 2 999] 1 0 0 3] + +test listrep-2.5.3 { + Deletes from front of large shared list with no free space should + create span - lassign version +} -constraints testlistrep -body { + set a [freeSpaceNone 1000] + set b [lrange $a $zero end]; # Ensure shared listrep + set l [lassign $b e] + validate $l + # The listrep store should be shared among a, b, l (3 refs) + list $e [sameStore $b $l] [repStoreRefCount $b] $l [hasSpan $l] [leadSpace $l] [tailSpace $l] [repStoreRefCount $l] +} -result [list 0 1 3 [irange 1 999] 1 0 0 3] + +test listrep-2.5.4 { + Deletes from front of large shared list with no free space should + create span - lpop version +} -constraints testlistrep -body { + set a [freeSpaceNone 1000] + set l [lrange $a $zero end]; # Ensure shared listrep + set e [lpop l $zero] + validate $l + # The listrep store should be shared among a, b, l (3 refs) + list $e $l [hasSpan $l] [leadSpace $l] [tailSpace $l] [repStoreRefCount $l] +} -result [list 0 [irange 1 999] 1 0 0 2] test listrep-2.6 { Deletes from back of small shared list with no free space should - allocate new list of exact size + allocate new list of exact size - lreplace version } -constraints testlistrep -body { set a [freeSpaceNone] - set b [lrange $a 0 end]; # Ensure shared listrep + set b [lrange $a $zero end]; # Ensure shared listrep set l [lreplace $b $end $end] validate $l list [repStoreRefCount $b] $l [leadSpace $l] [tailSpace $l] [repStoreRefCount $l] } -result [list 2 {0 1 2 3 4 5 6} 0 0 1] +test listrep-2.6.1 { + Deletes from back of small shared list with no free space should + allocate new list of exact size - lremove version +} -constraints testlistrep -body { + set a [freeSpaceNone] + set b [lrange $a $zero end]; # Ensure shared listrep + set l [lremove $b $end $end-1] + validate $l + list [repStoreRefCount $b] $l [leadSpace $l] [tailSpace $l] [repStoreRefCount $l] +} -result [list 2 {0 1 2 3 4 5} 0 0 1] + +test listrep-2.6.2 { + Deletes from back of small shared list with no free space should + allocate new list of exact size - lrange version +} -constraints testlistrep -body { + set a [freeSpaceNone] + set b [lrange $a $zero end]; # Ensure shared listrep + set l [lrange $b $zero $end-1] + validate $l + list [repStoreRefCount $b] $l [leadSpace $l] [tailSpace $l] [repStoreRefCount $l] +} -result [list 2 {0 1 2 3 4 5 6} 0 0 1] + +test listrep-2.6.3 { + Deletes from back of small shared list with no free space should + allocate new list of exact size - lpop version +} -constraints testlistrep -body { + set a [freeSpaceNone] + set l [lrange $a $zero end]; # Ensure shared listrep + set e [lpop l] + validate $l + list $e $l [leadSpace $l] [tailSpace $l] [repStoreRefCount $l] +} -result [list 7 {0 1 2 3 4 5 6} 0 0 1] + test listrep-2.7 { Deletes from back of large shared list with no free space should - use a span + use a span - lreplace version } -constraints testlistrep -body { set a [freeSpaceNone 1000] - set b [lrange $a 0 end]; # Ensure shared listrep + set b [lrange $a $zero end]; # Ensure shared listrep set l [lreplace $b $end $end] validate $l # Note lead and tail space is 0 because original list store in a,b is used list [repStoreRefCount $b] $l [leadSpace $l] [tailSpace $l] [repStoreRefCount $l] } -result [list 3 [irange 0 998] 0 0 3] +test listrep-2.7.1 { + Deletes from back of large shared list with no free space should + use a span - lremove version +} -constraints testlistrep -body { + set a [freeSpaceNone 1000] + set b [lrange $a $zero end]; # Ensure shared listrep + set l [lremove $b $end-1 $end] + validate $l + # Note lead and tail space is 0 because original list store in a,b is used + list [repStoreRefCount $b] $l [leadSpace $l] [tailSpace $l] [repStoreRefCount $l] +} -result [list 3 [irange 0 997] 0 0 3] + +test listrep-2.7.2 { + Deletes from back of large shared list with no free space should + use a span - lrange version +} -constraints testlistrep -body { + set a [freeSpaceNone 1000] + set b [lrange $a $zero end]; # Ensure shared listrep + set l [lrange $b $zero $end-1] + validate $l + # Note lead and tail space is 0 because original list store in a,b is used + list [repStoreRefCount $b] $l [leadSpace $l] [tailSpace $l] [repStoreRefCount $l] +} -result [list 3 [irange 0 998] 0 0 3] + +test listrep-2.7.3 { + Deletes from back of large shared list with no free space should + use a span - lpop version +} -constraints testlistrep -body { + set a [freeSpaceNone 1000] + set l [lrange $a $zero end]; # Ensure shared listrep + set e [lpop l] + validate $l + # Note lead and tail space is 0 because original list store in a,b is used + list $e $l [leadSpace $l] [tailSpace $l] [repStoreRefCount $l] +} -result [list 999 [irange 0 998] 0 0 2] + test listrep-2.8 { - lreplace no-op on shared list should force a canonical list representation - with original unchanged + no-op on shared list should force a canonical list representation + with original unchanged - lreplace version } -body { set l { 1 2 3 4 } list [lreplace $l $zero -1] $l } -result [list {1 2 3 4} { 1 2 3 4 }] +test listrep-2.8.1 { + no-op on shared list should force a canonical list representation + with original unchanged - lrange version +} -body { + set l { 1 2 3 4 } + list [lrange $l $zero end] $l +} -result [list {1 2 3 4} { 1 2 3 4 }] + test listrep-2.9 { Appends to back of large shared list with no free space allocates new - list with space only at the back. + list with space only at the back - lreplace version } -constraints testlistrep -body { set a [freeSpaceNone 1000] - set b [lrange $a 0 end]; # Ensure shared listrep + set b [lrange $a $zero end]; # Ensure shared listrep set l [lreplace $b $end+1 $end+1 1000] validate $l list [repStoreRefCount $b] $l [leadSpace $l] [expr {[tailSpace $l]>0}] [repStoreRefCount $l] } -result [list 2 [irange 0 1000] 0 1 1] +test listrep-2.9.1 { + Appends to back of large shared list with no free space allocates new + list with space only at the back - linsert version +} -constraints testlistrep -body { + set a [freeSpaceNone 1000] + set b [lrange $a $zero end]; # Ensure shared listrep + set l [linsert $b $end+1 1000 1001] + validate $l + list [repStoreRefCount $b] $l [leadSpace $l] [expr {[tailSpace $l]>0}] [repStoreRefCount $l] +} -result [list 2 [irange 0 1001] 0 1 1] + +test listrep-2.9.2 { + Appends to back of large shared list with no free space allocates new + list with space only at the back - lappend version +} -constraints testlistrep -body { + set a [freeSpaceNone 1000] + set l [lrange $a $zero end]; # Ensure shared listrep + lappend l 1000 + validate $l + list $l [leadSpace $l] [expr {[tailSpace $l]>0}] [repStoreRefCount $l] +} -result [list [irange 0 1000] 0 1 1] + +test listrep-2.9.3 { + Appends to back of large shared list with no free space allocates new + list with space only at the back - lset version +} -constraints testlistrep -body { + set a [freeSpaceNone 1000] + set l [lrange $a $zero end]; # Ensure shared listrep + lset l $end+1 1000 + validate $l + list $l [leadSpace $l] [expr {[tailSpace $l]>0}] [repStoreRefCount $l] +} -result [list [irange 0 1000] 0 1 1] + test listrep-2.10 { - Replacement of elements at front with same number elements in shared list - results in a new list store with more space in front than back + Replacement of elements at front with same number in shared list results + in a new list store with more space in front than back - lreplace version } -constraints testlistrep -body { set a [freeSpaceNone] - set b [lrange $a 0 end]; # Ensure shared listrep + set b [lrange $a $zero end]; # Ensure shared listrep set l [lreplace $b $zero $one 10 11] validate $l list [repStoreRefCount $b] $l [leadSpaceMore $l] [repStoreRefCount $l] } -result [list 2 {10 11 2 3 4 5 6 7} 1 1] +test listrep-2.10.1 { + Replacement of elements at front with same number in shared list results + in a new list store with no extra space - lset version +} -constraints testlistrep -body { + set a [freeSpaceNone] + set l [lrange $a $zero end]; # Ensure shared listrep + lset l $zero 10 + validate $l + list $l [leadSpace $l] [tailSpace $l] [repStoreRefCount $l] +} -result [list {10 1 2 3 4 5 6 7} 0 0 1] + test listrep-2.11 { Replacement of elements at front with fewer elements in shared list results in a new list store with more space in front than back } -constraints testlistrep -body { set a [freeSpaceNone] - set b [lrange $a 0 end]; # Ensure shared listrep + set b [lrange $a $zero end]; # Ensure shared listrep set l [lreplace $b $zero $four 10] validate $l list [repStoreRefCount $b] $l [leadSpaceMore $l] [repStoreRefCount $l] @@ -496,29 +1016,40 @@ test listrep-2.12 { results in a new spanned list with more space in front } -constraints testlistrep -body { set a [freeSpaceNone] - set b [lrange $a 0 end]; # Ensure shared listrep + set b [lrange $a $zero end]; # Ensure shared listrep set l [lreplace $b $zero $one 10 11 12] validate $l list [repStoreRefCount $b] $l [leadSpaceMore $l] [repStoreRefCount $l] } -result [list 2 {10 11 12 2 3 4 5 6 7} 1 1] test listrep-2.13 { - Replacement of elements in middle with same number elements in shared list - results in a new list store with equal space in front and back + Replacement of elements in middle with same number in shared list results + in a new list store with equal space in front and back - lreplace version } -constraints testlistrep -body { set a [freeSpaceNone] - set b [lrange $a 0 end]; # Ensure shared listrep + set b [lrange $a $zero end]; # Ensure shared listrep set l [lreplace $b $one $two 10 11] validate $l list [repStoreRefCount $b] $l [spaceEqual $l] [repStoreRefCount $l] } -result [list 2 {0 10 11 3 4 5 6 7} 1 1] +test listrep-2.13.1 { + Replacement of elements in middle with same number in shared list results + in a new list store with exact allocation - lset version +} -constraints testlistrep -body { + set a [freeSpaceNone] + set l [lrange $a $zero end]; # Ensure shared listrep + lset l $one 10 + validate $l + list $l [leadSpace $l] [tailSpace $l] [repStoreRefCount $l] +} -result [list {0 10 2 3 4 5 6 7} 0 0 1] + test listrep-2.14 { Replacement of elements in middle with fewer elements in shared list results in a new list store with equal space } -constraints testlistrep -body { set a [freeSpaceNone] - set b [lrange $a 0 end]; # Ensure shared listrep + set b [lrange $a $zero end]; # Ensure shared listrep set l [lreplace $b $one 5 10] validate $l list [repStoreRefCount $b] $l [spaceEqual $l] [repStoreRefCount $l] @@ -529,29 +1060,40 @@ test listrep-2.15 { results in a new spanned list with space in front and back } -constraints testlistrep -body { set a [freeSpaceNone] - set b [lrange $a 0 end]; # Ensure shared listrep + set b [lrange $a $zero end]; # Ensure shared listrep set l [lreplace $b $one $two 10 11 12] validate $l list [repStoreRefCount $b] $l [spaceEqual $l] [repStoreRefCount $l] } -result [list 2 {0 10 11 12 3 4 5 6 7} 1 1] test listrep-2.16 { - Replacement of elements at back with same number elements in shared list - results in a new list store with more space in back than front + Replacement of elements at back with same number in shared list results + in a new list store with more space in back than front - lreplace version } -constraints testlistrep -body { set a [freeSpaceNone] - set b [lrange $a 0 end]; # Ensure shared listrep + set b [lrange $a $zero end]; # Ensure shared listrep set l [lreplace $b end-$one $end 10 11] validate $l list [repStoreRefCount $b] $l [tailSpaceMore $l] [repStoreRefCount $l] } -result [list 2 {0 1 2 3 4 5 10 11} 1 1] +test listrep-2.16.1 { + Replacement of elements at back with same number in shared list results + in a new list store with no extra - lreplace version +} -constraints testlistrep -body { + set a [freeSpaceNone] + set l [lrange $a $zero end]; # Ensure shared listrep + lset l $end 10 + validate $l + list $l [leadSpace $l] [tailSpace $l] [repStoreRefCount $l] +} -result [list {0 1 2 3 4 5 6 10} 0 0 1] + test listrep-2.17 { Replacement of elements at back with fewer elements in shared list results in a new list store with more space in back than front } -constraints testlistrep -body { set a [freeSpaceNone] - set b [lrange $a 0 end]; # Ensure shared listrep + set b [lrange $a $zero end]; # Ensure shared listrep set l [lreplace $b end-$four $end 10] validate $l list [repStoreRefCount $b] $l [tailSpaceMore $l] [repStoreRefCount $l] @@ -562,7 +1104,7 @@ test listrep-2.18 { results in a new list store with more space in back than front } -constraints testlistrep -body { set a [freeSpaceNone] - set b [lrange $a 0 end]; # Ensure shared listrep + set b [lrange $a $zero end]; # Ensure shared listrep set l [lreplace $b end-$four $end 10] validate $l list [repStoreRefCount $b] $l [tailSpaceMore $l] [repStoreRefCount $l] @@ -573,59 +1115,176 @@ test listrep-2.18 { test listrep-3.1 { Inserts in front of unshared spanned list with room in front should just - shrink the lead space + shrink the lead space - linsert version } -constraints testlistrep -body { set l [linsert [freeSpaceBoth] $zero -2 -1] validate $l list $l [leadSpace $l] [tailSpace $l] [repStoreRefCount $l] } -result [list [irange -2 7] 1 3 1] +test listrep-3.1.1 { + Inserts in front of unshared spanned list with room in front should just + shrink the lead space - lreplace version +} -constraints testlistrep -body { + set l [lreplace [freeSpaceBoth] $zero -1 -2 -1] + validate $l + list $l [leadSpace $l] [tailSpace $l] [repStoreRefCount $l] +} -result [list [irange -2 7] 1 3 1] + test listrep-3.2 { Inserts in front of unshared spanned list with insufficient room in front - but enough total freespace should redistribute free space + but enough total freespace should redistribute free space - linsert version } -constraints testlistrep -body { set l [linsert [freeSpaceBoth 8 1 10] $zero -2 -1] validate $l list $l [leadSpace $l] [tailSpace $l] [repStoreRefCount $l] } -result [list [irange -2 7] 5 4 1] +test listrep-3.2.1 { + Inserts in front of unshared spanned list with insufficient room in front + but enough total freespace should redistribute free space - lreplace version +} -constraints testlistrep -body { + set l [lreplace [freeSpaceBoth 8 1 10] $zero -1 -2 -1] + validate $l + list $l [leadSpace $l] [tailSpace $l] [repStoreRefCount $l] +} -result [list [irange -2 7] 5 4 1] + test listrep-3.3 { Inserts in front of unshared spanned list with insufficient total freespace - should reallocate with equal free space + should reallocate with equal free space - linsert version } -constraints testlistrep -body { set l [linsert [freeSpaceBoth 8 1 1] $zero -3 -2 -1] validate $l list $l [leadSpace $l] [tailSpace $l] [repStoreRefCount $l] } -result [list [irange -3 7] 6 5 1] +test listrep-3.3.1 { + Inserts in front of unshared spanned list with insufficient total freespace + should reallocate with equal free space - lreplace version +} -constraints testlistrep -body { + set l [lreplace [freeSpaceBoth 8 1 1] $zero -1 -3 -2 -1] + validate $l + list $l [leadSpace $l] [tailSpace $l] [repStoreRefCount $l] +} -result [list [irange -3 7] 6 5 1] + test listrep-3.4 { Inserts at back of unshared spanned list with room at back should not - reallocate + reallocate - linsert version } -constraints testlistrep -body { set l [linsert [freeSpaceBoth] $end 8] validate $l list $l [leadSpace $l] [tailSpace $l] [repStoreRefCount $l] } -result [list [irange 0 8] 3 2 1] +test listrep-3.4.1 { + Inserts at back of unshared spanned list with room at back should not + reallocate - lreplace version +} -constraints testlistrep -body { + set l [lreplace [freeSpaceBoth] $end+1 $end+1 8 9] + validate $l + list $l [leadSpace $l] [tailSpace $l] [repStoreRefCount $l] +} -result [list [irange 0 9] 3 1 1] + +test listrep-3.4.2 { + Inserts at back of unshared spanned list with room at back should not + reallocate - lappend version +} -constraints testlistrep -body { + set l [freeSpaceBoth] + lappend l 8 9 10 + validate $l + list $l [leadSpace $l] [tailSpace $l] [repStoreRefCount $l] +} -result [list [irange 0 10] 3 0 1] + +test listrep-3.4.3 { + Inserts at back of unshared spanned list with room at back should not + reallocate - lset version +} -constraints testlistrep -body { + set l [freeSpaceBoth] + lset l $end+1 8 + validate $l + list $l [leadSpace $l] [tailSpace $l] [repStoreRefCount $l] +} -result [list [irange 0 8] 3 2 1] + test listrep-3.5 { Inserts at back of unshared spanned list with insufficient room in back - but enough total freespace should redistribute free space + but enough total freespace should redistribute free space - linsert version } -constraints testlistrep -body { set l [linsert [freeSpaceBoth 8 10 1] $end 8 9] validate $l list $l [leadSpace $l] [tailSpace $l] [repStoreRefCount $l] } -result [list [irange 0 9] 5 4 1] +test listrep-3.5.1 { + Inserts at back of unshared spanned list with insufficient room in back + but enough total freespace should redistribute free space - lreplace version +} -constraints testlistrep -body { + set l [lreplace [freeSpaceBoth 8 10 1] $end+1 $end+1 8 9] + validate $l + list $l [leadSpace $l] [tailSpace $l] [repStoreRefCount $l] +} -result [list [irange 0 9] 5 4 1] + +test listrep-3.5.2 { + Inserts at back of unshared spanned list with insufficient room in back + but enough total freespace should redistribute free space - lappend version +} -constraints testlistrep -body { + set l [freeSpaceBoth 8 10 1] + lappend l 8 9 + validate $l + list $l [leadSpace $l] [tailSpace $l] [repStoreRefCount $l] +} -result [list [irange 0 9] 5 4 1] + +test listrep-3.5.3 { + Inserts at back of unshared spanned list with insufficient room in back + but enough total freespace should redistribute free space - lset version +} -constraints testlistrep -body { + set l [freeSpaceBoth 8 10 0] + lset l $end+1 8 + validate $l + list $l [leadSpace $l] [tailSpace $l] [repStoreRefCount $l] +} -result [list [irange 0 8] 5 4 1] + test listrep-3.6 { Inserts in back of unshared spanned list with insufficient total freespace should reallocate with all *additional* space at back. Note this differs - from the insert in front case because here we can realloc() + from the insert in front case because here we realloc(). - linsert version } -constraints testlistrep -body { set l [linsert [freeSpaceBoth 8 1 1] $end 8 9 10] validate $l list $l [leadSpace $l] [tailSpace $l] [repStoreRefCount $l] } -result [list [irange 0 10] 1 10 1] +test listrep-3.6.1 { + Inserts in back of unshared spanned list with insufficient total freespace + should reallocate with all *additional* space at back. Note this differs + from the insert in front case because here we realloc() - lreplace version +} -constraints testlistrep -body { + set l [lreplace [freeSpaceBoth 8 1 1] $end+1 $end+1 8 9 10] + validate $l + list $l [leadSpace $l] [tailSpace $l] [repStoreRefCount $l] +} -result [list [irange 0 10] 1 10 1] + +test listrep-3.6.2 { + Inserts in back of unshared spanned list with insufficient total freespace + should reallocate with all *additional* space at back. Note this differs + from the insert in front case because here we realloc() - lappend version +} -constraints testlistrep -body { + set l [freeSpaceBoth 8 1 1] + lappend l 8 9 10 + validate $l + list $l [leadSpace $l] [tailSpace $l] [repStoreRefCount $l] +} -result [list [irange 0 10] 1 10 1] + +test listrep-3.6.3 { + Inserts in back of unshared spanned list with insufficient total freespace + should reallocate with all *additional* space at back. Note this differs + from the insert in front case because here we realloc() - lset version +} -constraints testlistrep -body { + set l [freeSpaceNone] + lset l $end+1 8 + validate $l + list $l [leadSpace $l] [tailSpace $l] [repStoreRefCount $l] +} -result [list [irange 0 8] 0 9 1] + test listrep-3.7 { Inserts in front half of unshared spanned list with room in front should not reallocate and should move front segment @@ -637,148 +1296,390 @@ test listrep-3.7 { test listrep-3.8 { Inserts in front half of unshared spanned list with insufficient leading - space but with enough tail space + space but with enough tail space - linsert version } -constraints testlistrep -body { set l [linsert [freeSpaceBoth 8 1 5] $one -2 -1] validate $l list $l [leadSpace $l] [tailSpace $l] [repStoreRefCount $l] } -result [list {0 -2 -1 1 2 3 4 5 6 7} 1 3 1] +test listrep-3.8.1 { + Inserts in front half of unshared spanned list with insufficient leading + space but with enough tail space - lreplace version +} -constraints testlistrep -body { + set l [lreplace [freeSpaceBoth 8 1 5] $one -1 -2 -1] + validate $l + list $l [leadSpace $l] [tailSpace $l] [repStoreRefCount $l] +} -result [list {0 -2 -1 1 2 3 4 5 6 7} 1 3 1] + test listrep-3.9 { - Inserts in front half of unshared spanned list with sufficient total free space + Inserts in front half of unshared spanned list with sufficient total + free space - linsert version } -constraints testlistrep -body { set l [linsert [freeSpaceBoth 8 2 2] $one -3 -2 -1] validate $l list $l [leadSpace $l] [tailSpace $l] [repStoreRefCount $l] } -result [list {0 -3 -2 -1 1 2 3 4 5 6 7} 0 1 1] +test listrep-3.9.1 { + Inserts in front half of unshared spanned list with sufficient total + free space - lreplace version +} -constraints testlistrep -body { + set l [lreplace [freeSpaceBoth 8 2 2] $one -1 -3 -2 -1] + validate $l + list $l [leadSpace $l] [tailSpace $l] [repStoreRefCount $l] +} -result [list {0 -3 -2 -1 1 2 3 4 5 6 7} 0 1 1] + test listrep-3.10 { Inserts in front half of unshared spanned list with insufficient total space. - Note use of realloc() means new space will be at the back + Note use of realloc() means new space will be at the back - linsert version } -constraints testlistrep -body { set l [linsert [freeSpaceBoth 8 1 1] $one -3 -2 -1] validate $l list $l [leadSpace $l] [tailSpace $l] [repStoreRefCount $l] } -result [list {0 -3 -2 -1 1 2 3 4 5 6 7} 1 10 1] +test listrep-3.10.1 { + Inserts in front half of unshared spanned list with insufficient total space. + Note use of realloc() means new space will be at the back - lreplace version +} -constraints testlistrep -body { + set l [lreplace [freeSpaceBoth 8 1 1] $one -1 -3 -2 -1] + validate $l + list $l [leadSpace $l] [tailSpace $l] [repStoreRefCount $l] +} -result [list {0 -3 -2 -1 1 2 3 4 5 6 7} 1 10 1] + test listrep-3.11 { Inserts in back half of unshared spanned list with room in back should not - reallocate and should move back segment + reallocate and should move back segment - linsert version } -constraints testlistrep -body { set l [linsert [freeSpaceBoth] $end-$one 8 9] validate $l list $l [leadSpace $l] [tailSpace $l] [repStoreRefCount $l] } -result [list {0 1 2 3 4 5 6 8 9 7} 3 1 1] +test listrep-3.11.1 { + Inserts in back half of unshared spanned list with room in back should not + reallocate and should move back segment - lreplace version +} -constraints testlistrep -body { + set l [lreplace [freeSpaceBoth] $end -1 8 9] + validate $l + list $l [leadSpace $l] [tailSpace $l] [repStoreRefCount $l] +} -result [list {0 1 2 3 4 5 6 8 9 7} 3 1 1] + test listrep-3.12 { Inserts in back half of unshared spanned list with insufficient tail - space but with enough leading space + space but with enough leading space - linsert version } -constraints testlistrep -body { set l [linsert [freeSpaceBoth 8 5 1] $end-$one 8 9] validate $l list $l [leadSpace $l] [tailSpace $l] [repStoreRefCount $l] } -result [list {0 1 2 3 4 5 6 8 9 7} 3 1 1] +test listrep-3.12.1 { + Inserts in back half of unshared spanned list with insufficient tail + space but with enough leading space - lreplace version +} -constraints testlistrep -body { + set l [lreplace [freeSpaceBoth 8 5 1] $end -1 8 9] + validate $l + list $l [leadSpace $l] [tailSpace $l] [repStoreRefCount $l] +} -result [list {0 1 2 3 4 5 6 8 9 7} 3 1 1] + test listrep-3.13 { - Inserts in back half of unshared spanned list with sufficient total free space + Inserts in back half of unshared spanned list with sufficient total + free space - linsert version } -constraints testlistrep -body { set l [linsert [freeSpaceBoth 8 2 2] $end-$one 8 9 10] validate $l list $l [leadSpace $l] [tailSpace $l] [repStoreRefCount $l] } -result [list {0 1 2 3 4 5 6 8 9 10 7} 0 1 1] +test listrep-3.13.1 { + Inserts in back half of unshared spanned list with sufficient total + free space - lreplace version +} -constraints testlistrep -body { + set l [lreplace [freeSpaceBoth 8 2 2] $end -1 8 9 10] + validate $l + list $l [leadSpace $l] [tailSpace $l] [repStoreRefCount $l] +} -result [list {0 1 2 3 4 5 6 8 9 10 7} 0 1 1] + test listrep-3.14 { - Inserts in back half of unshared spanned list with insufficient total space. - Note use of realloc() means new space will be at the back + Inserts in back half of unshared spanned list with insufficient + total space. Note use of realloc() means new space will be at the + back - linsert version } -constraints testlistrep -body { set l [linsert [freeSpaceBoth 8 1 1] $end-$one 8 9 10] validate $l list $l [leadSpace $l] [tailSpace $l] [repStoreRefCount $l] } -result [list {0 1 2 3 4 5 6 8 9 10 7} 1 10 1] +test listrep-3.14.1 { + Inserts in back half of unshared spanned list with insufficient + total space. Note use of realloc() means new space will be at the + back - lrepalce version +} -constraints testlistrep -body { + set l [lreplace [freeSpaceBoth 8 1 1] $end -1 8 9 10] + validate $l + list $l [leadSpace $l] [tailSpace $l] [repStoreRefCount $l] +} -result [list {0 1 2 3 4 5 6 8 9 10 7} 1 10 1] + test listrep-3.15 { Deletes from front of small unshared span list results in elements - moved up front and span removal + moved up front and span removal - lreplace version } -constraints testlistrep -body { set l [lreplace [freeSpaceBoth] $zero $zero] validate $l - list $l [leadSpace $l] [tailSpace $l] [hasSpan $l] -} -result [list {1 2 3 4 5 6 7} 0 7 0] + list $l [leadSpace $l] [tailSpace $l] [hasSpan $l] +} -result [list {1 2 3 4 5 6 7} 0 7 0] + +test listrep-3.15.1 { + Deletes from front of small unshared span list results in elements + moved up front and span removal - lremove version +} -constraints testlistrep -body { + set l [lremove [freeSpaceBoth] $zero $one] + validate $l + list $l [leadSpace $l] [tailSpace $l] [hasSpan $l] +} -result [list {2 3 4 5 6 7} 0 8 0] + +test listrep-3.15.2 { + Deletes from front of small unshared span list results in elements + moved up front and span removal - lrange version +} -constraints testlistrep -body { + set l [lrange [freeSpaceBoth] $one $end] + validate $l + list $l [leadSpace $l] [tailSpace $l] [hasSpan $l] +} -result [list {1 2 3 4 5 6 7} 0 7 0] + +test listrep-3.15.3 { + Deletes from front of small unshared span list results in elements + moved up front and span removal - lassign version +} -constraints testlistrep -body { + set l [lassign [freeSpaceBoth] e] + validate $l + list $e $l [leadSpace $l] [tailSpace $l] [hasSpan $l] +} -result [list 0 {1 2 3 4 5 6 7} 0 7 0] + +test listrep-3.15.4 { + Deletes from front of small unshared span list results in elements + moved up front and span removal - lpop version +} -constraints testlistrep -body { + set l [freeSpaceBoth] + set e [lpop l $zero] + validate $l + list $l [leadSpace $l] [tailSpace $l] [hasSpan $l] +} -result [list {1 2 3 4 5 6 7} 0 7 0] + +test listrep-3.16 { + Deletes from front of large unshared span list results in another + span - lreplace version +} -constraints testlistrep -body { + set l [lreplace [freeSpaceBoth 1000 10 10] $zero $one] + validate $l + list $l [leadSpace $l] [tailSpace $l] [hasSpan $l 12 998] +} -result [list [irange 2 999] 12 10 1] + +test listrep-3.16.1 { + Deletes from front of large unshared span list results in another + span - lremove version +} -constraints testlistrep -body { + set l [lremove [freeSpaceBoth 1000 10 10] $zero $one] + validate $l + list $l [leadSpace $l] [tailSpace $l] [hasSpan $l 12 998] +} -result [list [irange 2 999] 12 10 1] + +test listrep-3.16.2 { + Deletes from front of large unshared span list results in another + span - lrange version +} -constraints testlistrep -body { + set l [lrange [freeSpaceBoth 1000 10 10] $two $end] + validate $l + list $l [leadSpace $l] [tailSpace $l] [hasSpan $l 12 998] +} -result [list [irange 2 999] 12 10 1] + +test listrep-3.16.3 { + Deletes from front of large unshared span list results in another + span - lassign version +} -constraints testlistrep -body { + set l [lassign [freeSpaceBoth 1000 10 10] e] + validate $l + list $e $l [leadSpace $l] [tailSpace $l] [hasSpan $l 11 999] +} -result [list 0 [irange 1 999] 11 10 1] -test listrep-3.16 { +test listrep-3.16.4 { Deletes from front of large unshared span list results in another - span + span - lpop version } -constraints testlistrep -body { - set l [lreplace [freeSpaceBoth 1000 10 10] $zero $one] + set l [freeSpaceBoth 1000 10 10] + set e [lpop l $zero] validate $l - list $l [leadSpace $l] [tailSpace $l] [hasSpan $l 12 998] -} -result [list [irange 2 999] 12 10 1] + list $e $l [leadSpace $l] [tailSpace $l] [hasSpan $l 11 999] +} -result [list 0 [irange 1 999] 11 10 1] test listrep-3.17 { Deletes from back of small unshared span list results in new store - without span + without span - lreplace version } -constraints testlistrep -body { set l [lreplace [freeSpaceBoth] $end $end] validate $l list $l [leadSpace $l] [tailSpace $l] [hasSpan $l] } -result [list {0 1 2 3 4 5 6} 0 7 0] +test listrep-3.17.1 { + Deletes from back of small unshared span list results in new store + without span - lremove version +} -constraints testlistrep -body { + set l [lremove [freeSpaceBoth] $end] + validate $l + list $l [leadSpace $l] [tailSpace $l] [hasSpan $l] +} -result [list {0 1 2 3 4 5 6} 0 7 0] + +test listrep-3.17.2 { + Deletes from back of small unshared span list results in new store + without span - lrange version +} -constraints testlistrep -body { + set l [lrange [freeSpaceBoth] $zero $end-1] + validate $l + list $l [leadSpace $l] [tailSpace $l] [hasSpan $l] +} -result [list {0 1 2 3 4 5 6} 0 7 0] + +test listrep-3.17.3 { + Deletes from back of small unshared span list results in new store + without span - lpop version +} -constraints testlistrep -body { + set l [freeSpaceBoth] + set e [lpop l] + validate $l + list $e $l [leadSpace $l] [tailSpace $l] [hasSpan $l] +} -result [list 7 {0 1 2 3 4 5 6} 0 7 0] + test listrep-3.18 { Deletes from back of large unshared span list results in another - span + span - lreplace version } -constraints testlistrep -body { set l [lreplace [freeSpaceBoth 1000 10 10] $end-1 $end] validate $l list $l [leadSpace $l] [tailSpace $l] [hasSpan $l 10 998] } -result [list [irange 0 997] 10 12 1] +test listrep-3.18.1 { + Deletes from back of large unshared span list results in another + span - lremove version +} -constraints testlistrep -body { + set l [lremove [freeSpaceBoth 1000 10 10] $end-1 $end] + validate $l + list $l [leadSpace $l] [tailSpace $l] [hasSpan $l 10 998] +} -result [list [irange 0 997] 10 12 1] + +test listrep-3.18.2 { + Deletes from back of large unshared span list results in another + span - lrange version +} -constraints testlistrep -body { + set l [lrange [freeSpaceBoth 1000 10 10] $zero $end-2] + validate $l + list $l [leadSpace $l] [tailSpace $l] [hasSpan $l 10 998] +} -result [list [irange 0 997] 10 12 1] + +test listrep-3.18.3 { + Deletes from back of large unshared span list results in another + span - lpop version +} -constraints testlistrep -body { + set l [freeSpaceBoth 1000 10 10] + set e [lpop l] + validate $l + list $e $l [leadSpace $l] [tailSpace $l] [hasSpan $l 10 999] +} -result [list 999 [irange 0 998] 10 11 1] + test listrep-3.19 { Deletes from front half of small unshared span list results in - movement of smaller front segment + movement of smaller front segment - lreplace version } -constraints testlistrep -body { set l [lreplace [freeSpaceBoth] $one $two] validate $l list $l [leadSpace $l] [tailSpace $l] [hasSpan $l 5 6] } -result [list {0 3 4 5 6 7} 5 3 1] +test listrep-3.19.1 { + Deletes from front half of small unshared span list results in + movement of smaller front segment - lremove version +} -constraints testlistrep -body { + set l [lremove [freeSpaceBoth] $one $two] + validate $l + list $l [leadSpace $l] [tailSpace $l] [hasSpan $l 5 6] +} -result [list {0 3 4 5 6 7} 5 3 1] + test listrep-3.20 { Deletes from front half of large unshared span list results in - movement of smaller front segment + movement of smaller front segment - lreplace version } -constraints testlistrep -body { set l [lreplace [freeSpaceBoth 1000 10 10] $one $two] validate $l list $l [leadSpace $l] [tailSpace $l] [hasSpan $l 12 998] } -result [list [list 0 {*}[irange 3 999]] 12 10 1] +test listrep-3.20.1 { + Deletes from front half of large unshared span list results in + movement of smaller front segment - lremove version +} -constraints testlistrep -body { + set l [lremove [freeSpaceBoth 1000 10 10] $one $two] + validate $l + list $l [leadSpace $l] [tailSpace $l] [hasSpan $l 12 998] +} -result [list [list 0 {*}[irange 3 999]] 12 10 1] + test listrep-3.21 { Deletes from back half of small unshared span list results in - movement of smaller back segment + movement of smaller back segment - lreplace version } -constraints testlistrep -body { set l [lreplace [freeSpaceBoth] $end-2 $end-1] validate $l list $l [leadSpace $l] [tailSpace $l] [hasSpan $l 3 6] } -result [list {0 1 2 3 4 7} 3 5 1] -test listrep-3.22 { +test listrep-3.21.1 { Deletes from back half of small unshared span list results in - movement of smaller back segment + movement of smaller back segment - lremove version +} -constraints testlistrep -body { + set l [lremove [freeSpaceBoth] $end-2 $end-1] + validate $l + list $l [leadSpace $l] [tailSpace $l] [hasSpan $l 3 6] +} -result [list {0 1 2 3 4 7} 3 5 1] + +test listrep-3.22 { + Deletes from back half of large unshared span list results in + movement of smaller back segment - lreplace version } -constraints testlistrep -body { set l [lreplace [freeSpaceBoth 1000 10 10] $end-2 $end-1] validate $l list $l [leadSpace $l] [tailSpace $l] [hasSpan $l 10 998] } -result [list [list {*}[irange 0 996] 999] 10 12 1] +test listrep-3.22.1 { + Deletes from back half of large unshared span list results in + movement of smaller back segment - lremove version +} -constraints testlistrep -body { + set l [lremove [freeSpaceBoth 1000 10 10] $end-2 $end-1] + validate $l + list $l [leadSpace $l] [tailSpace $l] [hasSpan $l 10 998] +} -result [list [list {*}[irange 0 996] 999] 10 12 1] + test listrep-3.23 { Replacement of elements at front with same number elements in unshared - spanned list is in-place + spanned list is in-place - lreplace version } -body { set l [lreplace [freeSpaceBoth] $zero $one 10 11] list $l [leadSpace $l] [tailSpace $l] } -result [list {10 11 2 3 4 5 6 7} 3 3] +test listrep-3.23.1 { + Replacement of elements at front with same number elements in unshared + spanned list is in-place - lset version +} -body { + set l [freeSpaceBoth] + lset l $zero 10 + list $l [leadSpace $l] [tailSpace $l] +} -result [list {10 1 2 3 4 5 6 7} 3 3] + test listrep-3.24 { Replacement of elements at front with fewer elements in unshared - spanned list expands leading space + spanned list expands leading space - lreplace version } -body { set l [lreplace [freeSpaceBoth] $zero $four 10] list $l [leadSpace $l] [tailSpace $l] @@ -813,17 +1714,29 @@ test listrep-3.27 { test listrep-3.28 { Replacement of elements at back with same number of elements in unshared - spanned list is in-place + spanned list is in-place - lreplace version } -body { set l [lreplace [freeSpaceBoth] $end-1 $end 10 11] + validate $l list $l [leadSpace $l] [tailSpace $l] } -result [list {0 1 2 3 4 5 10 11} 3 3] +test listrep-3.28.1 { + Replacement of elements at back with same number of elements in unshared + spanned list is in-place - lset version +} -body { + set l [freeSpaceBoth] + lset l $end 10 + validate $l + list $l [leadSpace $l] [tailSpace $l] +} -result [list {0 1 2 3 4 5 6 10} 3 3] + test listrep-3.29 { Replacement of elements at back with fewer elements in unshared spanned list expands tail space } -body { set l [lreplace [freeSpaceBoth] $end-2 $end 10] + validate $l list $l [leadSpace $l] [tailSpace $l] } -result [list {0 1 2 3 4 10} 3 5] @@ -832,6 +1745,7 @@ test listrep-3.30 { spanned list with sufficient tail space shrinks tailspace } -body { set l [lreplace [freeSpaceBoth] $end-1 $end 10 11 12] + validate $l list $l [leadSpace $l] [tailSpace $l] } -result [list {0 1 2 3 4 5 10 11 12} 3 2] @@ -840,6 +1754,7 @@ test listrep-3.31 { with insufficient tail space but enough total free space moves up the span } -body { set l [lreplace [freeSpaceBoth 8 2 2] $end-1 $end 10 11 12 13 14] + validate $l list $l [leadSpace $l] [tailSpace $l] } -result [list {0 1 2 3 4 5 10 11 12 13 14} 0 1] @@ -849,22 +1764,35 @@ test listrep-3.32 { of realloc() } -body { set l [lreplace [freeSpaceBoth 8 1 1] $end-1 $end 10 11 12 13 14] + validate $l list $l [leadSpace $l] [tailSpace $l] } -result [list {0 1 2 3 4 5 10 11 12 13 14} 1 10] test listrep-3.33 { Replacement of elements in the middle in an unshared spanned list with - the same number of elements + the same number of elements - lreplace version } -body { set l [lreplace [freeSpaceBoth] $two $four 10 11 12] + validate $l list $l [leadSpace $l] [tailSpace $l] } -result [list {0 1 10 11 12 5 6 7} 3 3] +test listrep-3.33.1 { + Replacement of elements in the middle in an unshared spanned list with + the same number of elements - lset version +} -body { + set l [freeSpaceBoth] + lset l $two 10 + validate $l + list $l [leadSpace $l] [tailSpace $l] +} -result [list {0 1 10 3 4 5 6 7} 3 3] + test listrep-3.34 { Replacement of elements in an unshared spanned list with fewer elements in the front half moves the front (smaller) segment } -body { set l [lreplace [freeSpaceBoth] $two $four 10 11] + validate $l list $l [leadSpace $l] [tailSpace $l] } -result [list {0 1 10 11 5 6 7} 4 3] @@ -873,6 +1801,7 @@ test listrep-3.35 { in the back half moves the tail (smaller) segment } -body { set l [lreplace [freeSpaceBoth] $end-2 $end-1 10] + validate $l list $l [leadSpace $l] [tailSpace $l] } -result [list {0 1 2 3 4 10 7} 3 4] @@ -882,6 +1811,7 @@ test listrep-3.36 { (front case) } -body { set l [lreplace [freeSpaceBoth] $one $two 8 9 10] + validate $l list $l [leadSpace $l] [tailSpace $l] } -result [list {0 8 9 10 3 4 5 6 7} 2 3] @@ -891,6 +1821,7 @@ test listrep-3.37 { (back case) } -body { set l [lreplace [freeSpaceBoth] $end-2 $end-1 8 9 10] + validate $l list $l [leadSpace $l] [tailSpace $l] } -result [list {0 1 2 3 4 8 9 10 7} 3 2] @@ -899,6 +1830,7 @@ test listrep-3.38 { when only front has room } -body { set l [lreplace [freeSpaceBoth 8 3 1] $end-1 $end-1 8 9 10] + validate $l list $l [leadSpace $l] [tailSpace $l] } -result [list {0 1 2 3 4 5 8 9 10 7} 1 1] @@ -907,6 +1839,7 @@ test listrep-3.39 { when only back has room } -body { set l [lreplace [freeSpaceBoth 8 1 3] $one $one 8 9 10] + validate $l list $l [leadSpace $l] [tailSpace $l] } -result [list {0 8 9 10 2 3 4 5 6 7} 1 1] @@ -915,6 +1848,7 @@ test listrep-3.40 { when neither send has enough room by itself } -body { set l [lreplace [freeSpaceBoth] $one $one 8 9 10 11 12] + validate $l list $l [leadSpace $l] [tailSpace $l] } -result [list {0 8 9 10 11 12 2 3 4 5 6 7} 1 1] @@ -924,6 +1858,7 @@ test listrep-3.41 { end has more space because of realloc() } -body { set l [lreplace [freeSpaceBoth 8 1 1] $one $one 8 9 10 11 12] + validate $l list $l [leadSpace $l] [tailSpace $l] } -result [list {0 8 9 10 11 12 2 3 4 5 6 7} 1 11] @@ -932,17 +1867,29 @@ test listrep-3.41 { test listrep-4.1 { Inserts in front of shared spanned list with used elements in lead space - creates a new list rep without more lead space than tail space. + creates new list rep with more lead than tail space - linsert version } -constraints testlistrep -body { set master [freeSpaceNone 1000] set spanl [lrange $master $two $end-2] set l [linsert $spanl $zero -1] + validate $l list $master $spanl $l [leadSpaceMore $l] [hasSpan $l] [repStoreRefCount $master] [repStoreRefCount $spanl] [repStoreRefCount $l] } -result [list [irange 0 999] [irange 2 997] [list -1 {*}[irange 2 997]] 1 1 2 2 1] +test listrep-4.1.1 { + Inserts in front of shared spanned list with used elements in lead space + creates new list rep with more lead than tail space - lreplace version +} -constraints testlistrep -body { + set master [freeSpaceNone 1000] + set spanl [lrange $master $two $end-2] + set l [lreplace $spanl $zero -1 -2] + validate $l + list $master $spanl $l [leadSpaceMore $l] [hasSpan $l] [repStoreRefCount $master] [repStoreRefCount $spanl] [repStoreRefCount $l] +} -result [list [irange 0 999] [irange 2 997] [list -2 {*}[irange 2 997]] 1 1 2 2 1] + test listrep-4.2 { Inserts in front of shared spanned list with orphaned leading elements - allocate a new list rep with more lead space than tail space. + allocate a new list rep with more lead than tail space - linsert version TODO - ideally this should garbage collect the orphans and reuse the lead space but that needs a "lprepend" command else the listrep operand is shared and hence orphans cannot be freed @@ -951,16 +1898,44 @@ test listrep-4.2 { set spanl [lrange $master $two $end-2] unset master; # So elements at 0, 1 are not used set l [linsert $spanl $zero -1] + validate $l list $spanl $l [sameStore $spanl $l] [leadSpaceMore $l] [hasSpan $l] [repStoreRefCount $spanl] [repStoreRefCount $l] } -result [list [irange 2 997] [list -1 {*}[irange 2 997]] 0 1 1 1 1] +test listrep-4.2.1 { + Inserts in front of shared spanned list with orphaned leading elements + allocate a new list rep with more lead than tail space - lreplace version + TODO - ideally this should garbage collect the orphans and reuse the lead space + but that needs a "lprepend" command else the listrep operand is shared and hence + orphans cannot be freed +} -constraints testlistrep -body { + set master [freeSpaceLead 1000 100] + set spanl [lrange $master $two $end-2] + unset master; # So elements at 0, 1 are not used + set l [lreplace $spanl $zero -1 -2] + validate $l + list $spanl $l [sameStore $spanl $l] [leadSpaceMore $l] [hasSpan $l] [repStoreRefCount $spanl] [repStoreRefCount $l] +} -result [list [irange 2 997] [list -2 {*}[irange 2 997]] 0 1 1 1 1] + test listrep-4.3 { Inserts in front of shared spanned list where span is at front of used - space reuses the same list store. + space reuses the same list store - linsert version } -constraints testlistrep -body { set master [freeSpaceLead 1000 100] set spanl [lrange $master $zero $end-2] set l [linsert $spanl $zero -1] + validate $l + list $spanl $l [sameStore $spanl $l] [leadSpace $l] [tailSpace $l] [hasSpan $l] [repStoreRefCount $spanl] [repStoreRefCount $l] +} -result [list [irange 0 997] [irange -1 997] 1 99 0 1 3 3] + +test listrep-4.3.1 { + Inserts in front of shared spanned list where span is at front of used + space reuses the same list store - lreplace version +} -constraints testlistrep -body { + set master [freeSpaceLead 1000 100] + set spanl [lrange $master $zero $end-2] + set l [lreplace $spanl $zero -1 -1] + validate $l list $spanl $l [sameStore $spanl $l] [leadSpace $l] [tailSpace $l] [hasSpan $l] [repStoreRefCount $spanl] [repStoreRefCount $l] } -result [list [irange 0 997] [irange -1 997] 1 99 0 1 3 3] @@ -968,73 +1943,258 @@ test listrep-4.4 { Inserts in front of shared spanned list where span is at front of used space allocates new listrep if lead space insufficient even if total free space is sufficient. New listrep should have more lead space than tail space. + - linsert version } -constraints testlistrep -body { set master [freeSpaceBoth 1000 2] set spanl [lrange $master $zero $end-2] set l [linsert $spanl $zero -3 -2 -1] + validate $l + list $spanl $l [sameStore $spanl $l] [leadSpaceMore $l] [hasSpan $l] [repStoreRefCount $spanl] [repStoreRefCount $l] +} -result [list [irange 0 997] [irange -3 997] 0 1 1 2 1] + +test listrep-4.4.1 { + Inserts in front of shared spanned list where span is at front of used + space allocates new listrep if lead space insufficient even if total free space + is sufficient. New listrep should have more lead space than tail space. + - lreplace version +} -constraints testlistrep -body { + set master [freeSpaceBoth 1000 2] + set spanl [lrange $master $zero $end-2] + set l [lreplace $spanl $zero -1 -3 -2 -1] + validate $l list $spanl $l [sameStore $spanl $l] [leadSpaceMore $l] [hasSpan $l] [repStoreRefCount $spanl] [repStoreRefCount $l] } -result [list [irange 0 997] [irange -3 997] 0 1 1 2 1] test listrep-4.5 { Inserts in back of shared spanned list where span is at end of used space still allocates a new listrep and trailing space is more than leading space + - linsert version } -constraints testlistrep -body { set master [freeSpaceBoth 1000 2] set spanl [lrange $master $two $end] set l [linsert $spanl $end 1000] + validate $l + list $spanl $l [sameStore $spanl $l] [tailSpaceMore $l] [hasSpan $l] [repStoreRefCount $spanl] [repStoreRefCount $l] +} -result [list [irange 2 999] [irange 2 1000] 0 1 1 2 1] + +test listrep-4.5.1 { + Inserts in back of shared spanned list where span is at end of used space + still allocates a new listrep and trailing space is more than leading space + - lreplace version +} -constraints testlistrep -body { + set master [freeSpaceBoth 1000 2] + set spanl [lrange $master $two $end] + set l [lreplace $spanl $end+1 $end+1 1000] + validate $l list $spanl $l [sameStore $spanl $l] [tailSpaceMore $l] [hasSpan $l] [repStoreRefCount $spanl] [repStoreRefCount $l] } -result [list [irange 2 999] [irange 2 1000] 0 1 1 2 1] +test listrep-4.5.2 { + Inserts in back of shared spanned list where span is at end of used space + still allocates a new listrep and trailing space is more than leading space + - lappend version +} -constraints testlistrep -body { + set master [freeSpaceBoth 1000 2] + set l [lrange $master $two $end] + lappend l 1000 + validate $l + list $l [sameStore $master $l] [tailSpaceMore $l] [hasSpan $l] [repStoreRefCount $l] +} -result [list [irange 2 1000] 0 1 1 1] + +test listrep-4.5.3 { + Inserts in back of shared spanned list where span is at end of used space + still allocates a new listrep and trailing space is more than leading space + - lset version +} -constraints testlistrep -body { + set master [freeSpaceBoth 1000 2] + set l [lrange $master $two $end] + lset l $end+1 1000 + validate $l + list $l [sameStore $master $l] [tailSpaceMore $l] [hasSpan $l] [repStoreRefCount $l] +} -result [list [irange 2 1000] 0 1 1 1] + + test listrep-4.6 { Inserts in middle of shared spanned list allocates a new listrep with equal - lead and tail space + lead and tail space - linsert version } -constraints testlistrep -body { set master [freeSpaceBoth 1000 2] set spanl [lrange $master $two $end-2] set i 200 set l [linsert $spanl $i 1000] + validate $l + list $spanl $l [sameStore $spanl $l] [spaceEqual $l] [hasSpan $l] [repStoreRefCount $spanl] [repStoreRefCount $l] +} -result [list [irange 2 997] [concat [irange 2 201] 1000 [irange 202 997]] 0 1 1 2 1] + +test listrep-4.6.1 { + Inserts in middle of shared spanned list allocates a new listrep with equal + lead and tail space - lreplace version +} -constraints testlistrep -body { + set master [freeSpaceBoth 1000 2] + set spanl [lrange $master $two $end-2] + set i 200 + set l [lreplace $spanl $i -1 1000] + validate $l list $spanl $l [sameStore $spanl $l] [spaceEqual $l] [hasSpan $l] [repStoreRefCount $spanl] [repStoreRefCount $l] } -result [list [irange 2 997] [concat [irange 2 201] 1000 [irange 202 997]] 0 1 1 2 1] test listrep-4.7 { Deletes from front of shared spanned list do not create a new allocation + - lreplace version } -constraints testlistrep -body { set master [freeSpaceNone 1000] set spanl [lrange $master $two $end-2] set l [lreplace $spanl $zero $one] + validate $l + list $spanl $l [sameStore $spanl $l] [hasSpan $l] [repStoreRefCount $spanl] [repStoreRefCount $l] +} -result [list [irange 2 997] [irange 4 997] 1 1 3 3] + +test listrep-4.7.1 { + Deletes from front of shared spanned list do not create a new allocation + - lremove version +} -constraints testlistrep -body { + set master [freeSpaceNone 1000] + set spanl [lrange $master $two $end-2] + set l [lremove $spanl $zero $one] + validate $l + list $spanl $l [sameStore $spanl $l] [hasSpan $l] [repStoreRefCount $spanl] [repStoreRefCount $l] +} -result [list [irange 2 997] [irange 4 997] 1 1 3 3] + +test listrep-4.7.2 { + Deletes from front of shared spanned list do not create a new allocation + - lrange version +} -constraints testlistrep -body { + set master [freeSpaceNone 1000] + set spanl [lrange $master $two $end-2] + set l [lrange $spanl $two $end] + validate $l list $spanl $l [sameStore $spanl $l] [hasSpan $l] [repStoreRefCount $spanl] [repStoreRefCount $l] } -result [list [irange 2 997] [irange 4 997] 1 1 3 3] +test listrep-4.7.3 { + Deletes from front of shared spanned list do not create a new allocation + - lassign version +} -constraints testlistrep -body { + set master [freeSpaceNone 1000] + set spanl [lrange $master $two $end-2] + set l [lassign $spanl e] + validate $l + list $e $spanl $l [sameStore $spanl $l] [hasSpan $l] [repStoreRefCount $spanl] [repStoreRefCount $l] +} -result [list 2 [irange 2 997] [irange 3 997] 1 1 3 3] + +test listrep-4.7.4 { + Deletes from front of shared spanned list do not create a new allocation + - lpop version +} -constraints testlistrep -body { + set master [freeSpaceNone 1000] + set l [lrange $master $two $end-2] + set e [lpop l $zero] + validate $l + list $e $l [sameStore $master $l] [hasSpan $l] [repStoreRefCount $l] +} -result [list 2 [irange 3 997] 1 1 2] + test listrep-4.8 { Deletes from end of shared spanned list do not create a new allocation + - lreplace version } -constraints testlistrep -body { set master [freeSpaceNone 1000] set spanl [lrange $master $two $end-2] set l [lreplace $spanl $end-1 $end] + validate $l list $spanl $l [sameStore $spanl $l] [hasSpan $l] [repStoreRefCount $spanl] [repStoreRefCount $l] } -result [list [irange 2 997] [irange 2 995] 1 1 3 3] +test listrep-4.8.1 { + Deletes from end of shared spanned list do not create a new allocation + - lremove version +} -constraints testlistrep -body { + set master [freeSpaceNone 1000] + set spanl [lrange $master $two $end-2] + set l [lremove $spanl $end-1 $end] + validate $l + list $spanl $l [sameStore $spanl $l] [hasSpan $l] [repStoreRefCount $spanl] [repStoreRefCount $l] +} -result [list [irange 2 997] [irange 2 995] 1 1 3 3] + +test listrep-4.8.2 { + Deletes from end of shared spanned list do not create a new allocation + - lrange version +} -constraints testlistrep -body { + set master [freeSpaceNone 1000] + set spanl [lrange $master $two $end-2] + set l [lrange $spanl 0 $end-2] + validate $l + list $spanl $l [sameStore $spanl $l] [hasSpan $l] [repStoreRefCount $spanl] [repStoreRefCount $l] +} -result [list [irange 2 997] [irange 2 995] 1 1 3 3] + +test listrep-4.8.3 { + Deletes from end of shared spanned list do not create a new allocation + - lpop version +} -constraints testlistrep -body { + set master [freeSpaceNone 1000] + set l [lrange $master $two $end-2] + set e [lpop l] + validate $l + list $e $l [sameStore $master $l] [hasSpan $l] [repStoreRefCount $l] +} -result [list 997 [irange 2 996] 1 1 2] + test listrep-4.9 { Deletes from middle of shared spanned list creates a new allocation with - equal free space at front and back + equal free space at front and back - lreplace version } -constraints testlistrep -body { set master [freeSpaceNone 1000] set spanl [lrange $master $two $end-2] set i 500 set l [lreplace $spanl $i $i] + validate $l + list $spanl $l [sameStore $spanl $l] [hasSpan $l] [spaceEqual $l] [repStoreRefCount $spanl] [repStoreRefCount $l] +} -result [list [irange 2 997] [concat [irange 2 501] [irange 503 997]] 0 1 1 2 1] + +test listrep-4.9.1 { + Deletes from middle of shared spanned list creates a new allocation with + equal free space at front and back - lremove version +} -constraints testlistrep -body { + set master [freeSpaceNone 1000] + set spanl [lrange $master $two $end-2] + set i 500 + set l [lremove $spanl $i $i] + validate $l list $spanl $l [sameStore $spanl $l] [hasSpan $l] [spaceEqual $l] [repStoreRefCount $spanl] [repStoreRefCount $l] } -result [list [irange 2 997] [concat [irange 2 501] [irange 503 997]] 0 1 1 2 1] +test listrep-4.9.2 { + Deletes from middle of shared spanned list creates a new allocation with + equal free space at front and back - lpop version +} -constraints testlistrep -body { + set master [freeSpaceNone 1000] + set l [lrange $master $two $end-2] + set i 500 + set e [lpop l $i] + validate $l + list $e $l [sameStore $master $l] [hasSpan $l] [spaceEqual $l] [repStoreRefCount $l] +} -result [list 502 [concat [irange 2 501] [irange 503 997]] 0 1 1 1] + test listrep-4.10 { Replacements with same number of elements at front of shared spanned list - create a new allocation with more space in front + create a new allocation with more space in front - lreplace version } -constraints testlistrep -body { set master [freeSpaceNone 1000] set spanl [lrange $master $two $end-2] set l [lreplace $spanl $zero $one -2 -1] + validate $l list $spanl $l [sameStore $spanl $l] [leadSpaceMore $l] [hasSpan $l] [repStoreRefCount $spanl] [repStoreRefCount $l] } -result [list [irange 2 997] [concat {-2 -1} [irange 4 997]] 0 1 1 2 1] +test listrep-4.10.1 { + Replacements with same number of elements at front of shared spanned list + create a new allocation with exact size +} -constraints testlistrep -body { + set master [freeSpaceNone 1000] + set l [lrange $master $two $end-2] + lset l $zero -1 + validate $l + list $l [sameStore $master $l] [hasSpan $l] [repStoreRefCount $l] +} -result [list [concat {-1} [irange 3 997]] 0 0 1] + test listrep-4.11 { Replacements with fewer elements at front of shared spanned list create a new allocation with more space in front @@ -1042,6 +2202,7 @@ test listrep-4.11 { set master [freeSpaceNone 1000] set spanl [lrange $master $two $end-2] set l [lreplace $spanl $zero $one -1] + validate $l list $spanl $l [sameStore $spanl $l] [leadSpaceMore $l] [hasSpan $l] [repStoreRefCount $spanl] [repStoreRefCount $l] } -result [list [irange 2 997] [concat {-1} [irange 4 997]] 0 1 1 2 1] @@ -1052,19 +2213,32 @@ test listrep-4.12 { set master [freeSpaceNone 1000] set spanl [lrange $master $two $end-2] set l [lreplace $spanl $zero $one -3 -2 -1] + validate $l list $spanl $l [sameStore $spanl $l] [leadSpaceMore $l] [hasSpan $l] [repStoreRefCount $spanl] [repStoreRefCount $l] } -result [list [irange 2 997] [concat {-3 -2 -1} [irange 4 997]] 0 1 1 2 1] test listrep-4.13 { Replacements with same number of elements at back of shared spanned list - create a new allocation with more space in back + create a new allocation with more space in back - lreplace version } -constraints testlistrep -body { set master [freeSpaceNone 1000] set spanl [lrange $master $two $end-2] set l [lreplace $spanl $end-1 $end 1000 1001] + validate $l list $spanl $l [sameStore $spanl $l] [tailSpaceMore $l] [hasSpan $l] [repStoreRefCount $spanl] [repStoreRefCount $l] } -result [list [irange 2 997] [concat [irange 2 995] {1000 1001}] 0 1 1 2 1] +test listrep-4.13.1 { + Replacements with same number of elements at back of shared spanned list + create a new exact allocation with no span - lset version +} -constraints testlistrep -body { + set master [freeSpaceNone 1000] + set l [lrange $master $two $end-2] + lset l $end 1000 + validate $l + list $l [sameStore $master $l] [tailSpace $l] [hasSpan $l] [repStoreRefCount $l] +} -result [list [concat [irange 2 996] {1000}] 0 0 0 1] + test listrep-4.14 { Replacements with fewer elements at back of shared spanned list create a new allocation with more space in back @@ -1072,6 +2246,7 @@ test listrep-4.14 { set master [freeSpaceNone 1000] set spanl [lrange $master $two $end-2] set l [lreplace $spanl $end-1 $end 1000] + validate $l list $spanl $l [sameStore $spanl $l] [tailSpaceMore $l] [hasSpan $l] [repStoreRefCount $spanl] [repStoreRefCount $l] } -result [list [irange 2 997] [concat [irange 2 995] {1000}] 0 1 1 2 1] @@ -1082,6 +2257,7 @@ test listrep-4.15 { set master [freeSpaceNone 1000] set spanl [lrange $master $two $end-2] set l [lreplace $spanl $end-1 $end 1000 1001 1002] + validate $l list $spanl $l [sameStore $spanl $l] [tailSpaceMore $l] [hasSpan $l] [repStoreRefCount $spanl] [repStoreRefCount $l] } -result [list [irange 2 997] [concat [irange 2 995] {1000 1001 1002}] 0 1 1 2 1] @@ -1092,9 +2268,21 @@ test listrep-4.16 { set master [freeSpaceNone 1000] set spanl [lrange $master $two $end-2] set l [lreplace $spanl $one $two -2 -1] + validate $l list $spanl $l [sameStore $spanl $l] [spaceEqual $l] [hasSpan $l] [repStoreRefCount $spanl] [repStoreRefCount $l] } -result [list [irange 2 997] [concat {2 -2 -1} [irange 5 997]] 0 1 1 2 1] +test listrep-4.16.1 { + Replacements with same number of elements in middle of shared spanned list + create a new exact allocation - lset version +} -constraints testlistrep -body { + set master [freeSpaceNone 1000] + set l [lrange $master $two $end-2] + lset l $one -2 + validate $l + list $l [sameStore $master $l] [hasSpan $l] [tailSpace $l] [repStoreRefCount $l] +} -result [list [concat {2 -2} [irange 4 997]] 0 0 0 1] + test listrep-4.17 { Replacements with fewer elements in middle of shared spanned list create a new allocation with equal lead and tail sapce @@ -1102,6 +2290,7 @@ test listrep-4.17 { set master [freeSpaceNone 1000] set spanl [lrange $master $two $end-2] set l [lreplace $spanl $end-2 $end-1 1000] + validate $l list $spanl $l [sameStore $spanl $l] [spaceEqual $l] [hasSpan $l] [repStoreRefCount $spanl] [repStoreRefCount $l] } -result [list [irange 2 997] [concat [irange 2 994] {1000 997}] 0 1 1 2 1] @@ -1112,16 +2301,22 @@ test listrep-4.18 { set master [freeSpaceNone 1000] set spanl [lrange $master $two $end-2] set l [lreplace $spanl $end-2 $end-1 1000 1001 1002] + validate $l list $spanl $l [sameStore $spanl $l] [spaceEqual $l] [hasSpan $l] [repStoreRefCount $spanl] [repStoreRefCount $l] } -result [list [irange 2 997] [concat [irange 2 994] {1000 1001 1002 997}] 0 1 1 2 1] +# +# Tests when tcl-obj is shared but listrep is not (lappend, lset etc.) -# TBD - tests when tcl-obj is shared but listrep is not (lappend, lset etc.) +# TBD - canonical output on shared and spanned lists (see 1.10) # TBD - range and subrange tests # - spanned and unspanned # TBD - zombie tests # -# Special case - nested lremove (does not seem tested in 8.6) +# Special cases +# - nested lset (does not seem tested in 8.6) +# - lremove with multiple indices +# - nested lpop ::tcltest::cleanupTests return -- cgit v0.12 From a66ed8e23823b7ddefdb8867d3f4d5dc5dfd44d6 Mon Sep 17 00:00:00 2001 From: sebres Date: Wed, 27 Jul 2022 15:56:13 +0000 Subject: fixes [4eb3a155ac] and similar segfaults: reset corresponding bodyPtr->procPtr if procPtr gets released in TclProcCleanupProc, also recompile body if its procPtr is not the same as supplied. --- generic/tclProc.c | 17 +++++++++++++++-- 1 file changed, 15 insertions(+), 2 deletions(-) diff --git a/generic/tclProc.c b/generic/tclProc.c index 59153b8..7550bfa 100644 --- a/generic/tclProc.c +++ b/generic/tclProc.c @@ -1576,13 +1576,16 @@ TclPushProcCallFrame( * is up-to-date), the namespace must match (so variable handling * is right) and the resolverEpoch must match (so that new shadowed * commands and/or resolver changes are considered). + * Ensure the ByteCode's procPtr is the same (or it's precompiled). */ codePtr = procPtr->bodyPtr->internalRep.twoPtrValue.ptr1; if (((Interp *) *codePtr->interpHandle != iPtr) || (codePtr->compileEpoch != iPtr->compileEpoch) || (codePtr->nsPtr != nsPtr) - || (codePtr->nsEpoch != nsPtr->resolverEpoch)) { + || (codePtr->nsEpoch != nsPtr->resolverEpoch) + || ((codePtr->procPtr != procPtr) && procPtr->bodyPtr->bytes) + ) { goto doCompilation; } } else { @@ -1920,6 +1923,7 @@ TclProcCompileProc( * procPtr->numCompiledLocals if new local variables are found while * compiling. * + * Ensure the ByteCode's procPtr is the same (or it is pure precompiled). * Precompiled procedure bodies, however, are immutable and therefore they * are not recompiled, even if things have changed. */ @@ -1928,7 +1932,9 @@ TclProcCompileProc( if (((Interp *) *codePtr->interpHandle == iPtr) && (codePtr->compileEpoch == iPtr->compileEpoch) && (codePtr->nsPtr == nsPtr) - && (codePtr->nsEpoch == nsPtr->resolverEpoch)) { + && (codePtr->nsEpoch == nsPtr->resolverEpoch) + && ((codePtr->procPtr == procPtr) || !bodyPtr->bytes) + ) { return TCL_OK; } @@ -2139,6 +2145,13 @@ TclProcCleanupProc( Interp *iPtr = procPtr->iPtr; if (bodyPtr != NULL) { + /* procPtr is stored in body's ByteCode, so ensure to reset it. */ + if (bodyPtr->typePtr == &tclByteCodeType) { + ByteCode *codePtr = bodyPtr->internalRep.twoPtrValue.ptr1; + if (codePtr->procPtr == procPtr) { + codePtr->procPtr = NULL; + } + } Tcl_DecrRefCount(bodyPtr); } for (localPtr = procPtr->firstLocalPtr; localPtr != NULL; ) { -- cgit v0.12 From 25b5f03d7a8f8c50e31c2498d9b9fef6e48c51f5 Mon Sep 17 00:00:00 2001 From: apnadkarni Date: Wed, 27 Jul 2022 16:19:36 +0000 Subject: Final prep for TIP625 vote --- generic/tclListObj.c | 28 +++++++++++-------- tests/listRep.test | 78 +++++++++++++++++++++++++++++++++++++++++++++------- 2 files changed, 84 insertions(+), 22 deletions(-) diff --git a/generic/tclListObj.c b/generic/tclListObj.c index 6e195e3..43307ad 100644 --- a/generic/tclListObj.c +++ b/generic/tclListObj.c @@ -12,8 +12,11 @@ #include "tclInt.h" #include -/* TODO - memmove is fast. Measure at what size we should prefer memmove - (for unshared objects only) in lieu of range operations */ +/* + * TODO - memmove is fast. Measure at what size we should prefer memmove + * (for unshared objects only) in lieu of range operations. On the other + * hand, more cache dirtied? + */ /* * Macros for validation and bug checking. @@ -1451,7 +1454,7 @@ ListRepRange( if (!preserveSrcRep) { /* T:listrep-1.{4,5,8,9},2.{4:7},3.{15:18},4.{7,8} */ ListRepFreeUnreferenced(srcRepPtr); - } + } /* else T:listrep-2.{4.2,4.3,5.2,5.3,6.2,7.2,8.1} */ if (rangeStart < 0) { rangeStart = 0; @@ -1486,7 +1489,7 @@ ListRepRange( */ if (rangeStart == 0 && rangeEnd == (numSrcElems-1)) { /* Option 0 - entire list. This may be used to canonicalize */ - /* T:listrep-1.10.1 */ + /* T:listrep-1.10.1,2.8.1 */ *rangeRepPtr = *srcRepPtr; /* Not ref counts not incremented */ } else if (rangeStart == 0 && (!preserveSrcRep) && (!ListRepIsShared(srcRepPtr) && srcRepPtr->spanPtr == NULL)) { @@ -1513,7 +1516,7 @@ ListRepRange( if (!preserveSrcRep && srcRepPtr->spanPtr && srcRepPtr->spanPtr->refCount <= 1) { /* If span is not shared reuse it */ - /* T:listrep-3.{16,18} */ + /* T:listrep-2.7.3,3.{16,18} */ srcRepPtr->spanPtr->spanStart = spanStart; srcRepPtr->spanPtr->spanLength = rangeLen; *rangeRepPtr = *srcRepPtr; @@ -1636,7 +1639,7 @@ TclListObjRange( ListRepRange(&listRep, rangeStart, rangeEnd, isShared, &resultRep); if (isShared) { - /* T:listrep-1.10.1 */ + /* T:listrep-1.10.1,2.{4.2,4.3,5.2,5.3,6.2,7.2,8.1} */ TclNewObj(listObj); } /* T:listrep-1.{4.3,5.1,5.2} */ ListObjReplaceRepAndInvalidate(listObj, &resultRep); @@ -1846,7 +1849,7 @@ Tcl_ListObjAppendList( LIST_ASSERT(listRep.spanPtr->spanStart == listRep.storePtr->firstUsed); listRep.spanPtr->spanLength = finalLen; - } + } /* else T:listrep-3.6.3 */ LIST_ASSERT(ListRepStart(&listRep) == listRep.storePtr->firstUsed); LIST_ASSERT(ListRepLength(&listRep) == finalLen); LISTREP_CHECK(&listRep); @@ -2179,7 +2182,7 @@ Tcl_ListObjReplace( if (numToDelete == 0) { /* Case (2a) - Append to list. */ if (first == origListLen) { - /* T:listrep-1.11,2.9,3.{5,6} */ + /* T:listrep-1.11,2.9,3.{5,6},2.2.1 */ return TclListObjAppendElements( interp, listObj, numToInsert, insertObjs); } @@ -2740,7 +2743,7 @@ TclLsetList( && TclGetIntForIndexM(NULL, indexArgObj, ListSizeT_MAX - 1, &index) == TCL_OK) { /* indexArgPtr designates a single index. */ - /* T:listrep-1.{2.1,12.1,15.1,19.1} */ + /* T:listrep-1.{2.1,12.1,15.1,19.1},2.{2.3,9.3,10.1,13.1,16.1}, 3.{4,5,6}.3 */ return TclLsetFlat(interp, listObj, 1, &indexArgObj, valueObj); } @@ -3023,13 +3026,13 @@ TclLsetFlat( len = -1; TclListObjLengthM(NULL, subListObj, &len); if (valueObj == NULL) { - /* T:listrep-1.{4.2,5.4,6.1,7.1,8.3} */ + /* T:listrep-1.{4.2,5.4,6.1,7.1,8.3},2.{4,5}.4 */ Tcl_ListObjReplace(NULL, subListObj, index, 1, 0, NULL); } else if (index == len) { - /* T:listrep-1.2.1 */ + /* T:listrep-1.2.1,2.{2.3,9.3},3.{4,5,6}.3 */ Tcl_ListObjAppendElement(NULL, subListObj, valueObj); } else { - /* T:listrep-1.{12.1,15.1,19.1} */ + /* T:listrep-1.{12.1,15.1,19.1},2.{10,13,16}.1 */ TclListObjSetElement(NULL, subListObj, index, valueObj); TclInvalidateStringRep(subListObj); } @@ -3102,6 +3105,7 @@ TclListObjSetElement( /* Replace a shared internal rep with an unshared copy */ if (listRep.storePtr->refCount > 1) { ListRep newInternalRep; + /* T:listrep-2.{10,13,16}.1 */ /* TODO - leave extra space? */ ListRepClone(&listRep, &newInternalRep, LISTREP_PANIC_ON_FAIL); listRep = newInternalRep; diff --git a/tests/listRep.test b/tests/listRep.test index 9cfaeb2..7d0dda2 100644 --- a/tests/listRep.test +++ b/tests/listRep.test @@ -2306,17 +2306,75 @@ test listrep-4.18 { } -result [list [irange 2 997] [concat [irange 2 994] {1000 1001 1002 997}] 0 1 1 2 1] # -# Tests when tcl-obj is shared but listrep is not (lappend, lset etc.) +# Tests when tcl-obj is shared but listrep is not. This is to ensure that +# checks for shared values check the Tcl_Obj reference counts in addition to +# the list internal representation reference counts. Probably some or all +# cases are already covered elsewhere but easier to just test than look. +test listrep-5.1 { + Verify that operation on a shared Tcl_Obj with a single-ref, spanless + list representation only modifies the target object - lappend version +} -constraints testlistrep -body { + set l [freeSpaceNone] + set l2 $l + set same [sameStore $l $l2] + lappend l 8 + list $same $l $l2 [sameStore $l $l2] +} -result [list 1 [irange 0 8] [irange 0 7] 0] -# TBD - canonical output on shared and spanned lists (see 1.10) -# TBD - range and subrange tests -# - spanned and unspanned -# TBD - zombie tests -# -# Special cases -# - nested lset (does not seem tested in 8.6) -# - lremove with multiple indices -# - nested lpop +test listrep-5.1.1 { + Verify that operation on a shared Tcl_Obj with a single-ref, spanless + list representation only modifies the target object - lset version +} -constraints testlistrep -body { + set l [freeSpaceNone] + set l2 $l + set same [sameStore $l $l2] + lset l $end+1 8 + list $same $l $l2 [sameStore $l $l2] +} -result [list 1 [irange 0 8] [irange 0 7] 0] + +test listrep-5.1.2 { + Verify that operation on a shared Tcl_Obj with a single-ref, spanless + list representation only modifies the target object - lpop version +} -constraints testlistrep -body { + set l [freeSpaceNone] + set l2 $l + set same [sameStore $l $l2] + lpop l + list $same $l $l2 [sameStore $l $l2] [hasSpan $l] +} -result [list 1 [irange 0 6] [irange 0 7] 0 0] + +test listrep-5.2 { + Verify that operation on a shared Tcl_Obj with a single-ref, spanned + list representation only modifies the target object - lappend version +} -constraints testlistrep -body { + set l [freeSpaceBoth 1000 10 10] + set l2 $l + set same [sameStore $l $l2] + lappend l 1000 + list $same $l $l2 [sameStore $l $l2] [hasSpan $l] [hasSpan $l2] +} -result [list 1 [irange 0 1000] [irange 0 999] 0 1 1] + +test listrep-5.2.1 { + Verify that operation on a shared Tcl_Obj with a single-ref, spanned + list representation only modifies the target object - lset version +} -constraints testlistrep -body { + set l [freeSpaceBoth 1000 10 10] + set l2 $l + set same [sameStore $l $l2] + lset l $end+1 1000 + list $same $l $l2 [sameStore $l $l2] [hasSpan $l] [hasSpan $l2] +} -result [list 1 [irange 0 1000] [irange 0 999] 0 1 1] + +test listrep-5.2.2 { + Verify that operation on a shared Tcl_Obj with a single-ref, spanned + list representation only modifies the target object - lpop version +} -constraints testlistrep -body { + set l [freeSpaceNone 1000] + set l2 $l + set same [sameStore $l $l2] + lpop l + list $same $l $l2 [sameStore $l $l2] [hasSpan $l] [hasSpan $l2] +} -result [list 1 [irange 0 998] [irange 0 999] 1 1 0] ::tcltest::cleanupTests return -- cgit v0.12 From 2da979cd8e0bfb96bc57578f2ff2413efd393e5c Mon Sep 17 00:00:00 2001 From: sebres Date: Fri, 29 Jul 2022 10:55:37 +0000 Subject: amend for [4eb3a155ac] SF-fix: 8.7 specific implementation and warnings silencing --- generic/tclProc.c | 10 +++++----- generic/tclTest.c | 6 +++--- 2 files changed, 8 insertions(+), 8 deletions(-) diff --git a/generic/tclProc.c b/generic/tclProc.c index 311ea4e..e6b1372 100644 --- a/generic/tclProc.c +++ b/generic/tclProc.c @@ -2162,11 +2162,11 @@ TclProcCleanupProc( if (bodyPtr != NULL) { /* procPtr is stored in body's ByteCode, so ensure to reset it. */ - if (bodyPtr->typePtr == &tclByteCodeType) { - ByteCode *codePtr = bodyPtr->internalRep.twoPtrValue.ptr1; - if (codePtr->procPtr == procPtr) { - codePtr->procPtr = NULL; - } + ByteCode *codePtr; + + ByteCodeGetInternalRep(bodyPtr, &tclByteCodeType, codePtr); + if (codePtr != NULL && codePtr->procPtr == procPtr) { + codePtr->procPtr = NULL; } Tcl_DecrRefCount(bodyPtr); } diff --git a/generic/tclTest.c b/generic/tclTest.c index 77540e2..ed5f34b 100644 --- a/generic/tclTest.c +++ b/generic/tclTest.c @@ -8145,10 +8145,10 @@ TestInterpResolverCmd( *------------------------------------------------------------------------ */ int TestApplyLambdaObjCmd ( - ClientData notUsed, + TCL_UNUSED(void*), Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) /* Argument objects. */ + TCL_UNUSED(int), /* objc. */ + TCL_UNUSED(Tcl_Obj *const *)) /* objv. */ { Tcl_Obj *lambdaObjs[2]; Tcl_Obj *evalObjs[2]; -- cgit v0.12 From 12afabecd7fe8795a8327e18308db7e2f7a16dd7 Mon Sep 17 00:00:00 2001 From: apnadkarni Date: Fri, 29 Jul 2022 16:41:47 +0000 Subject: Garbage collect unreferenced elements in lset implementation. Add tests for garbage collection for commands that modify lists. --- generic/tclListObj.c | 9 ++- tests/listRep.test | 180 +++++++++++++++++++++++++++++++++++++++++++++++---- 2 files changed, 177 insertions(+), 12 deletions(-) diff --git a/generic/tclListObj.c b/generic/tclListObj.c index 43307ad..5100159 100644 --- a/generic/tclListObj.c +++ b/generic/tclListObj.c @@ -1062,7 +1062,7 @@ static void ListRepUnsharedFreeUnreferenced(const ListRep *repPtr) count = spanPtr->spanStart - storePtr->firstUsed; LIST_COUNT_ASSERT(count); if (count > 0) { - /* T:listrep-1.5.1 */ + /* T:listrep-1.5.1,6.{1:8} */ ObjArrayDecrRefs(storePtr->slots, storePtr->firstUsed, count); storePtr->firstUsed = spanPtr->spanStart; LIST_ASSERT(storePtr->numUsed >= count); @@ -1074,6 +1074,7 @@ static void ListRepUnsharedFreeUnreferenced(const ListRep *repPtr) - (spanPtr->spanStart + spanPtr->spanLength); LIST_COUNT_ASSERT(count); if (count > 0) { + /* T:listrep-6.{1:8} */ ObjArrayDecrRefs( storePtr->slots, spanPtr->spanStart + spanPtr->spanLength, count); LIST_ASSERT(storePtr->numUsed >= count); @@ -3102,6 +3103,12 @@ TclListObjSetElement( return TCL_ERROR; } + /* + * Note - garbage collect this only AFTER checking indices above. + * Do not want to modify listrep and then not store it back in listObj. + */ + ListRepFreeUnreferenced(&listRep); + /* Replace a shared internal rep with an unshared copy */ if (listRep.storePtr->refCount > 1) { ListRep newInternalRep; diff --git a/tests/listRep.test b/tests/listRep.test index 7d0dda2..7883a21 100644 --- a/tests/listRep.test +++ b/tests/listRep.test @@ -83,8 +83,11 @@ proc spaceEqual {l} { set diff [expr {$leadSpace - $tailSpace}] return [expr {$diff >= -1 && $diff <= 1}] } +proc storeAddress {l} { + return [describe $l store memoryAddress] +} proc sameStore {l1 l2} { - expr {[describe $l1 store memoryAddress] == [describe $l2 store memoryAddress]} + expr {[storeAddress $l1] == [storeAddress $l2]} } proc hasSpan {l args} { # Returns 1 if list has a span. If args are specified, they are checked with @@ -153,12 +156,12 @@ proc freeSpaceTail {{len 8} {tail 3}} {return [testlistrep new $len 0 $tail]} proc freeSpaceBoth {{len 8} {lead 3} {tail 3}} { return [testlistrep new $len $lead $tail] } -proc listWithZombies {{len 1000} {leadZombies 100} {tailZombies 100}} { - # Returns an unshared listrep with zombies in front and back +proc zombieSample {{len 1000} {leadzombies 100} {tailzombies 100}} { + # returns an unshared listrep with zombies in front and back - # DON'T COMBINE NEXT TWO STATEMENTS ELSE ZOMBIES ARE FREED - set l [freeSpaceNone [expr {$len+$leadZombies+$tailZombies}]] - return [lrange $l $leadZombies [expr {$leadZombies+$len-1}]] + # don't combine freespacenone and lrange else zombies are freed + set l [freeSpaceNone [expr {$len+$leadzombies+$tailzombies}]] + return [lrange $l $leadzombies [expr {$leadzombies+$len-1}]] } # Just ensure above stubs return what's expected @@ -167,9 +170,9 @@ if {[testConstraint testlistrep]} { assertListrep [freeSpaceLead] 8 11 3 0 1 assertListrep [freeSpaceTail] 8 11 0 3 1 assertListrep [freeSpaceBoth] 8 14 3 3 1 - assertListrep [listWithZombies] 1000 1200 0 0 1 - if {![hasSpan [listWithZombies]] || [dict get [testlistrep describe [listWithZombies]] span spanStart] == 0} { - error "listWithZombies span missing or span start is at 0." + assertListrep [zombieSample] 1000 1200 0 0 1 + if {![hasSpan [zombieSample]] || [dict get [testlistrep describe [zombieSample]] span spanStart] == 0} { + error "zombieSample span missing or span start is at 0." } } @@ -188,6 +191,7 @@ set end end # 3.* - unshared internal rep, spanned # 4.* - shared internal rep, spanned # 5.* - shared Tcl_Obj +# 6.* - lists with zombie Tcl_Obj's # # listrep-1.* tests all operate on unshared listreps with no free space @@ -2305,8 +2309,8 @@ test listrep-4.18 { list $spanl $l [sameStore $spanl $l] [spaceEqual $l] [hasSpan $l] [repStoreRefCount $spanl] [repStoreRefCount $l] } -result [list [irange 2 997] [concat [irange 2 994] {1000 1001 1002 997}] 0 1 1 2 1] -# -# Tests when tcl-obj is shared but listrep is not. This is to ensure that +# 5.* - tests on shared Tcl_Obj +# Tests when Tcl_Obj is shared but listrep is not. This is to ensure that # checks for shared values check the Tcl_Obj reference counts in addition to # the list internal representation reference counts. Probably some or all # cases are already covered elsewhere but easier to just test than look. @@ -2376,5 +2380,159 @@ test listrep-5.2.2 { list $same $l $l2 [sameStore $l $l2] [hasSpan $l] [hasSpan $l2] } -result [list 1 [irange 0 998] [irange 0 999] 1 1 0] +# +# 6.* - tests when lists contain zombies. +# The list implementation does lazy freeing in some cases so the list store +# contain Tcl_Obj's that are not actually referenced by any list (zombies). +# These are to be freed next time the list store is modified by a list +# operation as long as it is no longer shared. +test listrep-6.1 { + Verify that zombies are freed up - linsert at front +} -constraints testlistrep -body { + set l [zombieSample 200 10 10] + set addr [storeAddress $l] + # set l {} is for reference counts to drop to 1 + set l [linsert $l[set l {}] $zero -1] + list $l [expr {$addr == [storeAddress $l]}] [leadSpace $l] [tailSpace $l] [repStoreRefCount $l] +} -result [list [list -1 {*}[irange 10 209]] 1 9 10 1] + +test listrep-6.1.1 { + Verify that zombies are freed up - linsert in middle +} -constraints testlistrep -body { + set l [zombieSample 200 10 10] + set addr [storeAddress $l] + # set l {} is for reference counts to drop to 1 + set l [linsert $l[set l {}] $one -1] + list $l [expr {$addr == [storeAddress $l]}] [leadSpace $l] [tailSpace $l] [repStoreRefCount $l] +} -result [list [list 10 -1 {*}[irange 11 209]] 1 9 10 1] + +test listrep-6.1.2 { + Verify that zombies are freed up - linsert at end +} -constraints testlistrep -body { + set l [zombieSample 200 10 10] + set addr [storeAddress $l] + # set l {} is for reference counts to drop to 1 + set l [linsert $l[set l {}] $end 210] + list $l [expr {$addr == [storeAddress $l]}] [leadSpace $l] [tailSpace $l] [repStoreRefCount $l] +} -result [list [irange 10 210] 1 10 9 1] + +test listrep-6.2 { + Verify that zombies are freed up - lrange version (whole) +} -constraints testlistrep -body { + set l [zombieSample 200 10 10] + set addr [storeAddress $l] + # set l {} is for reference counts to drop to 1 + set l [lrange $l[set l {}] $zero $end] + list $l [expr {$addr == [storeAddress $l]}] [leadSpace $l] [tailSpace $l] [repStoreRefCount $l] +} -result [list [irange 10 209] 1 10 10 1] + +test listrep-6.2.1 { + Verify that zombies are freed up - lrange version (subrange) +} -constraints testlistrep -body { + set l [zombieSample 200 10 10] + set addr [storeAddress $l] + # set l {} is for reference counts to drop to 1 + set l [lrange $l[set l {}] $one $end-1] + list $l [expr {$addr == [storeAddress $l]}] [leadSpace $l] [tailSpace $l] [repStoreRefCount $l] +} -result [list [irange 11 208] 1 11 11 1] + +test listrep-6.3 { + Verify that zombies are freed up - lassign version +} -constraints testlistrep -body { + set l [zombieSample 200 10 10] + set addr [storeAddress $l] + # set l {} is for reference counts to drop to 1 + set l [lassign $l[set l {}] e] + list $e $l [expr {$addr == [storeAddress $l]}] [leadSpace $l] [tailSpace $l] [repStoreRefCount $l] +} -result [list 10 [irange 11 209] 1 11 10 1] + +test listrep-6.4 { + Verify that zombies are freed up - lremove version (front) +} -constraints testlistrep -body { + set l [zombieSample 200 10 10] + set addr [storeAddress $l] + # set l {} is for reference counts to drop to 1 + set l [lremove $l[set l {}] $zero] + list $l [expr {$addr == [storeAddress $l]}] [leadSpace $l] [tailSpace $l] [repStoreRefCount $l] +} -result [list [irange 11 209] 1 11 10 1] + +test listrep-6.4.1 { + Verify that zombies are freed up - lremove version (back) +} -constraints testlistrep -body { + set l [zombieSample 200 10 10] + set addr [storeAddress $l] + # set l {} is for reference counts to drop to 1 + set l [lremove $l[set l {}] $end] + list $l [expr {$addr == [storeAddress $l]}] [leadSpace $l] [tailSpace $l] [repStoreRefCount $l] +} -result [list [irange 10 208] 1 10 11 1] + +test listrep-6.5 { + Verify that zombies are freed up - lreplace at front +} -constraints testlistrep -body { + set l [zombieSample 200 10 10] + set addr [storeAddress $l] + # set l {} is for reference counts to drop to 1 + set l [lreplace $l[set l {}] $zero $one -3 -2 -1] + list $l [expr {$addr == [storeAddress $l]}] [leadSpace $l] [tailSpace $l] [repStoreRefCount $l] +} -result [list [list -3 -2 -1 {*}[irange 12 209]] 1 9 10 1] + +test listrep-6.5.1 { + Verify that zombies are freed up - lreplace at back +} -constraints testlistrep -body { + set l [zombieSample 200 10 10] + set addr [storeAddress $l] + # set l {} is for reference counts to drop to 1 + set l [lreplace $l[set l {}] $end-1 $end -1 -2 -3] + list $l [expr {$addr == [storeAddress $l]}] [leadSpace $l] [tailSpace $l] [repStoreRefCount $l] +} -result [list [list {*}[irange 10 207] -1 -2 -3] 1 10 9 1] + +test listrep-6.6 { + Verify that zombies are freed up - lappend +} -constraints testlistrep -body { + set l [zombieSample 200 10 10] + set addr [storeAddress $l] + lappend l 210 + list $l [expr {$addr == [storeAddress $l]}] [leadSpace $l] [tailSpace $l] [repStoreRefCount $l] +} -result [list [irange 10 210] 1 10 9 1] + +test listrep-6.7 { + Verify that zombies are freed up - lpop version (front) +} -constraints testlistrep -body { + set l [zombieSample 200 10 10] + set addr [storeAddress $l] + set e [lpop l $zero] + list $e $l [expr {$addr == [storeAddress $l]}] [leadSpace $l] [tailSpace $l] [repStoreRefCount $l] +} -result [list 10 [irange 11 209] 1 11 10 1] + +test listrep-6.7.1 { + Verify that zombies are freed up - lpop version (back) +} -constraints testlistrep -body { + set l [zombieSample 200 10 10] + set addr [storeAddress $l] + set e [lpop l] + list $e $l [expr {$addr == [storeAddress $l]}] [leadSpace $l] [tailSpace $l] [repStoreRefCount $l] +} -result [list 209 [irange 10 208] 1 10 11 1] + +test listrep-6.8 { + Verify that zombies are freed up - lset version +} -constraints testlistrep -body { + set l [zombieSample 200 10 10] + set addr [storeAddress $l] + lset l $zero -1 + list $l [expr {$addr == [storeAddress $l]}] [leadSpace $l] [tailSpace $l] [repStoreRefCount $l] +} -result [list [list -1 {*}[irange 11 209]] 1 10 10 1] + +test listrep-6.8.1 { + Verify that zombies are freed up - lset version (back) +} -constraints testlistrep -body { + set l [zombieSample 200 10 10] + set addr [storeAddress $l] + lset l $end+1 210 + list $l [expr {$addr == [storeAddress $l]}] [leadSpace $l] [tailSpace $l] [repStoreRefCount $l] +} -result [list [irange 10 210] 1 10 9 1] + + +# All done ::tcltest::cleanupTests + return -- cgit v0.12 From 7c269c207f4a9c13dd64edea5fa799a5d952742c Mon Sep 17 00:00:00 2001 From: max Date: Thu, 4 Aug 2022 15:09:59 +0000 Subject: Fix a case of lf not being flushed in certain cases when the crlf sequence gets split across two buffers on channels in crlf mode with line buffering [https://core.tcl-lang.org/tcllib/tktview?name=c9d8a52fe] --- generic/tclIO.c | 4 ++-- tests/io.test | 9 +++++++++ 2 files changed, 11 insertions(+), 2 deletions(-) diff --git a/generic/tclIO.c b/generic/tclIO.c index 376ab36..6b7ccdf 100644 --- a/generic/tclIO.c +++ b/generic/tclIO.c @@ -4435,8 +4435,8 @@ Write( } ReleaseChannelBuffer(bufPtr); } - if ((flushed < total) && (GotFlag(statePtr, CHANNEL_UNBUFFERED) || - (needNlFlush && GotFlag(statePtr, CHANNEL_LINEBUFFERED)))) { + if (((flushed < total) && GotFlag(statePtr, CHANNEL_UNBUFFERED)) || + (needNlFlush && GotFlag(statePtr, CHANNEL_LINEBUFFERED))) { if (FlushChannel(NULL, chanPtr, 0) != 0) { return -1; } diff --git a/tests/io.test b/tests/io.test index 3b374c1..0a34019 100644 --- a/tests/io.test +++ b/tests/io.test @@ -330,6 +330,15 @@ test io-3.8 {WriteChars: reset sawLF after each buffer} { close $f lappend x [contents $path(test1)] } [list "abcdefg\nhijklmno" "abcdefg\nhijklmnopqrstuvwxyz"] +test io-3.9 {Write: flush line-buffered channels when crlf is split over two buffers} -body { + # https://core.tcl-lang.org/tcllib/tktedit?name=c9d8a52fe + set f [open $path(test1) w] + fconfigure $f -buffering line -translation crlf -buffersize 8 + puts $f "1234567" + string map {"\r" "" "\n" ""} [contents $path(test1)] +} -cleanup { + close $f +} -result "1234567" test io-4.1 {TranslateOutputEOL: lf} { # search for \n -- cgit v0.12 From c35f73ae26971655393e97ecf7ef928604810afa Mon Sep 17 00:00:00 2001 From: apnadkarni Date: Sat, 6 Aug 2022 16:00:14 +0000 Subject: Remove knownBug constraint now that apply has been fixed --- tests/apply.test | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/tests/apply.test b/tests/apply.test index 47fcb67..24b27cc 100644 --- a/tests/apply.test +++ b/tests/apply.test @@ -261,7 +261,7 @@ test apply-9.1 {leaking internal rep} -setup { lindex $lines 3 3 } set lam [list {} {set a 1}] -} -constraints {memory knownBug} -body { +} -constraints {memory} -body { set end [getbytes] for {set i 0} {$i < 5} {incr i} { ::apply [lrange $lam 0 end] -- cgit v0.12 From da40e7deb9d3e26315a495419b6ed50f0099bdc7 Mon Sep 17 00:00:00 2001 From: sebres Date: Sat, 20 Aug 2022 10:13:04 +0000 Subject: closes [baa51423c28a3baf]: needEvent must be initialized in cycle (for each watching channel) --- win/tclWinConsole.c | 30 +++++++++++++++++------------- 1 file changed, 17 insertions(+), 13 deletions(-) diff --git a/win/tclWinConsole.c b/win/tclWinConsole.c index 23652de..30a09fd 100644 --- a/win/tclWinConsole.c +++ b/win/tclWinConsole.c @@ -861,21 +861,25 @@ ConsoleCheckProc( handleInfoPtr = FindConsoleInfo(chanInfoPtr); /* Pointer is safe to access as we are holding gConsoleLock */ - if (handleInfoPtr != NULL) { - AcquireSRWLockShared(&handleInfoPtr->lock); - /* Rememebr channel is read or write, never both */ - if (chanInfoPtr->watchMask & TCL_READABLE) { - if (RingBufferLength(&handleInfoPtr->buffer) > 0 - || handleInfoPtr->lastError != ERROR_SUCCESS) { - needEvent = 1; /* Input data available or error/EOF */ - } - } else if (chanInfoPtr->watchMask & TCL_WRITABLE) { - if (RingBufferHasFreeSpace(&handleInfoPtr->buffer)) { - needEvent = 1; /* Output space available */ - } + if (handleInfoPtr == NULL) { + continue; + } + + needEvent = 0; + AcquireSRWLockShared(&handleInfoPtr->lock); + /* Rememebr channel is read or write, never both */ + if (chanInfoPtr->watchMask & TCL_READABLE) { + if (RingBufferLength(&handleInfoPtr->buffer) > 0 + || handleInfoPtr->lastError != ERROR_SUCCESS + ) { + needEvent = 1; /* Input data available or error/EOF */ + } + } else if (chanInfoPtr->watchMask & TCL_WRITABLE) { + if (RingBufferHasFreeSpace(&handleInfoPtr->buffer)) { + needEvent = 1; /* Output space available */ } - ReleaseSRWLockShared(&handleInfoPtr->lock); } + ReleaseSRWLockShared(&handleInfoPtr->lock); if (needEvent) { ConsoleEvent *evPtr = (ConsoleEvent *)ckalloc(sizeof(ConsoleEvent)); -- cgit v0.12 From b00b14a7fd336ad3a98519a59657d143e4ef1ae0 Mon Sep 17 00:00:00 2001 From: apnadkarni Date: Sat, 20 Aug 2022 12:16:10 +0000 Subject: Really closes [baa51423c28a3baf] --- win/tclWinConsole.c | 17 ++++++++++++----- 1 file changed, 12 insertions(+), 5 deletions(-) diff --git a/win/tclWinConsole.c b/win/tclWinConsole.c index 30a09fd..0e38c5b 100644 --- a/win/tclWinConsole.c +++ b/win/tclWinConsole.c @@ -862,19 +862,26 @@ ConsoleCheckProc( /* Pointer is safe to access as we are holding gConsoleLock */ if (handleInfoPtr == NULL) { + /* Stale event */ continue; } - + needEvent = 0; AcquireSRWLockShared(&handleInfoPtr->lock); - /* Rememebr channel is read or write, never both */ + /* Rememeber channel is read or write, never both */ if (chanInfoPtr->watchMask & TCL_READABLE) { if (RingBufferLength(&handleInfoPtr->buffer) > 0 - || handleInfoPtr->lastError != ERROR_SUCCESS - ) { + || handleInfoPtr->lastError != ERROR_SUCCESS) { needEvent = 1; /* Input data available or error/EOF */ } - } else if (chanInfoPtr->watchMask & TCL_WRITABLE) { + /* + * TCL_READABLE watch means someone is looking out for data being + * available, let reader thread know. + */ + handleInfoPtr->flags |= CONSOLE_DATA_AWAITED; + WakeConditionVariable(&handleInfoPtr->consoleThreadCV); + } + else if (chanInfoPtr->watchMask & TCL_WRITABLE) { if (RingBufferHasFreeSpace(&handleInfoPtr->buffer)) { needEvent = 1; /* Output space available */ } -- cgit v0.12 From 839d38fbba493c388c1d261f9b47b8b38e2b7cb4 Mon Sep 17 00:00:00 2001 From: apnadkarni Date: Sat, 20 Aug 2022 16:56:10 +0000 Subject: Added test for bug [baa51423c2] --- tests/winConsole.test | 46 +++++++++++++++++++++++++++++++++++++++++----- win/tclWinConsole.c | 3 ++- 2 files changed, 43 insertions(+), 6 deletions(-) diff --git a/tests/winConsole.test b/tests/winConsole.test index 0daf54c..821a143 100644 --- a/tests/winConsole.test +++ b/tests/winConsole.test @@ -52,13 +52,21 @@ test console-input-1.0 {Console blocking gets} -constraints {win interactive} -b test console-input-1.1 {Console file channel: non-blocking gets} -constraints { win interactive +} -setup { + unset -nocomplain result + unset -nocomplain result2 } -body { set oldmode [fconfigure stdin] prompt "Type \"abc\" and hit Enter: " fileevent stdin readable { if {[gets stdin line] >= 0} { - set result $line + lappend result2 $line + if {[llength $result2] > 1} { + set result $result2 + } else { + prompt "Type \"def\" and hit Enter: " + } } elseif {[eof stdin]} { set result "gets failed" } @@ -66,7 +74,6 @@ test console-input-1.1 {Console file channel: non-blocking gets} -constraints { fconfigure stdin -blocking 0 -buffering line - set result {} vwait result #cleanup the fileevent @@ -74,7 +81,35 @@ test console-input-1.1 {Console file channel: non-blocking gets} -constraints { fconfigure stdin {*}$oldmode set result -} -result abc +} -result {abc def} + +test console-input-1.1.1 {Bug baa51423c28a: Console file channel: fileevent with blocking gets} -constraints { + win interactive +} -setup { + unset -nocomplain result + unset -nocomplain result2 +} -body { + prompt "Type \"abc\" and hit Enter: " + fileevent stdin readable { + if {[gets stdin line] >= 0} { + lappend result2 $line + if {[llength $result2] > 1} { + set result $result2 + } else { + prompt "Type \"def\" and hit Enter: " + } + } elseif {[eof stdin]} { + set result "gets failed" + } + } + + vwait result + + #cleanup the fileevent + fileevent stdin readable {} + set result + +} -result {abc def} test console-input-2.0 {Console blocking read} -constraints {win interactive} -setup { set oldmode [fconfigure stdin] @@ -94,6 +129,7 @@ test console-input-2.1 {Console file channel: non-blocking read} -constraints { set oldmode [fconfigure stdin] } -cleanup { fconfigure stdin {*}$oldmode + puts ""; # Because CRLF also would not have been echoed } -body { set input "" fconfigure stdin -blocking 0 -buffering line -inputmode raw @@ -262,10 +298,10 @@ test console-fconfigure-set-1.1 { fconfigure stdin -inputmode normal lappend result [yesno "\nWere the characters echoed?"] - prompt "\nType the keys \"c\", Ctrl-H, \"d\" and hit Enter. You should see characters echoed: " + prompt "Type the keys \"c\", Ctrl-H, \"d\" and hit Enter. You should see characters echoed: " lappend result [gets stdin] lappend result [fconfigure stdin -inputmode] - lappend result [yesno "\nWere the characters echoed (c replaced by d)?"] + lappend result [yesno "Were the characters echoed (c replaced by d)?"] set result } -result [list a\x08b raw 0 d normal 1] diff --git a/win/tclWinConsole.c b/win/tclWinConsole.c index 0e38c5b..4b2d1d3 100644 --- a/win/tclWinConsole.c +++ b/win/tclWinConsole.c @@ -876,7 +876,8 @@ ConsoleCheckProc( } /* * TCL_READABLE watch means someone is looking out for data being - * available, let reader thread know. + * available, let reader thread know. Note channel need not be + * ASYNC! (Bug [baa51423c2]) */ handleInfoPtr->flags |= CONSOLE_DATA_AWAITED; WakeConditionVariable(&handleInfoPtr->consoleThreadCV); -- cgit v0.12 From 02c762f9ec9e806dbd2b392e0f19a035b7da31f2 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Sun, 21 Aug 2022 20:28:57 +0000 Subject: ClientData -> 'void *" in TclOO headers --- generic/tclOO.h | 10 ++++---- generic/tclOOInt.h | 68 +++++++++++++++++++++++++++--------------------------- 2 files changed, 39 insertions(+), 39 deletions(-) diff --git a/generic/tclOO.h b/generic/tclOO.h index a5c67b3..20dc281 100644 --- a/generic/tclOO.h +++ b/generic/tclOO.h @@ -60,12 +60,12 @@ typedef struct Tcl_ObjectContext_ *Tcl_ObjectContext; * and to allow the attachment of arbitrary data to objects and classes. */ -typedef int (Tcl_MethodCallProc)(ClientData clientData, Tcl_Interp *interp, +typedef int (Tcl_MethodCallProc)(void *clientData, Tcl_Interp *interp, Tcl_ObjectContext objectContext, int objc, Tcl_Obj *const *objv); -typedef void (Tcl_MethodDeleteProc)(ClientData clientData); -typedef int (Tcl_CloneProc)(Tcl_Interp *interp, ClientData oldClientData, - ClientData *newClientData); -typedef void (Tcl_ObjectMetadataDeleteProc)(ClientData clientData); +typedef void (Tcl_MethodDeleteProc)(void *clientData); +typedef int (Tcl_CloneProc)(Tcl_Interp *interp, void *oldClientData, + void **newClientData); +typedef void (Tcl_ObjectMetadataDeleteProc)(void *clientData); typedef int (Tcl_ObjectMapMethodNameProc)(Tcl_Interp *interp, Tcl_Object object, Tcl_Class *startClsPtr, Tcl_Obj *methodNameObj); diff --git a/generic/tclOOInt.h b/generic/tclOOInt.h index f061bc6..2931044 100644 --- a/generic/tclOOInt.h +++ b/generic/tclOOInt.h @@ -47,7 +47,7 @@ typedef struct Method { * special flag record which is just used for * the setting of the flags field. */ int refCount; - ClientData clientData; /* Type-specific data. */ + void *clientData; /* Type-specific data. */ Tcl_Obj *namePtr; /* Name of the method. */ struct Object *declaringObjectPtr; /* The object that declares this method, or @@ -65,12 +65,12 @@ typedef struct Method { * tuned in their behaviour. */ -typedef int (TclOO_PreCallProc)(ClientData clientData, Tcl_Interp *interp, +typedef int (TclOO_PreCallProc)(void *clientData, Tcl_Interp *interp, Tcl_ObjectContext context, Tcl_CallFrame *framePtr, int *isFinished); -typedef int (TclOO_PostCallProc)(ClientData clientData, Tcl_Interp *interp, +typedef int (TclOO_PostCallProc)(void *clientData, Tcl_Interp *interp, Tcl_ObjectContext context, Tcl_Namespace *namespacePtr, int result); -typedef void (TclOO_PmCDDeleteProc)(ClientData clientData); -typedef ClientData (TclOO_PmCDCloneProc)(ClientData clientData); +typedef void (TclOO_PmCDDeleteProc)(void *clientData); +typedef void *(TclOO_PmCDCloneProc)(void *clientData); /* * Procedure-like methods have the following extra information. @@ -84,7 +84,7 @@ typedef struct ProcedureMethod { * body bytecodes. */ int flags; /* Flags to control features. */ int refCount; - ClientData clientData; + void *clientData; TclOO_PmCDDeleteProc *deleteClientdataProc; TclOO_PmCDCloneProc *cloneClientdataProc; ProcErrorProc *errProc; /* Replacement error handler. */ @@ -368,7 +368,7 @@ typedef struct CallContext { #define PUBLIC_METHOD 0x01 /* This is a public (exported) method. */ #define PRIVATE_METHOD 0x02 /* This is a private (class's direct instances - * only) method. */ + * only) method. Supports itcl. */ #define OO_UNKNOWN_METHOD 0x04 /* This is an unknown method. */ #define CONSTRUCTOR 0x08 /* This is a constructor. */ #define DESTRUCTOR 0x10 /* This is a destructor. */ @@ -390,55 +390,55 @@ typedef struct { */ MODULE_SCOPE int TclOOInit(Tcl_Interp *interp); -MODULE_SCOPE int TclOODefineObjCmd(ClientData clientData, +MODULE_SCOPE int TclOODefineObjCmd(void *clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv); -MODULE_SCOPE int TclOOObjDefObjCmd(ClientData clientData, +MODULE_SCOPE int TclOOObjDefObjCmd(void *clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv); -MODULE_SCOPE int TclOODefineConstructorObjCmd(ClientData clientData, +MODULE_SCOPE int TclOODefineConstructorObjCmd(void *clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv); -MODULE_SCOPE int TclOODefineDeleteMethodObjCmd(ClientData clientData, +MODULE_SCOPE int TclOODefineDeleteMethodObjCmd(void *clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv); -MODULE_SCOPE int TclOODefineDestructorObjCmd(ClientData clientData, +MODULE_SCOPE int TclOODefineDestructorObjCmd(void *clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv); -MODULE_SCOPE int TclOODefineExportObjCmd(ClientData clientData, +MODULE_SCOPE int TclOODefineExportObjCmd(void *clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv); -MODULE_SCOPE int TclOODefineForwardObjCmd(ClientData clientData, +MODULE_SCOPE int TclOODefineForwardObjCmd(void *clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv); -MODULE_SCOPE int TclOODefineMethodObjCmd(ClientData clientData, +MODULE_SCOPE int TclOODefineMethodObjCmd(void *clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv); -MODULE_SCOPE int TclOODefineRenameMethodObjCmd(ClientData clientData, +MODULE_SCOPE int TclOODefineRenameMethodObjCmd(void *clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv); -MODULE_SCOPE int TclOODefineUnexportObjCmd(ClientData clientData, +MODULE_SCOPE int TclOODefineUnexportObjCmd(void *clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv); -MODULE_SCOPE int TclOODefineClassObjCmd(ClientData clientData, +MODULE_SCOPE int TclOODefineClassObjCmd(void *clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv); -MODULE_SCOPE int TclOODefineSelfObjCmd(ClientData clientData, +MODULE_SCOPE int TclOODefineSelfObjCmd(void *clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv); -MODULE_SCOPE int TclOOUnknownDefinition(ClientData clientData, +MODULE_SCOPE int TclOOUnknownDefinition(void *clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv); -MODULE_SCOPE int TclOOCopyObjectCmd(ClientData clientData, +MODULE_SCOPE int TclOOCopyObjectCmd(void *clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv); -MODULE_SCOPE int TclOONextObjCmd(ClientData clientData, +MODULE_SCOPE int TclOONextObjCmd(void *clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv); -MODULE_SCOPE int TclOONextToObjCmd(ClientData clientData, +MODULE_SCOPE int TclOONextToObjCmd(void *clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv); -MODULE_SCOPE int TclOOSelfObjCmd(ClientData clientData, +MODULE_SCOPE int TclOOSelfObjCmd(void *clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv); @@ -446,31 +446,31 @@ MODULE_SCOPE int TclOOSelfObjCmd(ClientData clientData, * Method implementations (in tclOOBasic.c). */ -MODULE_SCOPE int TclOO_Class_Constructor(ClientData clientData, +MODULE_SCOPE int TclOO_Class_Constructor(void *clientData, Tcl_Interp *interp, Tcl_ObjectContext context, int objc, Tcl_Obj *const *objv); -MODULE_SCOPE int TclOO_Class_Create(ClientData clientData, +MODULE_SCOPE int TclOO_Class_Create(void *clientData, Tcl_Interp *interp, Tcl_ObjectContext context, int objc, Tcl_Obj *const *objv); -MODULE_SCOPE int TclOO_Class_CreateNs(ClientData clientData, +MODULE_SCOPE int TclOO_Class_CreateNs(void *clientData, Tcl_Interp *interp, Tcl_ObjectContext context, int objc, Tcl_Obj *const *objv); -MODULE_SCOPE int TclOO_Class_New(ClientData clientData, +MODULE_SCOPE int TclOO_Class_New(void *clientData, Tcl_Interp *interp, Tcl_ObjectContext context, int objc, Tcl_Obj *const *objv); -MODULE_SCOPE int TclOO_Object_Destroy(ClientData clientData, +MODULE_SCOPE int TclOO_Object_Destroy(void *clientData, Tcl_Interp *interp, Tcl_ObjectContext context, int objc, Tcl_Obj *const *objv); -MODULE_SCOPE int TclOO_Object_Eval(ClientData clientData, +MODULE_SCOPE int TclOO_Object_Eval(void *clientData, Tcl_Interp *interp, Tcl_ObjectContext context, int objc, Tcl_Obj *const *objv); -MODULE_SCOPE int TclOO_Object_LinkVar(ClientData clientData, +MODULE_SCOPE int TclOO_Object_LinkVar(void *clientData, Tcl_Interp *interp, Tcl_ObjectContext context, int objc, Tcl_Obj *const *objv); -MODULE_SCOPE int TclOO_Object_Unknown(ClientData clientData, +MODULE_SCOPE int TclOO_Object_Unknown(void *clientData, Tcl_Interp *interp, Tcl_ObjectContext context, int objc, Tcl_Obj *const *objv); -MODULE_SCOPE int TclOO_Object_VarName(ClientData clientData, +MODULE_SCOPE int TclOO_Object_VarName(void *clientData, Tcl_Interp *interp, Tcl_ObjectContext context, int objc, Tcl_Obj *const *objv); @@ -517,7 +517,7 @@ MODULE_SCOPE int TclOOGetSortedMethodList(Object *oPtr, int flags, const char ***stringsPtr); MODULE_SCOPE int TclOOInit(Tcl_Interp *interp); MODULE_SCOPE void TclOOInitInfo(Tcl_Interp *interp); -MODULE_SCOPE int TclOOInvokeContext(ClientData clientData, +MODULE_SCOPE int TclOOInvokeContext(void *clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); MODULE_SCOPE int TclNRObjectContextInvokeNext(Tcl_Interp *interp, -- cgit v0.12 From f8ed9f54314d3f2dc8fe1b157cc7358c9ed7b371 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Sun, 21 Aug 2022 20:53:08 +0000 Subject: More type-casts in tclOOMethod.c (backported from 8.7) --- generic/tclOOMethod.c | 131 ++++++++++++++++++++++++++------------------------ 1 file changed, 67 insertions(+), 64 deletions(-) diff --git a/generic/tclOOMethod.c b/generic/tclOOMethod.c index 717aa09..c65003f 100644 --- a/generic/tclOOMethod.c +++ b/generic/tclOOMethod.c @@ -3,7 +3,7 @@ * * This file contains code to create and manage methods. * - * Copyright (c) 2005-2011 by Donal K. Fellows + * Copyright (c) 2005-2011 Donal K. Fellows * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. @@ -67,7 +67,7 @@ static Tcl_Obj ** InitEnsembleRewrite(Tcl_Interp *interp, int objc, Tcl_Obj *const *objv, int toRewrite, int rewriteLength, Tcl_Obj *const *rewriteObjs, int *lengthPtr); -static int InvokeProcedureMethod(ClientData clientData, +static int InvokeProcedureMethod(void *clientData, Tcl_Interp *interp, Tcl_ObjectContext context, int objc, Tcl_Obj *const *objv); static Tcl_NRPostProc FinalizeForwardCall; @@ -77,22 +77,22 @@ static int PushMethodCallFrame(Tcl_Interp *interp, int objc, Tcl_Obj *const *objv, PMFrameData *fdPtr); static void DeleteProcedureMethodRecord(ProcedureMethod *pmPtr); -static void DeleteProcedureMethod(ClientData clientData); +static void DeleteProcedureMethod(void *clientData); static int CloneProcedureMethod(Tcl_Interp *interp, - ClientData clientData, ClientData *newClientData); + void *clientData, void **newClientData); static void MethodErrorHandler(Tcl_Interp *interp, Tcl_Obj *procNameObj); static void ConstructorErrorHandler(Tcl_Interp *interp, Tcl_Obj *procNameObj); static void DestructorErrorHandler(Tcl_Interp *interp, Tcl_Obj *procNameObj); -static Tcl_Obj * RenderDeclarerName(ClientData clientData); -static int InvokeForwardMethod(ClientData clientData, +static Tcl_Obj * RenderDeclarerName(void *clientData); +static int InvokeForwardMethod(void *clientData, Tcl_Interp *interp, Tcl_ObjectContext context, int objc, Tcl_Obj *const *objv); -static void DeleteForwardMethod(ClientData clientData); +static void DeleteForwardMethod(void *clientData); static int CloneForwardMethod(Tcl_Interp *interp, - ClientData clientData, ClientData *newClientData); + void *clientData, void **newClientData); static int ProcedureMethodVarResolver(Tcl_Interp *interp, const char *varName, Tcl_Namespace *contextNs, int flags, Tcl_Var *varPtr); @@ -146,7 +146,7 @@ Tcl_NewInstanceMethod( /* The type of method this is, which defines * how to invoke, delete and clone the * method. */ - ClientData clientData) /* Some data associated with the particular + void *clientData) /* Some data associated with the particular * method to be created. */ { Object *oPtr = (Object *) object; @@ -155,25 +155,25 @@ Tcl_NewInstanceMethod( int isNew; if (nameObj == NULL) { - mPtr = ckalloc(sizeof(Method)); + mPtr = (Method *)ckalloc(sizeof(Method)); mPtr->namePtr = NULL; mPtr->refCount = 1; goto populate; } if (!oPtr->methodsPtr) { - oPtr->methodsPtr = ckalloc(sizeof(Tcl_HashTable)); + oPtr->methodsPtr = (Tcl_HashTable *)ckalloc(sizeof(Tcl_HashTable)); Tcl_InitObjHashTable(oPtr->methodsPtr); oPtr->flags &= ~USE_CLASS_CACHE; } hPtr = Tcl_CreateHashEntry(oPtr->methodsPtr, (char *) nameObj, &isNew); if (isNew) { - mPtr = ckalloc(sizeof(Method)); + mPtr = (Method *)ckalloc(sizeof(Method)); mPtr->namePtr = nameObj; mPtr->refCount = 1; Tcl_IncrRefCount(nameObj); Tcl_SetHashValue(hPtr, mPtr); } else { - mPtr = Tcl_GetHashValue(hPtr); + mPtr = (Method *)Tcl_GetHashValue(hPtr); if (mPtr->typePtr != NULL && mPtr->typePtr->deleteProc != NULL) { mPtr->typePtr->deleteProc(mPtr->clientData); } @@ -214,7 +214,7 @@ Tcl_NewMethod( /* The type of method this is, which defines * how to invoke, delete and clone the * method. */ - ClientData clientData) /* Some data associated with the particular + void *clientData) /* Some data associated with the particular * method to be created. */ { Class *clsPtr = (Class *) cls; @@ -223,20 +223,20 @@ Tcl_NewMethod( int isNew; if (nameObj == NULL) { - mPtr = ckalloc(sizeof(Method)); + mPtr = (Method *)ckalloc(sizeof(Method)); mPtr->namePtr = NULL; mPtr->refCount = 1; goto populate; } hPtr = Tcl_CreateHashEntry(&clsPtr->classMethods, (char *)nameObj,&isNew); if (isNew) { - mPtr = ckalloc(sizeof(Method)); + mPtr = (Method *)ckalloc(sizeof(Method)); mPtr->refCount = 1; mPtr->namePtr = nameObj; Tcl_IncrRefCount(nameObj); Tcl_SetHashValue(hPtr, mPtr); } else { - mPtr = Tcl_GetHashValue(hPtr); + mPtr = (Method *)Tcl_GetHashValue(hPtr); if (mPtr->typePtr != NULL && mPtr->typePtr->deleteProc != NULL) { mPtr->typePtr->deleteProc(mPtr->clientData); } @@ -342,7 +342,7 @@ TclOONewProcInstanceMethod( if (TclListObjLength(interp, argsObj, &argsLen) != TCL_OK) { return NULL; } - pmPtr = ckalloc(sizeof(ProcedureMethod)); + pmPtr = (ProcedureMethod *)ckalloc(sizeof(ProcedureMethod)); memset(pmPtr, 0, sizeof(ProcedureMethod)); pmPtr->version = TCLOO_PROCEDURE_METHOD_VERSION; pmPtr->flags = flags & USE_DECLARER_NS; @@ -403,7 +403,7 @@ TclOONewProcMethod( procName = (nameObj==NULL ? "" : TclGetString(nameObj)); } - pmPtr = ckalloc(sizeof(ProcedureMethod)); + pmPtr = (ProcedureMethod *)ckalloc(sizeof(ProcedureMethod)); memset(pmPtr, 0, sizeof(ProcedureMethod)); pmPtr->version = TCLOO_PROCEDURE_METHOD_VERSION; pmPtr->flags = flags & USE_DECLARER_NS; @@ -450,7 +450,7 @@ TclOOMakeProcInstanceMethod( * NULL. */ const Tcl_MethodType *typePtr, /* The type of the method to create. */ - ClientData clientData, /* The per-method type-specific data. */ + void *clientData, /* The per-method type-specific data. */ Proc **procPtrPtr) /* A pointer to the variable in which to write * the procedure record reference. Presumably * inside the structure indicated by the @@ -497,12 +497,12 @@ TclOOMakeProcInstanceMethod( if (context.line && (context.nline >= 4) && (context.line[3] >= 0)) { int isNew; - CmdFrame *cfPtr = ckalloc(sizeof(CmdFrame)); + CmdFrame *cfPtr = (CmdFrame *)ckalloc(sizeof(CmdFrame)); Tcl_HashEntry *hPtr; cfPtr->level = -1; cfPtr->type = context.type; - cfPtr->line = ckalloc(sizeof(int)); + cfPtr->line = (int *)ckalloc(sizeof(int)); cfPtr->line[0] = context.line[3]; cfPtr->nline = 1; cfPtr->framePtr = NULL; @@ -563,7 +563,7 @@ TclOOMakeProcMethod( * NULL. */ const Tcl_MethodType *typePtr, /* The type of the method to create. */ - ClientData clientData, /* The per-method type-specific data. */ + void *clientData, /* The per-method type-specific data. */ Proc **procPtrPtr) /* A pointer to the variable in which to write * the procedure record reference. Presumably * inside the structure indicated by the @@ -610,12 +610,12 @@ TclOOMakeProcMethod( if (context.line && (context.nline >= 4) && (context.line[3] >= 0)) { int isNew; - CmdFrame *cfPtr = ckalloc(sizeof(CmdFrame)); + CmdFrame *cfPtr = (CmdFrame *)ckalloc(sizeof(CmdFrame)); Tcl_HashEntry *hPtr; cfPtr->level = -1; cfPtr->type = context.type; - cfPtr->line = ckalloc(sizeof(int)); + cfPtr->line = (int *)ckalloc(sizeof(int)); cfPtr->line[0] = context.line[3]; cfPtr->nline = 1; cfPtr->framePtr = NULL; @@ -658,13 +658,13 @@ TclOOMakeProcMethod( static int InvokeProcedureMethod( - ClientData clientData, /* Pointer to some per-method context. */ + void *clientData, /* Pointer to some per-method context. */ Tcl_Interp *interp, Tcl_ObjectContext context, /* The method calling context. */ int objc, /* Number of arguments. */ Tcl_Obj *const *objv) /* Arguments as actually seen. */ { - ProcedureMethod *pmPtr = clientData; + ProcedureMethod *pmPtr = (ProcedureMethod *)clientData; int result; PMFrameData *fdPtr; /* Important data that has to have a lifetime * matched by this function (or rather, by the @@ -686,7 +686,7 @@ InvokeProcedureMethod( * Allocate the special frame data. */ - fdPtr = TclStackAlloc(interp, sizeof(PMFrameData)); + fdPtr = (PMFrameData *)TclStackAlloc(interp, sizeof(PMFrameData)); /* * Create a call frame for this method. @@ -739,13 +739,13 @@ InvokeProcedureMethod( static int FinalizePMCall( - ClientData data[], + void *data[], Tcl_Interp *interp, int result) { - ProcedureMethod *pmPtr = data[0]; - Tcl_ObjectContext context = data[1]; - PMFrameData *fdPtr = data[2]; + ProcedureMethod *pmPtr = (ProcedureMethod *)data[0]; + Tcl_ObjectContext context = (Tcl_ObjectContext)data[1]; + PMFrameData *fdPtr = (PMFrameData *)data[2]; /* * Give the post-call callback a chance to do some cleanup. Note that at @@ -999,7 +999,7 @@ ProcedureMethodCompiledVarConnect( if (framePtr == NULL || !(framePtr->isProcCallFrame & FRAME_IS_METHOD)) { return NULL; } - contextPtr = framePtr->clientData; + contextPtr = (CallContext *)framePtr->clientData; /* * If we've done the work before (in a comparable context) then reuse that @@ -1102,7 +1102,7 @@ ProcedureMethodCompiledVarResolver( return TCL_CONTINUE; } - infoPtr = ckalloc(sizeof(OOResVarInfo)); + infoPtr = (OOResVarInfo *)ckalloc(sizeof(OOResVarInfo)); infoPtr->info.fetchProc = ProcedureMethodCompiledVarConnect; infoPtr->info.deleteProc = ProcedureMethodCompiledVarDelete; infoPtr->cachedObjectVar = NULL; @@ -1127,9 +1127,9 @@ ProcedureMethodCompiledVarResolver( static Tcl_Obj * RenderDeclarerName( - ClientData clientData) + void *clientData) { - struct PNI *pni = clientData; + struct PNI *pni = (struct PNI *)clientData; Tcl_Object object = Tcl_MethodDeclarerObject(pni->method); if (object == NULL) { @@ -1163,11 +1163,12 @@ MethodErrorHandler( Tcl_Obj *methodNameObj) { int nameLen, objectNameLen; - CallContext *contextPtr = ((Interp *) interp)->varFramePtr->clientData; + CallContext *contextPtr = (CallContext *)((Interp *) interp)->varFramePtr->clientData; Method *mPtr = contextPtr->callPtr->chain[contextPtr->index].mPtr; const char *objectName, *kindName, *methodName = Tcl_GetStringFromObj(mPtr->namePtr, &nameLen); Object *declarerPtr; + (void)methodNameObj;/* We pull the method name out of context instead of from argument */ if (mPtr->declaringObjectPtr != NULL) { declarerPtr = mPtr->declaringObjectPtr; @@ -1193,11 +1194,12 @@ ConstructorErrorHandler( Tcl_Interp *interp, Tcl_Obj *methodNameObj) { - CallContext *contextPtr = ((Interp *) interp)->varFramePtr->clientData; + CallContext *contextPtr = (CallContext *)((Interp *) interp)->varFramePtr->clientData; Method *mPtr = contextPtr->callPtr->chain[contextPtr->index].mPtr; Object *declarerPtr; const char *objectName, *kindName; int objectNameLen; + (void)methodNameObj;/* Ignore. We know it is the constructor. */ if (mPtr->declaringObjectPtr != NULL) { declarerPtr = mPtr->declaringObjectPtr; @@ -1222,11 +1224,12 @@ DestructorErrorHandler( Tcl_Interp *interp, Tcl_Obj *methodNameObj) { - CallContext *contextPtr = ((Interp *) interp)->varFramePtr->clientData; + CallContext *contextPtr = (CallContext *)((Interp *) interp)->varFramePtr->clientData; Method *mPtr = contextPtr->callPtr->chain[contextPtr->index].mPtr; Object *declarerPtr; const char *objectName, *kindName; int objectNameLen; + (void)methodNameObj; /* Ignore. We know it is the destructor. */ if (mPtr->declaringObjectPtr != NULL) { declarerPtr = mPtr->declaringObjectPtr; @@ -1269,9 +1272,9 @@ DeleteProcedureMethodRecord( static void DeleteProcedureMethod( - ClientData clientData) + void *clientData) { - ProcedureMethod *pmPtr = clientData; + ProcedureMethod *pmPtr = (ProcedureMethod *)clientData; if (pmPtr->refCount-- <= 1) { DeleteProcedureMethodRecord(pmPtr); @@ -1281,10 +1284,10 @@ DeleteProcedureMethod( static int CloneProcedureMethod( Tcl_Interp *interp, - ClientData clientData, - ClientData *newClientData) + void *clientData, + void **newClientData) { - ProcedureMethod *pmPtr = clientData; + ProcedureMethod *pmPtr = (ProcedureMethod *)clientData; ProcedureMethod *pm2Ptr; Tcl_Obj *bodyObj, *argsObj; CompiledLocal *localPtr; @@ -1323,7 +1326,7 @@ CloneProcedureMethod( * record. */ - pm2Ptr = ckalloc(sizeof(ProcedureMethod)); + pm2Ptr = (ProcedureMethod *)ckalloc(sizeof(ProcedureMethod)); memcpy(pm2Ptr, pmPtr, sizeof(ProcedureMethod)); pm2Ptr->refCount = 1; Tcl_IncrRefCount(argsObj); @@ -1377,7 +1380,7 @@ TclOONewForwardInstanceMethod( return NULL; } - fmPtr = ckalloc(sizeof(ForwardMethod)); + fmPtr = (ForwardMethod *)ckalloc(sizeof(ForwardMethod)); fmPtr->prefixObj = prefixObj; Tcl_IncrRefCount(prefixObj); return (Method *) Tcl_NewInstanceMethod(interp, (Tcl_Object) oPtr, @@ -1416,7 +1419,7 @@ TclOONewForwardMethod( return NULL; } - fmPtr = ckalloc(sizeof(ForwardMethod)); + fmPtr = (ForwardMethod *)ckalloc(sizeof(ForwardMethod)); fmPtr->prefixObj = prefixObj; Tcl_IncrRefCount(prefixObj); return (Method *) Tcl_NewMethod(interp, (Tcl_Class) clsPtr, nameObj, @@ -1436,14 +1439,14 @@ TclOONewForwardMethod( static int InvokeForwardMethod( - ClientData clientData, /* Pointer to some per-method context. */ + void *clientData, /* Pointer to some per-method context. */ Tcl_Interp *interp, Tcl_ObjectContext context, /* The method calling context. */ int objc, /* Number of arguments. */ Tcl_Obj *const *objv) /* Arguments as actually seen. */ { CallContext *contextPtr = (CallContext *) context; - ForwardMethod *fmPtr = clientData; + ForwardMethod *fmPtr = (ForwardMethod *)clientData; Tcl_Obj **argObjs, **prefixObjs; int numPrefixes, len, skip = contextPtr->skip; @@ -1470,11 +1473,11 @@ InvokeForwardMethod( static int FinalizeForwardCall( - ClientData data[], + void *data[], Tcl_Interp *interp, int result) { - Tcl_Obj **argObjs = data[0]; + Tcl_Obj **argObjs = (Tcl_Obj **)data[0]; TclStackFree(interp, argObjs); return result; @@ -1492,9 +1495,9 @@ FinalizeForwardCall( static void DeleteForwardMethod( - ClientData clientData) + void *clientData) { - ForwardMethod *fmPtr = clientData; + ForwardMethod *fmPtr = (ForwardMethod *)clientData; Tcl_DecrRefCount(fmPtr->prefixObj); ckfree(fmPtr); @@ -1503,11 +1506,11 @@ DeleteForwardMethod( static int CloneForwardMethod( Tcl_Interp *interp, - ClientData clientData, - ClientData *newClientData) + void *clientData, + void **newClientData) { - ForwardMethod *fmPtr = clientData; - ForwardMethod *fm2Ptr = ckalloc(sizeof(ForwardMethod)); + ForwardMethod *fmPtr = (ForwardMethod *)clientData; + ForwardMethod *fm2Ptr = (ForwardMethod *)ckalloc(sizeof(ForwardMethod)); fm2Ptr->prefixObj = fmPtr->prefixObj; Tcl_IncrRefCount(fm2Ptr->prefixObj); @@ -1531,7 +1534,7 @@ TclOOGetProcFromMethod( Method *mPtr) { if (mPtr->typePtr == &procMethodType) { - ProcedureMethod *pmPtr = mPtr->clientData; + ProcedureMethod *pmPtr = (ProcedureMethod *)mPtr->clientData; return pmPtr->procPtr; } @@ -1543,7 +1546,7 @@ TclOOGetMethodBody( Method *mPtr) { if (mPtr->typePtr == &procMethodType) { - ProcedureMethod *pmPtr = mPtr->clientData; + ProcedureMethod *pmPtr = (ProcedureMethod *)mPtr->clientData; if (pmPtr->procPtr->bodyPtr->bytes == NULL) { (void) Tcl_GetString(pmPtr->procPtr->bodyPtr); @@ -1558,7 +1561,7 @@ TclOOGetFwdFromMethod( Method *mPtr) { if (mPtr->typePtr == &fwdMethodType) { - ForwardMethod *fwPtr = mPtr->clientData; + ForwardMethod *fwPtr = (ForwardMethod *)mPtr->clientData; return fwPtr->prefixObj; } @@ -1600,7 +1603,7 @@ InitEnsembleRewrite( * array of rewritten arguments. */ { unsigned len = rewriteLength + objc - toRewrite; - Tcl_Obj **argObjs = TclStackAlloc(interp, sizeof(Tcl_Obj *) * len); + Tcl_Obj **argObjs = (Tcl_Obj **)TclStackAlloc(interp, sizeof(Tcl_Obj *) * len); memcpy(argObjs, rewriteObjs, rewriteLength * sizeof(Tcl_Obj *)); memcpy(argObjs + rewriteLength, objv + toRewrite, @@ -1655,7 +1658,7 @@ int Tcl_MethodIsType( Tcl_Method method, const Tcl_MethodType *typePtr, - ClientData *clientDataPtr) + void **clientDataPtr) { Method *mPtr = (Method *) method; @@ -1686,7 +1689,7 @@ TclOONewProcInstanceMethodEx( TclOO_PreCallProc *preCallPtr, TclOO_PostCallProc *postCallPtr, ProcErrorProc *errProc, - ClientData clientData, + void *clientData, Tcl_Obj *nameObj, /* The name of the method, which must not be * NULL. */ Tcl_Obj *argsObj, /* The formal argument list for the method, @@ -1723,7 +1726,7 @@ TclOONewProcMethodEx( TclOO_PreCallProc *preCallPtr, TclOO_PostCallProc *postCallPtr, ProcErrorProc *errProc, - ClientData clientData, + void *clientData, Tcl_Obj *nameObj, /* The name of the method, which may be NULL; * if so, up to caller to manage storage * (e.g., because it is a constructor or -- cgit v0.12 From e45303142daf39e0a1d4f7e0056c02fcbb3fff5f Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Sun, 21 Aug 2022 21:00:30 +0000 Subject: Add (dummy) stub entries to TclOO (matching TIP #630) --- generic/tclOO.decls | 24 ++++++++++++------------ generic/tclOODecls.h | 43 ++++++++++++++++++++++++++----------------- generic/tclOOIntDecls.h | 28 ++++++++++++++-------------- generic/tclOOStubInit.c | 5 ++++- 4 files changed, 56 insertions(+), 44 deletions(-) diff --git a/generic/tclOO.decls b/generic/tclOO.decls index 8a4fd1e..67b1996 100644 --- a/generic/tclOO.decls +++ b/generic/tclOO.decls @@ -51,7 +51,7 @@ declare 8 { } declare 9 { int Tcl_MethodIsType(Tcl_Method method, const Tcl_MethodType *typePtr, - ClientData *clientDataPtr) + void **clientDataPtr) } declare 10 { Tcl_Obj *Tcl_MethodName(Tcl_Method method) @@ -59,12 +59,12 @@ declare 10 { declare 11 { Tcl_Method Tcl_NewInstanceMethod(Tcl_Interp *interp, Tcl_Object object, Tcl_Obj *nameObj, int isPublic, const Tcl_MethodType *typePtr, - ClientData clientData) + void *clientData) } declare 12 { Tcl_Method Tcl_NewMethod(Tcl_Interp *interp, Tcl_Class cls, Tcl_Obj *nameObj, int isPublic, const Tcl_MethodType *typePtr, - ClientData clientData) + void *clientData) } declare 13 { Tcl_Object Tcl_NewObjectInstance(Tcl_Interp *interp, Tcl_Class cls, @@ -87,20 +87,20 @@ declare 18 { int Tcl_ObjectContextSkippedArgs(Tcl_ObjectContext context) } declare 19 { - ClientData Tcl_ClassGetMetadata(Tcl_Class clazz, + void *Tcl_ClassGetMetadata(Tcl_Class clazz, const Tcl_ObjectMetadataType *typePtr) } declare 20 { void Tcl_ClassSetMetadata(Tcl_Class clazz, - const Tcl_ObjectMetadataType *typePtr, ClientData metadata) + const Tcl_ObjectMetadataType *typePtr, void *metadata) } declare 21 { - ClientData Tcl_ObjectGetMetadata(Tcl_Object object, + void *Tcl_ObjectGetMetadata(Tcl_Object object, const Tcl_ObjectMetadataType *typePtr) } declare 22 { void Tcl_ObjectSetMetadata(Tcl_Object object, - const Tcl_ObjectMetadataType *typePtr, ClientData metadata) + const Tcl_ObjectMetadataType *typePtr, void *metadata) } declare 23 { int Tcl_ObjectContextInvokeNext(Tcl_Interp *interp, @@ -126,7 +126,7 @@ declare 27 { declare 28 { Tcl_Obj *Tcl_GetObjectName(Tcl_Interp *interp, Tcl_Object object) } -declare 31 { +declare 34 { void TclOOUnusedStubEntry(void) } @@ -144,14 +144,14 @@ declare 0 { declare 1 { Tcl_Method TclOOMakeProcInstanceMethod(Tcl_Interp *interp, Object *oPtr, int flags, Tcl_Obj *nameObj, Tcl_Obj *argsObj, Tcl_Obj *bodyObj, - const Tcl_MethodType *typePtr, ClientData clientData, + const Tcl_MethodType *typePtr, void *clientData, Proc **procPtrPtr) } declare 2 { 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, - ClientData clientData, Proc **procPtrPtr) + void *clientData, Proc **procPtrPtr) } declare 3 { Method *TclOONewProcInstanceMethod(Tcl_Interp *interp, Object *oPtr, @@ -182,13 +182,13 @@ declare 9 { Tcl_Method TclOONewProcInstanceMethodEx(Tcl_Interp *interp, Tcl_Object oPtr, TclOO_PreCallProc *preCallPtr, TclOO_PostCallProc *postCallPtr, ProcErrorProc *errProc, - ClientData clientData, Tcl_Obj *nameObj, Tcl_Obj *argsObj, + void *clientData, Tcl_Obj *nameObj, Tcl_Obj *argsObj, Tcl_Obj *bodyObj, int flags, void **internalTokenPtr) } declare 10 { Tcl_Method TclOONewProcMethodEx(Tcl_Interp *interp, Tcl_Class clsPtr, TclOO_PreCallProc *preCallPtr, TclOO_PostCallProc *postCallPtr, - ProcErrorProc *errProc, ClientData clientData, Tcl_Obj *nameObj, + ProcErrorProc *errProc, void *clientData, Tcl_Obj *nameObj, Tcl_Obj *argsObj, Tcl_Obj *bodyObj, int flags, void **internalTokenPtr) } diff --git a/generic/tclOODecls.h b/generic/tclOODecls.h index ead34f7..647bbd5 100644 --- a/generic/tclOODecls.h +++ b/generic/tclOODecls.h @@ -53,19 +53,19 @@ TCLAPI int Tcl_MethodIsPublic(Tcl_Method method); /* 9 */ TCLAPI int Tcl_MethodIsType(Tcl_Method method, const Tcl_MethodType *typePtr, - ClientData *clientDataPtr); + void **clientDataPtr); /* 10 */ TCLAPI Tcl_Obj * Tcl_MethodName(Tcl_Method method); /* 11 */ TCLAPI Tcl_Method Tcl_NewInstanceMethod(Tcl_Interp *interp, Tcl_Object object, Tcl_Obj *nameObj, int isPublic, const Tcl_MethodType *typePtr, - ClientData clientData); + void *clientData); /* 12 */ TCLAPI Tcl_Method Tcl_NewMethod(Tcl_Interp *interp, Tcl_Class cls, Tcl_Obj *nameObj, int isPublic, const Tcl_MethodType *typePtr, - ClientData clientData); + void *clientData); /* 13 */ TCLAPI Tcl_Object Tcl_NewObjectInstance(Tcl_Interp *interp, Tcl_Class cls, const char *nameStr, @@ -84,19 +84,19 @@ TCLAPI Tcl_Object Tcl_ObjectContextObject(Tcl_ObjectContext context); TCLAPI int Tcl_ObjectContextSkippedArgs( Tcl_ObjectContext context); /* 19 */ -TCLAPI ClientData Tcl_ClassGetMetadata(Tcl_Class clazz, +TCLAPI void * Tcl_ClassGetMetadata(Tcl_Class clazz, const Tcl_ObjectMetadataType *typePtr); /* 20 */ TCLAPI void Tcl_ClassSetMetadata(Tcl_Class clazz, const Tcl_ObjectMetadataType *typePtr, - ClientData metadata); + void *metadata); /* 21 */ -TCLAPI ClientData Tcl_ObjectGetMetadata(Tcl_Object object, +TCLAPI void * Tcl_ObjectGetMetadata(Tcl_Object object, const Tcl_ObjectMetadataType *typePtr); /* 22 */ TCLAPI void Tcl_ObjectSetMetadata(Tcl_Object object, const Tcl_ObjectMetadataType *typePtr, - ClientData metadata); + void *metadata); /* 23 */ TCLAPI int Tcl_ObjectContextInvokeNext(Tcl_Interp *interp, Tcl_ObjectContext context, int objc, @@ -118,7 +118,10 @@ TCLAPI Tcl_Obj * Tcl_GetObjectName(Tcl_Interp *interp, Tcl_Object object); /* Slot 29 is reserved */ /* Slot 30 is reserved */ -/* 31 */ +/* Slot 31 is reserved */ +/* Slot 32 is reserved */ +/* Slot 33 is reserved */ +/* 34 */ TCLAPI void TclOOUnusedStubEntry(void); typedef struct { @@ -138,20 +141,20 @@ typedef struct TclOOStubs { Tcl_Class (*tcl_MethodDeclarerClass) (Tcl_Method method); /* 6 */ Tcl_Object (*tcl_MethodDeclarerObject) (Tcl_Method method); /* 7 */ int (*tcl_MethodIsPublic) (Tcl_Method method); /* 8 */ - int (*tcl_MethodIsType) (Tcl_Method method, const Tcl_MethodType *typePtr, ClientData *clientDataPtr); /* 9 */ + int (*tcl_MethodIsType) (Tcl_Method method, const Tcl_MethodType *typePtr, void **clientDataPtr); /* 9 */ Tcl_Obj * (*tcl_MethodName) (Tcl_Method method); /* 10 */ - Tcl_Method (*tcl_NewInstanceMethod) (Tcl_Interp *interp, Tcl_Object object, Tcl_Obj *nameObj, int isPublic, const Tcl_MethodType *typePtr, ClientData clientData); /* 11 */ - Tcl_Method (*tcl_NewMethod) (Tcl_Interp *interp, Tcl_Class cls, Tcl_Obj *nameObj, int isPublic, const Tcl_MethodType *typePtr, ClientData clientData); /* 12 */ + Tcl_Method (*tcl_NewInstanceMethod) (Tcl_Interp *interp, Tcl_Object object, Tcl_Obj *nameObj, int isPublic, const Tcl_MethodType *typePtr, void *clientData); /* 11 */ + Tcl_Method (*tcl_NewMethod) (Tcl_Interp *interp, Tcl_Class cls, Tcl_Obj *nameObj, int isPublic, 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 */ int (*tcl_ObjectDeleted) (Tcl_Object object); /* 14 */ 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 */ - ClientData (*tcl_ClassGetMetadata) (Tcl_Class clazz, const Tcl_ObjectMetadataType *typePtr); /* 19 */ - void (*tcl_ClassSetMetadata) (Tcl_Class clazz, const Tcl_ObjectMetadataType *typePtr, ClientData metadata); /* 20 */ - ClientData (*tcl_ObjectGetMetadata) (Tcl_Object object, const Tcl_ObjectMetadataType *typePtr); /* 21 */ - void (*tcl_ObjectSetMetadata) (Tcl_Object object, const Tcl_ObjectMetadataType *typePtr, ClientData metadata); /* 22 */ + 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 */ + 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 */ Tcl_ObjectMapMethodNameProc * (*tcl_ObjectGetMethodNameMapper) (Tcl_Object object); /* 24 */ void (*tcl_ObjectSetMethodNameMapper) (Tcl_Object object, Tcl_ObjectMapMethodNameProc *mapMethodNameProc); /* 25 */ @@ -160,7 +163,10 @@ typedef struct TclOOStubs { Tcl_Obj * (*tcl_GetObjectName) (Tcl_Interp *interp, Tcl_Object object); /* 28 */ void (*reserved29)(void); void (*reserved30)(void); - void (*tclOOUnusedStubEntry) (void); /* 31 */ + void (*reserved31)(void); + void (*reserved32)(void); + void (*reserved33)(void); + void (*tclOOUnusedStubEntry) (void); /* 34 */ } TclOOStubs; extern const TclOOStubs *tclOOStubsPtr; @@ -235,8 +241,11 @@ extern const TclOOStubs *tclOOStubsPtr; (tclOOStubsPtr->tcl_GetObjectName) /* 28 */ /* Slot 29 is reserved */ /* Slot 30 is reserved */ +/* Slot 31 is reserved */ +/* Slot 32 is reserved */ +/* Slot 33 is reserved */ #define TclOOUnusedStubEntry \ - (tclOOStubsPtr->tclOOUnusedStubEntry) /* 31 */ + (tclOOStubsPtr->tclOOUnusedStubEntry) /* 34 */ #endif /* defined(USE_TCLOO_STUBS) */ diff --git a/generic/tclOOIntDecls.h b/generic/tclOOIntDecls.h index 74a8d81..6a5cfd3 100644 --- a/generic/tclOOIntDecls.h +++ b/generic/tclOOIntDecls.h @@ -22,14 +22,14 @@ TCLAPI Tcl_Method TclOOMakeProcInstanceMethod(Tcl_Interp *interp, Object *oPtr, int flags, Tcl_Obj *nameObj, Tcl_Obj *argsObj, Tcl_Obj *bodyObj, const Tcl_MethodType *typePtr, - ClientData clientData, Proc **procPtrPtr); + void *clientData, Proc **procPtrPtr); /* 2 */ TCLAPI 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, - ClientData clientData, Proc **procPtrPtr); + void *clientData, Proc **procPtrPtr); /* 3 */ TCLAPI Method * TclOONewProcInstanceMethod(Tcl_Interp *interp, Object *oPtr, int flags, Tcl_Obj *nameObj, @@ -59,19 +59,19 @@ TCLAPI Tcl_Method TclOONewProcInstanceMethodEx(Tcl_Interp *interp, Tcl_Object oPtr, TclOO_PreCallProc *preCallPtr, TclOO_PostCallProc *postCallPtr, - ProcErrorProc *errProc, - ClientData clientData, Tcl_Obj *nameObj, - Tcl_Obj *argsObj, Tcl_Obj *bodyObj, - int flags, void **internalTokenPtr); + ProcErrorProc *errProc, void *clientData, + Tcl_Obj *nameObj, Tcl_Obj *argsObj, + Tcl_Obj *bodyObj, int flags, + void **internalTokenPtr); /* 10 */ TCLAPI Tcl_Method TclOONewProcMethodEx(Tcl_Interp *interp, Tcl_Class clsPtr, TclOO_PreCallProc *preCallPtr, TclOO_PostCallProc *postCallPtr, - ProcErrorProc *errProc, - ClientData clientData, Tcl_Obj *nameObj, - Tcl_Obj *argsObj, Tcl_Obj *bodyObj, - int flags, void **internalTokenPtr); + ProcErrorProc *errProc, void *clientData, + Tcl_Obj *nameObj, Tcl_Obj *argsObj, + Tcl_Obj *bodyObj, int flags, + void **internalTokenPtr); /* 11 */ TCLAPI int TclOOInvokeObject(Tcl_Interp *interp, Tcl_Object object, Tcl_Class startCls, @@ -97,16 +97,16 @@ typedef struct TclOOIntStubs { void *hooks; Tcl_Object (*tclOOGetDefineCmdContext) (Tcl_Interp *interp); /* 0 */ - Tcl_Method (*tclOOMakeProcInstanceMethod) (Tcl_Interp *interp, Object *oPtr, int flags, Tcl_Obj *nameObj, Tcl_Obj *argsObj, Tcl_Obj *bodyObj, const Tcl_MethodType *typePtr, ClientData clientData, Proc **procPtrPtr); /* 1 */ - 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, ClientData clientData, Proc **procPtrPtr); /* 2 */ + Tcl_Method (*tclOOMakeProcInstanceMethod) (Tcl_Interp *interp, Object *oPtr, int flags, Tcl_Obj *nameObj, Tcl_Obj *argsObj, Tcl_Obj *bodyObj, const Tcl_MethodType *typePtr, void *clientData, Proc **procPtrPtr); /* 1 */ + 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 (*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, ClientData 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, ClientData clientData, Tcl_Obj *nameObj, Tcl_Obj *argsObj, Tcl_Obj *bodyObj, int flags, void **internalTokenPtr); /* 10 */ + 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 */ 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 */ diff --git a/generic/tclOOStubInit.c b/generic/tclOOStubInit.c index e8534eb..735d871 100644 --- a/generic/tclOOStubInit.c +++ b/generic/tclOOStubInit.c @@ -77,7 +77,10 @@ const TclOOStubs tclOOStubs = { Tcl_GetObjectName, /* 28 */ 0, /* 29 */ 0, /* 30 */ - TclOOUnusedStubEntry, /* 31 */ + 0, /* 31 */ + 0, /* 32 */ + 0, /* 33 */ + TclOOUnusedStubEntry, /* 34 */ }; /* !END!: Do not edit above this line. */ -- cgit v0.12 From 267ce5dd65e1d36a209381dc9077ddaa94b6e8e3 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Sun, 21 Aug 2022 22:34:42 +0000 Subject: ubuntu-18.04 is deprecated --- .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 c4212d4..45ce720 100644 --- a/.github/workflows/onefiledist.yml +++ b/.github/workflows/onefiledist.yml @@ -5,7 +5,7 @@ permissions: jobs: linux: name: Linux - runs-on: ubuntu-18.04 + runs-on: ubuntu-20.04 defaults: run: shell: bash -- cgit v0.12 From 192a96c334f64f1187e9088a912f79970ceab7b3 Mon Sep 17 00:00:00 2001 From: apnadkarni Date: Mon, 22 Aug 2022 03:50:43 +0000 Subject: Add two missing locks. Enable read-ahead if read fileevent registered even for blocking console. Account for focus-in events in console buffer. --- win/tclWinConsole.c | 52 ++++++++++++++++++++++++++++++---------------------- 1 file changed, 30 insertions(+), 22 deletions(-) diff --git a/win/tclWinConsole.c b/win/tclWinConsole.c index 4b2d1d3..753a572 100644 --- a/win/tclWinConsole.c +++ b/win/tclWinConsole.c @@ -19,8 +19,8 @@ #include /* - * A general note on the design: The console channel driver differs from most - * other drivers in the following respects: + * A general note on the design: The console channel driver differs from + * most other drivers in the following respects: * * - There can be at most 3 console handles at any time since Windows does * support allocation of more than one console (with three handles @@ -35,9 +35,10 @@ * std* channels are shared amongst threads which means there can be * multiple Tcl channels corresponding to a single console handle. * - * - Even with multiple threads, more than one file event handler is unlikely. - * It does not make sense for multiple threads to register handlers for - * stdin because the input would be randomly fragmented amongst the threads. + * - Even with multiple threads, more than one file event handler is + * unlikely. It does not make sense for multiple threads to register + * handlers for stdin because the input would be randomly fragmented amongst + * the threads. * * Various design factors are driven by the above, e.g. use of lists instead * of hash tables (at most 3 console handles) and use of global instead of @@ -55,9 +56,9 @@ * because an interpreter may (for example) turn off echo for passwords and * the read ahead would come in the way of that. * - * If multiple threads are reading from stdin, the input is sprayed in random - * fashion. This is not good application design and hence no plan to address - * this (not clear what should be done even in theory) + * If multiple threads are reading from stdin, the input is sprayed in + * random fashion. This is not good application design and hence no plan to + * address this (not clear what should be done even in theory) * * For output, we do not restrict all output to the console writer threads. * See ConsoleOutputProc for the conditions. @@ -152,7 +153,7 @@ typedef struct ConsoleHandleInfo { * only from the thread owning channel EXCEPT when a console traverses it * looking for a channel that is watching for events on the console. Even * in that case, no locking is required because that access is only under - * the consoleLock lock which prevents the channel from being removed from + * the gConsoleLock lock which prevents the channel from being removed from * the gWatchingChannelList which in turn means it will not be deallocated * from under the console thread. Access to individual fields does not need * to be controlled because @@ -1115,12 +1116,6 @@ ConsoleInputProc( * buffered data, we will pass it up. */ if (numRead != 0) { - /* If console thread was blocked, awaken it */ - if (chanInfoPtr->flags & CONSOLE_ASYNC) { - /* Async channels always want read ahead */ - handleInfoPtr->flags |= CONSOLE_DATA_AWAITED; - WakeConditionVariable(&handleInfoPtr->consoleThreadCV); - } break; } /* @@ -1211,7 +1206,9 @@ ConsoleInputProc( /* Lock is reacquired, loop back to try again */ } - if (chanInfoPtr->flags & CONSOLE_ASYNC) { + /* We read data. Ask for more if either async or watching for reads */ + if ((chanInfoPtr->flags & CONSOLE_ASYNC) + || (chanInfoPtr->watchMask & TCL_READABLE)) { handleInfoPtr->flags |= CONSOLE_DATA_AWAITED; WakeConditionVariable(&handleInfoPtr->consoleThreadCV); } @@ -1345,7 +1342,7 @@ ConsoleOutputProc( } } - /* Lock is reacquired. Continue loop */ + /* Lock must have been reacquired before continuing loop */ } WakeConditionVariable(&handleInfoPtr->consoleThreadCV); ReleaseSRWLockExclusive(&handleInfoPtr->lock); @@ -1511,8 +1508,10 @@ ConsoleWatchProc( ConsoleHandleInfo *handleInfoPtr; handleInfoPtr = FindConsoleInfo(chanInfoPtr); if (handleInfoPtr) { + AcquireSRWLockExclusive(&handleInfoPtr->lock); handleInfoPtr->flags |= CONSOLE_DATA_AWAITED; WakeConditionVariable(&handleInfoPtr->consoleThreadCV); + ReleaseSRWLockExclusive(&handleInfoPtr->lock); } ReleaseSRWLockExclusive(&gConsoleLock); } @@ -1520,6 +1519,7 @@ ConsoleWatchProc( } else if (oldMask) { /* Remove from list of watched channels */ + AcquireSRWLockExclusive(&gConsoleLock); for (nextPtrPtr = &gWatchingChannelList, ptr = *nextPtrPtr; ptr != NULL; nextPtrPtr = &ptr->nextWatchingChannelPtr, ptr = *nextPtrPtr) { @@ -1528,6 +1528,7 @@ ConsoleWatchProc( break; } } + ReleaseSRWLockExclusive(&gConsoleLock); } } @@ -1583,7 +1584,7 @@ ConsoleGetHandleProc( static int ConsoleDataAvailable (HANDLE consoleHandle) { - INPUT_RECORD input[5]; + INPUT_RECORD input[10]; DWORD count; DWORD i; @@ -1595,11 +1596,17 @@ ConsoleGetHandleProc( == FALSE) { return -1; } + /* + * Even if windows size and mouse events are disabled, can still have + * events other than keyboard, like focus events. Look for at least one + * keydown event because a trailing LF keyup is always present from the + * last input. However, if our buffer is full, assume there is a key + * down somewhere in the unread buffer. I suppose we could expand the + * buffer but not worth... + */ + if (count == (sizeof(input)/sizeof(input[0]))) + return 1; for (i = 0; i < count; ++i) { - /* - * Event must be a keydown because a trailing LF keyup event is always - * present for line based input. - */ if (input[i].EventType == KEY_EVENT && input[i].Event.KeyEvent.bKeyDown) { return 1; @@ -1996,6 +2003,7 @@ AllocateConsoleHandleInfo( handleInfoPtr = (ConsoleHandleInfo *)ckalloc(sizeof(*handleInfoPtr)); + memset(handleInfoPtr, 0, sizeof(*handleInfoPtr)); handleInfoPtr->console = consoleHandle; InitializeSRWLock(&handleInfoPtr->lock); InitializeConditionVariable(&handleInfoPtr->consoleThreadCV); -- cgit v0.12 From 25934485e8192cdf5832602923131de652588ffb Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 22 Aug 2022 07:22:29 +0000 Subject: ubuntu-18.04 is deprecated --- .github/workflows/linux-build.yml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.github/workflows/linux-build.yml b/.github/workflows/linux-build.yml index 0bbfbd2..d619507 100644 --- a/.github/workflows/linux-build.yml +++ b/.github/workflows/linux-build.yml @@ -4,7 +4,7 @@ permissions: contents: read jobs: gcc: - runs-on: ubuntu-18.04 + runs-on: ubuntu-20.04 strategy: matrix: cfgopt: -- cgit v0.12 From 1baffa9080094e6b95d3ece1f49479ae26c78bec Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 22 Aug 2022 07:29:21 +0000 Subject: Do github actions builds on Ubuntu 22.04 (was: 20.04) --- .github/workflows/linux-build.yml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.github/workflows/linux-build.yml b/.github/workflows/linux-build.yml index d5b9c78..01fcdfd 100644 --- a/.github/workflows/linux-build.yml +++ b/.github/workflows/linux-build.yml @@ -4,7 +4,7 @@ permissions: contents: read jobs: gcc: - runs-on: ubuntu-20.04 + runs-on: ubuntu-22.04 strategy: matrix: cfgopt: -- cgit v0.12 From 7fd9e2f5fdd413114e252c3c3db7546551e309a9 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 22 Aug 2022 10:17:38 +0000 Subject: Fix build error in tclTest.c (conflict with TIP #630). Handled deleteProc correctly in Tcl_(Set|Get)CommandInfo. --- generic/tclBasic.c | 35 ++++++++++++++++------------------- generic/tclTest.c | 4 ++-- 2 files changed, 18 insertions(+), 21 deletions(-) diff --git a/generic/tclBasic.c b/generic/tclBasic.c index f7f6ed8..645a581 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -3377,8 +3377,14 @@ Tcl_SetCommandInfoFromToken( } cmdPtr->objClientData = infoPtr->objClientData; } - cmdPtr->deleteProc = infoPtr->deleteProc; - cmdPtr->deleteData = infoPtr->deleteData; + if (cmdPtr->deleteProc == cmdWrapperDeleteProc) { + CmdWrapperInfo *info = (CmdWrapperInfo *)cmdPtr->deleteData; + info->deleteProc = infoPtr->deleteProc; + info->clientData = infoPtr->deleteData; + } else { + cmdPtr->deleteProc = infoPtr->deleteProc; + cmdPtr->deleteData = infoPtr->deleteData; + } return 1; } @@ -3432,21 +3438,6 @@ Tcl_GetCommandInfo( *---------------------------------------------------------------------- */ -#if TCL_MAJOR_VERSION > 8 || defined(TCL_NO_DEPRECATED) -static int cmdWrapper2Proc(void *clientData, - Tcl_Interp *interp, - size_t objc, - Tcl_Obj *const objv[]) -{ - Command *cmdPtr = (Command *)clientData; - if (objc > INT_MAX) { - Tcl_WrongNumArgs(interp, 1, objv, "?arg ...?"); - return TCL_ERROR; - } - return cmdPtr->objProc(cmdPtr->objClientData, interp, objc, objv); -} -#endif - int Tcl_GetCommandInfoFromToken( Tcl_Command cmd, @@ -3470,8 +3461,14 @@ Tcl_GetCommandInfoFromToken( infoPtr->objClientData = cmdPtr->objClientData; infoPtr->proc = cmdPtr->proc; infoPtr->clientData = cmdPtr->clientData; - infoPtr->deleteProc = cmdPtr->deleteProc; - infoPtr->deleteData = cmdPtr->deleteData; + if (cmdPtr->deleteProc == cmdWrapperDeleteProc) { + CmdWrapperInfo *info = (CmdWrapperInfo *)cmdPtr->deleteData; + infoPtr->deleteProc = info->deleteProc; + infoPtr->deleteData = info->clientData; + } else { + infoPtr->deleteProc = cmdPtr->deleteProc; + infoPtr->deleteData = cmdPtr->deleteData; + } infoPtr->namespacePtr = (Tcl_Namespace *) cmdPtr->nsPtr; return 1; } diff --git a/generic/tclTest.c b/generic/tclTest.c index 3db70fc..7cdd354 100644 --- a/generic/tclTest.c +++ b/generic/tclTest.c @@ -222,7 +222,7 @@ static Tcl_ObjCmdProc2 TestbytestringObjCmd; static Tcl_ObjCmdProc2 TestsetbytearraylengthObjCmd; static Tcl_ObjCmdProc2 TestpurebytesobjObjCmd; static Tcl_ObjCmdProc2 TeststringbytesObjCmd; -static Tcl_ObjCmdProc Testutf16stringObjCmd; +static Tcl_ObjCmdProc2 Testutf16stringObjCmd; static Tcl_CmdProc TestcmdinfoCmd; static Tcl_CmdProc TestcmdtokenCmd; static Tcl_CmdProc TestcmdtraceCmd; @@ -4039,7 +4039,7 @@ TestregexpObjCmd( Tcl_Obj *newPtr, *varPtr, *valuePtr; varPtr = objv[i]; - ii = ((cflags®_EXPECT) && i == objc-1) ? -1 : i; + ii = ((cflags®_EXPECT) && i == objc-1) ? -1 : (int)i; if (indices) { Tcl_Obj *objs[2]; -- cgit v0.12 From db0b1d30827fba12dba7afb143c0ff8d0daceddd Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 23 Aug 2022 06:32:49 +0000 Subject: Update tzdata to 2022c --- library/tzdata/America/Punta_Arenas | 1 + library/tzdata/America/Santiago | 4 +- library/tzdata/Antarctica/Vostok | 7 +- library/tzdata/Arctic/Longyearbyen | 6 +- library/tzdata/Asia/Brunei | 8 +- library/tzdata/Asia/Ho_Chi_Minh | 4 +- library/tzdata/Asia/Kuala_Lumpur | 14 +- library/tzdata/Asia/Tehran | 165 +---------------- library/tzdata/Atlantic/Jan_Mayen | 6 +- library/tzdata/Atlantic/Reykjavik | 74 +------- library/tzdata/Canada/East-Saskatchewan | 5 - library/tzdata/Europe/Amsterdam | 311 +------------------------------ library/tzdata/Europe/Copenhagen | 265 +------------------------- library/tzdata/Europe/Dublin | 4 +- library/tzdata/Europe/Kiev | 252 +------------------------ library/tzdata/Europe/Luxembourg | 314 +------------------------------ library/tzdata/Europe/Monaco | 316 +------------------------------- library/tzdata/Europe/Oslo | 272 +-------------------------- library/tzdata/Europe/Simferopol | 8 +- library/tzdata/Europe/Stockholm | 251 +------------------------ library/tzdata/Iceland | 6 +- library/tzdata/Indian/Christmas | 7 +- library/tzdata/Indian/Cocos | 7 +- library/tzdata/Indian/Kerguelen | 7 +- library/tzdata/Indian/Mahe | 7 +- library/tzdata/Indian/Reunion | 7 +- library/tzdata/Pacific/Chuuk | 12 +- library/tzdata/Pacific/Easter | 2 +- library/tzdata/Pacific/Funafuti | 7 +- library/tzdata/Pacific/Majuro | 13 +- library/tzdata/Pacific/Pohnpei | 13 +- library/tzdata/Pacific/Ponape | 6 +- library/tzdata/Pacific/Truk | 6 +- library/tzdata/Pacific/Wake | 7 +- library/tzdata/Pacific/Wallis | 7 +- library/tzdata/Pacific/Yap | 6 +- library/tzdata/US/Pacific-New | 5 - 37 files changed, 102 insertions(+), 2310 deletions(-) delete mode 100644 library/tzdata/Canada/East-Saskatchewan delete mode 100644 library/tzdata/US/Pacific-New diff --git a/library/tzdata/America/Punta_Arenas b/library/tzdata/America/Punta_Arenas index 959a0c1..8b06e6a 100644 --- a/library/tzdata/America/Punta_Arenas +++ b/library/tzdata/America/Punta_Arenas @@ -21,6 +21,7 @@ set TZData(:America/Punta_Arenas) { {-1178132400 -14400 0 -04} {-870552000 -18000 0 -05} {-865278000 -14400 0 -04} + {-736632000 -14400 1 -04} {-718056000 -18000 0 -05} {-713649600 -14400 0 -04} {-36619200 -10800 1 -04} diff --git a/library/tzdata/America/Santiago b/library/tzdata/America/Santiago index 801d3f2..13b8b99 100644 --- a/library/tzdata/America/Santiago +++ b/library/tzdata/America/Santiago @@ -22,7 +22,7 @@ set TZData(:America/Santiago) { {-870552000 -18000 0 -05} {-865278000 -14400 0 -04} {-740520000 -10800 1 -03} - {-736376400 -14400 0 -04} + {-736635600 -14400 1 -04} {-718056000 -18000 0 -05} {-713649600 -14400 0 -04} {-36619200 -10800 1 -04} @@ -131,7 +131,7 @@ set TZData(:America/Santiago) { {1617505200 -14400 0 -04} {1630814400 -10800 1 -04} {1648954800 -14400 0 -04} - {1662264000 -10800 1 -04} + {1662868800 -10800 1 -04} {1680404400 -14400 0 -04} {1693713600 -10800 1 -04} {1712458800 -14400 0 -04} diff --git a/library/tzdata/Antarctica/Vostok b/library/tzdata/Antarctica/Vostok index 7f345a2..1a19a5d 100644 --- a/library/tzdata/Antarctica/Vostok +++ b/library/tzdata/Antarctica/Vostok @@ -1,6 +1,5 @@ # created by tools/tclZIC.tcl - do not edit - -set TZData(:Antarctica/Vostok) { - {-9223372036854775808 0 0 -00} - {-380073600 21600 0 +06} +if {![info exists TZData(Asia/Urumqi)]} { + LoadTimeZoneFile Asia/Urumqi } +set TZData(:Antarctica/Vostok) $TZData(:Asia/Urumqi) diff --git a/library/tzdata/Arctic/Longyearbyen b/library/tzdata/Arctic/Longyearbyen index 51f83dc..4b52387 100644 --- a/library/tzdata/Arctic/Longyearbyen +++ b/library/tzdata/Arctic/Longyearbyen @@ -1,5 +1,5 @@ # created by tools/tclZIC.tcl - do not edit -if {![info exists TZData(Europe/Oslo)]} { - LoadTimeZoneFile Europe/Oslo +if {![info exists TZData(Europe/Berlin)]} { + LoadTimeZoneFile Europe/Berlin } -set TZData(:Arctic/Longyearbyen) $TZData(:Europe/Oslo) +set TZData(:Arctic/Longyearbyen) $TZData(:Europe/Berlin) diff --git a/library/tzdata/Asia/Brunei b/library/tzdata/Asia/Brunei index e8cc8c3..ec1a78d 100644 --- a/library/tzdata/Asia/Brunei +++ b/library/tzdata/Asia/Brunei @@ -1,7 +1,5 @@ # created by tools/tclZIC.tcl - do not edit - -set TZData(:Asia/Brunei) { - {-9223372036854775808 27580 0 LMT} - {-1383464380 27000 0 +0730} - {-1167636600 28800 0 +08} +if {![info exists TZData(Asia/Kuching)]} { + LoadTimeZoneFile Asia/Kuching } +set TZData(:Asia/Brunei) $TZData(:Asia/Kuching) diff --git a/library/tzdata/Asia/Ho_Chi_Minh b/library/tzdata/Asia/Ho_Chi_Minh index b4e749b..4689516 100644 --- a/library/tzdata/Asia/Ho_Chi_Minh +++ b/library/tzdata/Asia/Ho_Chi_Minh @@ -1,8 +1,8 @@ # created by tools/tclZIC.tcl - do not edit set TZData(:Asia/Ho_Chi_Minh) { - {-9223372036854775808 25600 0 LMT} - {-2004073600 25590 0 PLMT} + {-9223372036854775808 25590 0 LMT} + {-2004073590 25590 0 PLMT} {-1851577590 25200 0 +07} {-852105600 28800 0 +08} {-782643600 32400 0 +09} diff --git a/library/tzdata/Asia/Kuala_Lumpur b/library/tzdata/Asia/Kuala_Lumpur index 84eae1d..177539a 100644 --- a/library/tzdata/Asia/Kuala_Lumpur +++ b/library/tzdata/Asia/Kuala_Lumpur @@ -1,13 +1,5 @@ # created by tools/tclZIC.tcl - do not edit - -set TZData(:Asia/Kuala_Lumpur) { - {-9223372036854775808 24406 0 LMT} - {-2177477206 24925 0 SMT} - {-2038200925 25200 0 +07} - {-1167634800 26400 1 +0720} - {-1073028000 26400 0 +0720} - {-894180000 27000 0 +0730} - {-879665400 32400 0 +09} - {-767005200 27000 0 +0730} - {378664200 28800 0 +08} +if {![info exists TZData(Asia/Singapore)]} { + LoadTimeZoneFile Asia/Singapore } +set TZData(:Asia/Kuala_Lumpur) $TZData(:Asia/Singapore) diff --git a/library/tzdata/Asia/Tehran b/library/tzdata/Asia/Tehran index 4515523..c453c48 100644 --- a/library/tzdata/Asia/Tehran +++ b/library/tzdata/Asia/Tehran @@ -3,12 +3,13 @@ set TZData(:Asia/Tehran) { {-9223372036854775808 12344 0 LMT} {-1704165944 12344 0 TMT} - {-757394744 12600 0 +0330} - {247177800 14400 0 +04} - {259272000 18000 1 +04} - {277758000 14400 0 +04} + {-1090466744 12600 0 +0330} + {227820600 16200 1 +0330} + {246227400 14400 0 +04} + {259617600 18000 1 +04} + {271108800 14400 0 +04} {283982400 12600 0 +0330} - {290809800 16200 1 +0330} + {296598600 16200 1 +0330} {306531000 12600 0 +0330} {322432200 16200 1 +0330} {338499000 12600 0 +0330} @@ -72,158 +73,4 @@ set TZData(:Asia/Tehran) { {1632252600 12600 0 +0330} {1647894600 16200 1 +0330} {1663788600 12600 0 +0330} - {1679430600 16200 1 +0330} - {1695324600 12600 0 +0330} - {1710966600 16200 1 +0330} - {1726860600 12600 0 +0330} - {1742589000 16200 1 +0330} - {1758483000 12600 0 +0330} - {1774125000 16200 1 +0330} - {1790019000 12600 0 +0330} - {1805661000 16200 1 +0330} - {1821555000 12600 0 +0330} - {1837197000 16200 1 +0330} - {1853091000 12600 0 +0330} - {1868733000 16200 1 +0330} - {1884627000 12600 0 +0330} - {1900355400 16200 1 +0330} - {1916249400 12600 0 +0330} - {1931891400 16200 1 +0330} - {1947785400 12600 0 +0330} - {1963427400 16200 1 +0330} - {1979321400 12600 0 +0330} - {1994963400 16200 1 +0330} - {2010857400 12600 0 +0330} - {2026585800 16200 1 +0330} - {2042479800 12600 0 +0330} - {2058121800 16200 1 +0330} - {2074015800 12600 0 +0330} - {2089657800 16200 1 +0330} - {2105551800 12600 0 +0330} - {2121193800 16200 1 +0330} - {2137087800 12600 0 +0330} - {2152816200 16200 1 +0330} - {2168710200 12600 0 +0330} - {2184352200 16200 1 +0330} - {2200246200 12600 0 +0330} - {2215888200 16200 1 +0330} - {2231782200 12600 0 +0330} - {2247424200 16200 1 +0330} - {2263318200 12600 0 +0330} - {2279046600 16200 1 +0330} - {2294940600 12600 0 +0330} - {2310582600 16200 1 +0330} - {2326476600 12600 0 +0330} - {2342118600 16200 1 +0330} - {2358012600 12600 0 +0330} - {2373654600 16200 1 +0330} - {2389548600 12600 0 +0330} - {2405277000 16200 1 +0330} - {2421171000 12600 0 +0330} - {2436813000 16200 1 +0330} - {2452707000 12600 0 +0330} - {2468349000 16200 1 +0330} - {2484243000 12600 0 +0330} - {2499885000 16200 1 +0330} - {2515779000 12600 0 +0330} - {2531507400 16200 1 +0330} - {2547401400 12600 0 +0330} - {2563043400 16200 1 +0330} - {2578937400 12600 0 +0330} - {2594579400 16200 1 +0330} - {2610473400 12600 0 +0330} - {2626115400 16200 1 +0330} - {2642009400 12600 0 +0330} - {2657737800 16200 1 +0330} - {2673631800 12600 0 +0330} - {2689273800 16200 1 +0330} - {2705167800 12600 0 +0330} - {2720809800 16200 1 +0330} - {2736703800 12600 0 +0330} - {2752345800 16200 1 +0330} - {2768239800 12600 0 +0330} - {2783968200 16200 1 +0330} - {2799862200 12600 0 +0330} - {2815504200 16200 1 +0330} - {2831398200 12600 0 +0330} - {2847040200 16200 1 +0330} - {2862934200 12600 0 +0330} - {2878576200 16200 1 +0330} - {2894470200 12600 0 +0330} - {2910112200 16200 1 +0330} - {2926006200 12600 0 +0330} - {2941734600 16200 1 +0330} - {2957628600 12600 0 +0330} - {2973270600 16200 1 +0330} - {2989164600 12600 0 +0330} - {3004806600 16200 1 +0330} - {3020700600 12600 0 +0330} - {3036342600 16200 1 +0330} - {3052236600 12600 0 +0330} - {3067965000 16200 1 +0330} - {3083859000 12600 0 +0330} - {3099501000 16200 1 +0330} - {3115395000 12600 0 +0330} - {3131037000 16200 1 +0330} - {3146931000 12600 0 +0330} - {3162573000 16200 1 +0330} - {3178467000 12600 0 +0330} - {3194195400 16200 1 +0330} - {3210089400 12600 0 +0330} - {3225731400 16200 1 +0330} - {3241625400 12600 0 +0330} - {3257267400 16200 1 +0330} - {3273161400 12600 0 +0330} - {3288803400 16200 1 +0330} - {3304697400 12600 0 +0330} - {3320425800 16200 1 +0330} - {3336319800 12600 0 +0330} - {3351961800 16200 1 +0330} - {3367855800 12600 0 +0330} - {3383497800 16200 1 +0330} - {3399391800 12600 0 +0330} - {3415033800 16200 1 +0330} - {3430927800 12600 0 +0330} - {3446656200 16200 1 +0330} - {3462550200 12600 0 +0330} - {3478192200 16200 1 +0330} - {3494086200 12600 0 +0330} - {3509728200 16200 1 +0330} - {3525622200 12600 0 +0330} - {3541264200 16200 1 +0330} - {3557158200 12600 0 +0330} - {3572886600 16200 1 +0330} - {3588780600 12600 0 +0330} - {3604422600 16200 1 +0330} - {3620316600 12600 0 +0330} - {3635958600 16200 1 +0330} - {3651852600 12600 0 +0330} - {3667494600 16200 1 +0330} - {3683388600 12600 0 +0330} - {3699117000 16200 1 +0330} - {3715011000 12600 0 +0330} - {3730653000 16200 1 +0330} - {3746547000 12600 0 +0330} - {3762189000 16200 1 +0330} - {3778083000 12600 0 +0330} - {3793725000 16200 1 +0330} - {3809619000 12600 0 +0330} - {3825261000 16200 1 +0330} - {3841155000 12600 0 +0330} - {3856883400 16200 1 +0330} - {3872777400 12600 0 +0330} - {3888419400 16200 1 +0330} - {3904313400 12600 0 +0330} - {3919955400 16200 1 +0330} - {3935849400 12600 0 +0330} - {3951491400 16200 1 +0330} - {3967385400 12600 0 +0330} - {3983113800 16200 1 +0330} - {3999007800 12600 0 +0330} - {4014649800 16200 1 +0330} - {4030543800 12600 0 +0330} - {4046185800 16200 1 +0330} - {4062079800 12600 0 +0330} - {4077721800 16200 1 +0330} - {4093615800 12600 0 +0330} } diff --git a/library/tzdata/Atlantic/Jan_Mayen b/library/tzdata/Atlantic/Jan_Mayen index e592187..468d819 100644 --- a/library/tzdata/Atlantic/Jan_Mayen +++ b/library/tzdata/Atlantic/Jan_Mayen @@ -1,5 +1,5 @@ # created by tools/tclZIC.tcl - do not edit -if {![info exists TZData(Europe/Oslo)]} { - LoadTimeZoneFile Europe/Oslo +if {![info exists TZData(Europe/Berlin)]} { + LoadTimeZoneFile Europe/Berlin } -set TZData(:Atlantic/Jan_Mayen) $TZData(:Europe/Oslo) +set TZData(:Atlantic/Jan_Mayen) $TZData(:Europe/Berlin) diff --git a/library/tzdata/Atlantic/Reykjavik b/library/tzdata/Atlantic/Reykjavik index 6270572..3c4a133 100644 --- a/library/tzdata/Atlantic/Reykjavik +++ b/library/tzdata/Atlantic/Reykjavik @@ -1,73 +1,5 @@ # created by tools/tclZIC.tcl - do not edit - -set TZData(:Atlantic/Reykjavik) { - {-9223372036854775808 -5280 0 LMT} - {-1956609120 -3600 0 -01} - {-1668211200 0 1 -01} - {-1647212400 -3600 0 -01} - {-1636675200 0 1 -01} - {-1613430000 -3600 0 -01} - {-1605139200 0 1 -01} - {-1581894000 -3600 0 -01} - {-1539561600 0 1 -01} - {-1531350000 -3600 0 -01} - {-968025600 0 1 -01} - {-952293600 -3600 0 -01} - {-942008400 0 1 -01} - {-920239200 -3600 0 -01} - {-909957600 0 1 -01} - {-888789600 -3600 0 -01} - {-877903200 0 1 -01} - {-857944800 -3600 0 -01} - {-846453600 0 1 -01} - {-826495200 -3600 0 -01} - {-815004000 0 1 -01} - {-795045600 -3600 0 -01} - {-783554400 0 1 -01} - {-762991200 -3600 0 -01} - {-752104800 0 1 -01} - {-731541600 -3600 0 -01} - {-717631200 0 1 -01} - {-700092000 -3600 0 -01} - {-686181600 0 1 -01} - {-668642400 -3600 0 -01} - {-654732000 0 1 -01} - {-636588000 -3600 0 -01} - {-623282400 0 1 -01} - {-605743200 -3600 0 -01} - {-591832800 0 1 -01} - {-573688800 -3600 0 -01} - {-559778400 0 1 -01} - {-542239200 -3600 0 -01} - {-528328800 0 1 -01} - {-510789600 -3600 0 -01} - {-496879200 0 1 -01} - {-479340000 -3600 0 -01} - {-465429600 0 1 -01} - {-447890400 -3600 0 -01} - {-433980000 0 1 -01} - {-415836000 -3600 0 -01} - {-401925600 0 1 -01} - {-384386400 -3600 0 -01} - {-370476000 0 1 -01} - {-352936800 -3600 0 -01} - {-339026400 0 1 -01} - {-321487200 -3600 0 -01} - {-307576800 0 1 -01} - {-290037600 -3600 0 -01} - {-276127200 0 1 -01} - {-258588000 -3600 0 -01} - {-244677600 0 1 -01} - {-226533600 -3600 0 -01} - {-212623200 0 1 -01} - {-195084000 -3600 0 -01} - {-181173600 0 1 -01} - {-163634400 -3600 0 -01} - {-149724000 0 1 -01} - {-132184800 -3600 0 -01} - {-118274400 0 1 -01} - {-100735200 -3600 0 -01} - {-86824800 0 1 -01} - {-68680800 -3600 0 -01} - {-54770400 0 0 GMT} +if {![info exists TZData(Africa/Abidjan)]} { + LoadTimeZoneFile Africa/Abidjan } +set TZData(:Atlantic/Reykjavik) $TZData(:Africa/Abidjan) diff --git a/library/tzdata/Canada/East-Saskatchewan b/library/tzdata/Canada/East-Saskatchewan deleted file mode 100644 index f7e500c..0000000 --- a/library/tzdata/Canada/East-Saskatchewan +++ /dev/null @@ -1,5 +0,0 @@ -# created by tools/tclZIC.tcl - do not edit -if {![info exists TZData(America/Regina)]} { - LoadTimeZoneFile America/Regina -} -set TZData(:Canada/East-Saskatchewan) $TZData(:America/Regina) diff --git a/library/tzdata/Europe/Amsterdam b/library/tzdata/Europe/Amsterdam index b683c99..7fbe3aa 100644 --- a/library/tzdata/Europe/Amsterdam +++ b/library/tzdata/Europe/Amsterdam @@ -1,310 +1,5 @@ # created by tools/tclZIC.tcl - do not edit - -set TZData(:Europe/Amsterdam) { - {-9223372036854775808 1172 0 LMT} - {-4260212372 1172 0 AMT} - {-1693700372 4772 1 NST} - {-1680484772 1172 0 AMT} - {-1663453172 4772 1 NST} - {-1650147572 1172 0 AMT} - {-1633213172 4772 1 NST} - {-1617488372 1172 0 AMT} - {-1601158772 4772 1 NST} - {-1586038772 1172 0 AMT} - {-1569709172 4772 1 NST} - {-1554589172 1172 0 AMT} - {-1538259572 4772 1 NST} - {-1523139572 1172 0 AMT} - {-1507501172 4772 1 NST} - {-1490566772 1172 0 AMT} - {-1470176372 4772 1 NST} - {-1459117172 1172 0 AMT} - {-1443997172 4772 1 NST} - {-1427667572 1172 0 AMT} - {-1406672372 4772 1 NST} - {-1396217972 1172 0 AMT} - {-1376950772 4772 1 NST} - {-1364768372 1172 0 AMT} - {-1345414772 4772 1 NST} - {-1333318772 1172 0 AMT} - {-1313792372 4772 1 NST} - {-1301264372 1172 0 AMT} - {-1282256372 4772 1 NST} - {-1269814772 1172 0 AMT} - {-1250720372 4772 1 NST} - {-1238365172 1172 0 AMT} - {-1219184372 4772 1 NST} - {-1206915572 1172 0 AMT} - {-1186957172 4772 1 NST} - {-1175465972 1172 0 AMT} - {-1156025972 4772 1 NST} - {-1143411572 1172 0 AMT} - {-1124489972 4772 1 NST} - {-1111961972 1172 0 AMT} - {-1092953972 4772 1 NST} - {-1080512372 1172 0 AMT} - {-1061331572 4772 1 NST} - {-1049062772 1172 0 AMT} - {-1029190772 4772 1 NST} - {-1025741972 4800 0 +0120} - {-1017613200 1200 0 +0020} - {-998259600 4800 1 +0120} - {-986163600 1200 0 +0020} - {-966723600 4800 1 +0120} - {-954109200 1200 0 +0020} - {-935022000 7200 0 CEST} - {-857257200 3600 0 CET} - {-844556400 7200 1 CEST} - {-828226800 3600 0 CET} - {-812502000 7200 1 CEST} - {-796777200 3600 0 CET} - {-781052400 7200 0 CEST} - {-766623600 3600 0 CET} - {220921200 3600 0 CET} - {228877200 7200 1 CEST} - {243997200 3600 0 CET} - {260326800 7200 1 CEST} - {276051600 3600 0 CET} - {291776400 7200 1 CEST} - {307501200 3600 0 CET} - {323830800 7200 1 CEST} - {338950800 3600 0 CET} - {354675600 7200 1 CEST} - {370400400 3600 0 CET} - {386125200 7200 1 CEST} - {401850000 3600 0 CET} - {417574800 7200 1 CEST} - {433299600 3600 0 CET} - {449024400 7200 1 CEST} - {465354000 3600 0 CET} - {481078800 7200 1 CEST} - {496803600 3600 0 CET} - {512528400 7200 1 CEST} - {528253200 3600 0 CET} - {543978000 7200 1 CEST} - {559702800 3600 0 CET} - {575427600 7200 1 CEST} - {591152400 3600 0 CET} - {606877200 7200 1 CEST} - {622602000 3600 0 CET} - {638326800 7200 1 CEST} - {654656400 3600 0 CET} - {670381200 7200 1 CEST} - {686106000 3600 0 CET} - {701830800 7200 1 CEST} - {717555600 3600 0 CET} - {733280400 7200 1 CEST} - {749005200 3600 0 CET} - {764730000 7200 1 CEST} - {780454800 3600 0 CET} - {796179600 7200 1 CEST} - {811904400 3600 0 CET} - {828234000 7200 1 CEST} - {846378000 3600 0 CET} - {859683600 7200 1 CEST} - {877827600 3600 0 CET} - {891133200 7200 1 CEST} - {909277200 3600 0 CET} - {922582800 7200 1 CEST} - {941331600 3600 0 CET} - {954032400 7200 1 CEST} - {972781200 3600 0 CET} - {985482000 7200 1 CEST} - {1004230800 3600 0 CET} - {1017536400 7200 1 CEST} - {1035680400 3600 0 CET} - {1048986000 7200 1 CEST} - {1067130000 3600 0 CET} - {1080435600 7200 1 CEST} - {1099184400 3600 0 CET} - {1111885200 7200 1 CEST} - {1130634000 3600 0 CET} - {1143334800 7200 1 CEST} - {1162083600 3600 0 CET} - {1174784400 7200 1 CEST} - {1193533200 3600 0 CET} - {1206838800 7200 1 CEST} - {1224982800 3600 0 CET} - {1238288400 7200 1 CEST} - {1256432400 3600 0 CET} - {1269738000 7200 1 CEST} - {1288486800 3600 0 CET} - {1301187600 7200 1 CEST} - {1319936400 3600 0 CET} - {1332637200 7200 1 CEST} - {1351386000 3600 0 CET} - {1364691600 7200 1 CEST} - {1382835600 3600 0 CET} - {1396141200 7200 1 CEST} - {1414285200 3600 0 CET} - {1427590800 7200 1 CEST} - {1445734800 3600 0 CET} - {1459040400 7200 1 CEST} - {1477789200 3600 0 CET} - {1490490000 7200 1 CEST} - {1509238800 3600 0 CET} - {1521939600 7200 1 CEST} - {1540688400 3600 0 CET} - {1553994000 7200 1 CEST} - {1572138000 3600 0 CET} - {1585443600 7200 1 CEST} - {1603587600 3600 0 CET} - {1616893200 7200 1 CEST} - {1635642000 3600 0 CET} - {1648342800 7200 1 CEST} - {1667091600 3600 0 CET} - {1679792400 7200 1 CEST} - {1698541200 3600 0 CET} - {1711846800 7200 1 CEST} - {1729990800 3600 0 CET} - {1743296400 7200 1 CEST} - {1761440400 3600 0 CET} - {1774746000 7200 1 CEST} - {1792890000 3600 0 CET} - {1806195600 7200 1 CEST} - {1824944400 3600 0 CET} - {1837645200 7200 1 CEST} - {1856394000 3600 0 CET} - {1869094800 7200 1 CEST} - {1887843600 3600 0 CET} - {1901149200 7200 1 CEST} - {1919293200 3600 0 CET} - {1932598800 7200 1 CEST} - {1950742800 3600 0 CET} - {1964048400 7200 1 CEST} - {1982797200 3600 0 CET} - {1995498000 7200 1 CEST} - {2014246800 3600 0 CET} - {2026947600 7200 1 CEST} - {2045696400 3600 0 CET} - {2058397200 7200 1 CEST} - {2077146000 3600 0 CET} - {2090451600 7200 1 CEST} - {2108595600 3600 0 CET} - {2121901200 7200 1 CEST} - {2140045200 3600 0 CET} - {2153350800 7200 1 CEST} - {2172099600 3600 0 CET} - {2184800400 7200 1 CEST} - {2203549200 3600 0 CET} - {2216250000 7200 1 CEST} - {2234998800 3600 0 CET} - {2248304400 7200 1 CEST} - {2266448400 3600 0 CET} - {2279754000 7200 1 CEST} - {2297898000 3600 0 CET} - {2311203600 7200 1 CEST} - {2329347600 3600 0 CET} - {2342653200 7200 1 CEST} - {2361402000 3600 0 CET} - {2374102800 7200 1 CEST} - {2392851600 3600 0 CET} - {2405552400 7200 1 CEST} - {2424301200 3600 0 CET} - {2437606800 7200 1 CEST} - {2455750800 3600 0 CET} - {2469056400 7200 1 CEST} - {2487200400 3600 0 CET} - {2500506000 7200 1 CEST} - {2519254800 3600 0 CET} - {2531955600 7200 1 CEST} - {2550704400 3600 0 CET} - {2563405200 7200 1 CEST} - {2582154000 3600 0 CET} - {2595459600 7200 1 CEST} - {2613603600 3600 0 CET} - {2626909200 7200 1 CEST} - {2645053200 3600 0 CET} - {2658358800 7200 1 CEST} - {2676502800 3600 0 CET} - {2689808400 7200 1 CEST} - {2708557200 3600 0 CET} - {2721258000 7200 1 CEST} - {2740006800 3600 0 CET} - {2752707600 7200 1 CEST} - {2771456400 3600 0 CET} - {2784762000 7200 1 CEST} - {2802906000 3600 0 CET} - {2816211600 7200 1 CEST} - {2834355600 3600 0 CET} - {2847661200 7200 1 CEST} - {2866410000 3600 0 CET} - {2879110800 7200 1 CEST} - {2897859600 3600 0 CET} - {2910560400 7200 1 CEST} - {2929309200 3600 0 CET} - {2942010000 7200 1 CEST} - {2960758800 3600 0 CET} - {2974064400 7200 1 CEST} - {2992208400 3600 0 CET} - {3005514000 7200 1 CEST} - {3023658000 3600 0 CET} - {3036963600 7200 1 CEST} - {3055712400 3600 0 CET} - {3068413200 7200 1 CEST} - {3087162000 3600 0 CET} - {3099862800 7200 1 CEST} - {3118611600 3600 0 CET} - {3131917200 7200 1 CEST} - {3150061200 3600 0 CET} - {3163366800 7200 1 CEST} - {3181510800 3600 0 CET} - {3194816400 7200 1 CEST} - {3212960400 3600 0 CET} - {3226266000 7200 1 CEST} - {3245014800 3600 0 CET} - {3257715600 7200 1 CEST} - {3276464400 3600 0 CET} - {3289165200 7200 1 CEST} - {3307914000 3600 0 CET} - {3321219600 7200 1 CEST} - {3339363600 3600 0 CET} - {3352669200 7200 1 CEST} - {3370813200 3600 0 CET} - {3384118800 7200 1 CEST} - {3402867600 3600 0 CET} - {3415568400 7200 1 CEST} - {3434317200 3600 0 CET} - {3447018000 7200 1 CEST} - {3465766800 3600 0 CET} - {3479072400 7200 1 CEST} - {3497216400 3600 0 CET} - {3510522000 7200 1 CEST} - {3528666000 3600 0 CET} - {3541971600 7200 1 CEST} - {3560115600 3600 0 CET} - {3573421200 7200 1 CEST} - {3592170000 3600 0 CET} - {3604870800 7200 1 CEST} - {3623619600 3600 0 CET} - {3636320400 7200 1 CEST} - {3655069200 3600 0 CET} - {3668374800 7200 1 CEST} - {3686518800 3600 0 CET} - {3699824400 7200 1 CEST} - {3717968400 3600 0 CET} - {3731274000 7200 1 CEST} - {3750022800 3600 0 CET} - {3762723600 7200 1 CEST} - {3781472400 3600 0 CET} - {3794173200 7200 1 CEST} - {3812922000 3600 0 CET} - {3825622800 7200 1 CEST} - {3844371600 3600 0 CET} - {3857677200 7200 1 CEST} - {3875821200 3600 0 CET} - {3889126800 7200 1 CEST} - {3907270800 3600 0 CET} - {3920576400 7200 1 CEST} - {3939325200 3600 0 CET} - {3952026000 7200 1 CEST} - {3970774800 3600 0 CET} - {3983475600 7200 1 CEST} - {4002224400 3600 0 CET} - {4015530000 7200 1 CEST} - {4033674000 3600 0 CET} - {4046979600 7200 1 CEST} - {4065123600 3600 0 CET} - {4078429200 7200 1 CEST} - {4096573200 3600 0 CET} +if {![info exists TZData(Europe/Brussels)]} { + LoadTimeZoneFile Europe/Brussels } +set TZData(:Europe/Amsterdam) $TZData(:Europe/Brussels) diff --git a/library/tzdata/Europe/Copenhagen b/library/tzdata/Europe/Copenhagen index c747e58..1b144d1 100644 --- a/library/tzdata/Europe/Copenhagen +++ b/library/tzdata/Europe/Copenhagen @@ -1,264 +1,5 @@ # created by tools/tclZIC.tcl - do not edit - -set TZData(:Europe/Copenhagen) { - {-9223372036854775808 3020 0 LMT} - {-2524524620 3020 0 CMT} - {-2398294220 3600 0 CET} - {-1692496800 7200 1 CEST} - {-1680490800 3600 0 CET} - {-935110800 7200 1 CEST} - {-857257200 3600 0 CET} - {-844556400 7200 1 CEST} - {-828226800 3600 0 CET} - {-812502000 7200 1 CEST} - {-796777200 3600 0 CET} - {-781052400 7200 0 CEST} - {-769388400 3600 0 CET} - {-747010800 7200 1 CEST} - {-736383600 3600 0 CET} - {-715215600 7200 1 CEST} - {-706748400 3600 0 CET} - {-683161200 7200 1 CEST} - {-675298800 3600 0 CET} - {315529200 3600 0 CET} - {323830800 7200 1 CEST} - {338950800 3600 0 CET} - {354675600 7200 1 CEST} - {370400400 3600 0 CET} - {386125200 7200 1 CEST} - {401850000 3600 0 CET} - {417574800 7200 1 CEST} - {433299600 3600 0 CET} - {449024400 7200 1 CEST} - {465354000 3600 0 CET} - {481078800 7200 1 CEST} - {496803600 3600 0 CET} - {512528400 7200 1 CEST} - {528253200 3600 0 CET} - {543978000 7200 1 CEST} - {559702800 3600 0 CET} - {575427600 7200 1 CEST} - {591152400 3600 0 CET} - {606877200 7200 1 CEST} - {622602000 3600 0 CET} - {638326800 7200 1 CEST} - {654656400 3600 0 CET} - {670381200 7200 1 CEST} - {686106000 3600 0 CET} - {701830800 7200 1 CEST} - {717555600 3600 0 CET} - {733280400 7200 1 CEST} - {749005200 3600 0 CET} - {764730000 7200 1 CEST} - {780454800 3600 0 CET} - {796179600 7200 1 CEST} - {811904400 3600 0 CET} - {828234000 7200 1 CEST} - {846378000 3600 0 CET} - {859683600 7200 1 CEST} - {877827600 3600 0 CET} - {891133200 7200 1 CEST} - {909277200 3600 0 CET} - {922582800 7200 1 CEST} - {941331600 3600 0 CET} - {954032400 7200 1 CEST} - {972781200 3600 0 CET} - {985482000 7200 1 CEST} - {1004230800 3600 0 CET} - {1017536400 7200 1 CEST} - {1035680400 3600 0 CET} - {1048986000 7200 1 CEST} - {1067130000 3600 0 CET} - {1080435600 7200 1 CEST} - {1099184400 3600 0 CET} - {1111885200 7200 1 CEST} - {1130634000 3600 0 CET} - {1143334800 7200 1 CEST} - {1162083600 3600 0 CET} - {1174784400 7200 1 CEST} - {1193533200 3600 0 CET} - {1206838800 7200 1 CEST} - {1224982800 3600 0 CET} - {1238288400 7200 1 CEST} - {1256432400 3600 0 CET} - {1269738000 7200 1 CEST} - {1288486800 3600 0 CET} - {1301187600 7200 1 CEST} - {1319936400 3600 0 CET} - {1332637200 7200 1 CEST} - {1351386000 3600 0 CET} - {1364691600 7200 1 CEST} - {1382835600 3600 0 CET} - {1396141200 7200 1 CEST} - {1414285200 3600 0 CET} - {1427590800 7200 1 CEST} - {1445734800 3600 0 CET} - {1459040400 7200 1 CEST} - {1477789200 3600 0 CET} - {1490490000 7200 1 CEST} - {1509238800 3600 0 CET} - {1521939600 7200 1 CEST} - {1540688400 3600 0 CET} - {1553994000 7200 1 CEST} - {1572138000 3600 0 CET} - {1585443600 7200 1 CEST} - {1603587600 3600 0 CET} - {1616893200 7200 1 CEST} - {1635642000 3600 0 CET} - {1648342800 7200 1 CEST} - {1667091600 3600 0 CET} - {1679792400 7200 1 CEST} - {1698541200 3600 0 CET} - {1711846800 7200 1 CEST} - {1729990800 3600 0 CET} - {1743296400 7200 1 CEST} - {1761440400 3600 0 CET} - {1774746000 7200 1 CEST} - {1792890000 3600 0 CET} - {1806195600 7200 1 CEST} - {1824944400 3600 0 CET} - {1837645200 7200 1 CEST} - {1856394000 3600 0 CET} - {1869094800 7200 1 CEST} - {1887843600 3600 0 CET} - {1901149200 7200 1 CEST} - {1919293200 3600 0 CET} - {1932598800 7200 1 CEST} - {1950742800 3600 0 CET} - {1964048400 7200 1 CEST} - {1982797200 3600 0 CET} - {1995498000 7200 1 CEST} - {2014246800 3600 0 CET} - {2026947600 7200 1 CEST} - {2045696400 3600 0 CET} - {2058397200 7200 1 CEST} - {2077146000 3600 0 CET} - {2090451600 7200 1 CEST} - {2108595600 3600 0 CET} - {2121901200 7200 1 CEST} - {2140045200 3600 0 CET} - {2153350800 7200 1 CEST} - {2172099600 3600 0 CET} - {2184800400 7200 1 CEST} - {2203549200 3600 0 CET} - {2216250000 7200 1 CEST} - {2234998800 3600 0 CET} - {2248304400 7200 1 CEST} - {2266448400 3600 0 CET} - {2279754000 7200 1 CEST} - {2297898000 3600 0 CET} - {2311203600 7200 1 CEST} - {2329347600 3600 0 CET} - {2342653200 7200 1 CEST} - {2361402000 3600 0 CET} - {2374102800 7200 1 CEST} - {2392851600 3600 0 CET} - {2405552400 7200 1 CEST} - {2424301200 3600 0 CET} - {2437606800 7200 1 CEST} - {2455750800 3600 0 CET} - {2469056400 7200 1 CEST} - {2487200400 3600 0 CET} - {2500506000 7200 1 CEST} - {2519254800 3600 0 CET} - {2531955600 7200 1 CEST} - {2550704400 3600 0 CET} - {2563405200 7200 1 CEST} - {2582154000 3600 0 CET} - {2595459600 7200 1 CEST} - {2613603600 3600 0 CET} - {2626909200 7200 1 CEST} - {2645053200 3600 0 CET} - {2658358800 7200 1 CEST} - {2676502800 3600 0 CET} - {2689808400 7200 1 CEST} - {2708557200 3600 0 CET} - {2721258000 7200 1 CEST} - {2740006800 3600 0 CET} - {2752707600 7200 1 CEST} - {2771456400 3600 0 CET} - {2784762000 7200 1 CEST} - {2802906000 3600 0 CET} - {2816211600 7200 1 CEST} - {2834355600 3600 0 CET} - {2847661200 7200 1 CEST} - {2866410000 3600 0 CET} - {2879110800 7200 1 CEST} - {2897859600 3600 0 CET} - {2910560400 7200 1 CEST} - {2929309200 3600 0 CET} - {2942010000 7200 1 CEST} - {2960758800 3600 0 CET} - {2974064400 7200 1 CEST} - {2992208400 3600 0 CET} - {3005514000 7200 1 CEST} - {3023658000 3600 0 CET} - {3036963600 7200 1 CEST} - {3055712400 3600 0 CET} - {3068413200 7200 1 CEST} - {3087162000 3600 0 CET} - {3099862800 7200 1 CEST} - {3118611600 3600 0 CET} - {3131917200 7200 1 CEST} - {3150061200 3600 0 CET} - {3163366800 7200 1 CEST} - {3181510800 3600 0 CET} - {3194816400 7200 1 CEST} - {3212960400 3600 0 CET} - {3226266000 7200 1 CEST} - {3245014800 3600 0 CET} - {3257715600 7200 1 CEST} - {3276464400 3600 0 CET} - {3289165200 7200 1 CEST} - {3307914000 3600 0 CET} - {3321219600 7200 1 CEST} - {3339363600 3600 0 CET} - {3352669200 7200 1 CEST} - {3370813200 3600 0 CET} - {3384118800 7200 1 CEST} - {3402867600 3600 0 CET} - {3415568400 7200 1 CEST} - {3434317200 3600 0 CET} - {3447018000 7200 1 CEST} - {3465766800 3600 0 CET} - {3479072400 7200 1 CEST} - {3497216400 3600 0 CET} - {3510522000 7200 1 CEST} - {3528666000 3600 0 CET} - {3541971600 7200 1 CEST} - {3560115600 3600 0 CET} - {3573421200 7200 1 CEST} - {3592170000 3600 0 CET} - {3604870800 7200 1 CEST} - {3623619600 3600 0 CET} - {3636320400 7200 1 CEST} - {3655069200 3600 0 CET} - {3668374800 7200 1 CEST} - {3686518800 3600 0 CET} - {3699824400 7200 1 CEST} - {3717968400 3600 0 CET} - {3731274000 7200 1 CEST} - {3750022800 3600 0 CET} - {3762723600 7200 1 CEST} - {3781472400 3600 0 CET} - {3794173200 7200 1 CEST} - {3812922000 3600 0 CET} - {3825622800 7200 1 CEST} - {3844371600 3600 0 CET} - {3857677200 7200 1 CEST} - {3875821200 3600 0 CET} - {3889126800 7200 1 CEST} - {3907270800 3600 0 CET} - {3920576400 7200 1 CEST} - {3939325200 3600 0 CET} - {3952026000 7200 1 CEST} - {3970774800 3600 0 CET} - {3983475600 7200 1 CEST} - {4002224400 3600 0 CET} - {4015530000 7200 1 CEST} - {4033674000 3600 0 CET} - {4046979600 7200 1 CEST} - {4065123600 3600 0 CET} - {4078429200 7200 1 CEST} - {4096573200 3600 0 CET} +if {![info exists TZData(Europe/Berlin)]} { + LoadTimeZoneFile Europe/Berlin } +set TZData(:Europe/Copenhagen) $TZData(:Europe/Berlin) diff --git a/library/tzdata/Europe/Dublin b/library/tzdata/Europe/Dublin index 56afc93..eb0d182 100644 --- a/library/tzdata/Europe/Dublin +++ b/library/tzdata/Europe/Dublin @@ -1,8 +1,8 @@ # created by tools/tclZIC.tcl - do not edit set TZData(:Europe/Dublin) { - {-9223372036854775808 -1500 0 LMT} - {-2821649700 -1521 0 DMT} + {-9223372036854775808 -1521 0 LMT} + {-2821649679 -1521 0 DMT} {-1691962479 2079 1 IST} {-1680471279 0 0 GMT} {-1664143200 3600 1 BST} diff --git a/library/tzdata/Europe/Kiev b/library/tzdata/Europe/Kiev index 8da7061..ac5e50a 100644 --- a/library/tzdata/Europe/Kiev +++ b/library/tzdata/Europe/Kiev @@ -1,251 +1,5 @@ # created by tools/tclZIC.tcl - do not edit - -set TZData(:Europe/Kiev) { - {-9223372036854775808 7324 0 LMT} - {-2840148124 7324 0 KMT} - {-1441159324 7200 0 EET} - {-1247536800 10800 0 MSK} - {-892522800 3600 0 CET} - {-857257200 3600 0 CET} - {-844556400 7200 1 CEST} - {-828226800 3600 0 CET} - {-825382800 10800 0 MSD} - {354920400 14400 1 MSD} - {370728000 10800 0 MSK} - {386456400 14400 1 MSD} - {402264000 10800 0 MSK} - {417992400 14400 1 MSD} - {433800000 10800 0 MSK} - {449614800 14400 1 MSD} - {465346800 10800 0 MSK} - {481071600 14400 1 MSD} - {496796400 10800 0 MSK} - {512521200 14400 1 MSD} - {528246000 10800 0 MSK} - {543970800 14400 1 MSD} - {559695600 10800 0 MSK} - {575420400 14400 1 MSD} - {591145200 10800 0 MSK} - {606870000 14400 1 MSD} - {622594800 10800 0 MSK} - {638319600 14400 1 MSD} - {646786800 10800 1 EEST} - {686102400 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} - {891133200 10800 1 EEST} - {909277200 7200 0 EET} - {922582800 10800 1 EEST} - {941331600 7200 0 EET} - {954032400 10800 1 EEST} - {972781200 7200 0 EET} - {985482000 10800 1 EEST} - {1004230800 7200 0 EET} - {1017536400 10800 1 EEST} - {1035680400 7200 0 EET} - {1048986000 10800 1 EEST} - {1067130000 7200 0 EET} - {1080435600 10800 1 EEST} - {1099184400 7200 0 EET} - {1111885200 10800 1 EEST} - {1130634000 7200 0 EET} - {1143334800 10800 1 EEST} - {1162083600 7200 0 EET} - {1174784400 10800 1 EEST} - {1193533200 7200 0 EET} - {1206838800 10800 1 EEST} - {1224982800 7200 0 EET} - {1238288400 10800 1 EEST} - {1256432400 7200 0 EET} - {1269738000 10800 1 EEST} - {1288486800 7200 0 EET} - {1301187600 10800 1 EEST} - {1319936400 7200 0 EET} - {1332637200 10800 1 EEST} - {1351386000 7200 0 EET} - {1364691600 10800 1 EEST} - {1382835600 7200 0 EET} - {1396141200 10800 1 EEST} - {1414285200 7200 0 EET} - {1427590800 10800 1 EEST} - {1445734800 7200 0 EET} - {1459040400 10800 1 EEST} - {1477789200 7200 0 EET} - {1490490000 10800 1 EEST} - {1509238800 7200 0 EET} - {1521939600 10800 1 EEST} - {1540688400 7200 0 EET} - {1553994000 10800 1 EEST} - {1572138000 7200 0 EET} - {1585443600 10800 1 EEST} - {1603587600 7200 0 EET} - {1616893200 10800 1 EEST} - {1635642000 7200 0 EET} - {1648342800 10800 1 EEST} - {1667091600 7200 0 EET} - {1679792400 10800 1 EEST} - {1698541200 7200 0 EET} - {1711846800 10800 1 EEST} - {1729990800 7200 0 EET} - {1743296400 10800 1 EEST} - {1761440400 7200 0 EET} - {1774746000 10800 1 EEST} - {1792890000 7200 0 EET} - {1806195600 10800 1 EEST} - {1824944400 7200 0 EET} - {1837645200 10800 1 EEST} - {1856394000 7200 0 EET} - {1869094800 10800 1 EEST} - {1887843600 7200 0 EET} - {1901149200 10800 1 EEST} - {1919293200 7200 0 EET} - {1932598800 10800 1 EEST} - {1950742800 7200 0 EET} - {1964048400 10800 1 EEST} - {1982797200 7200 0 EET} - {1995498000 10800 1 EEST} - {2014246800 7200 0 EET} - {2026947600 10800 1 EEST} - {2045696400 7200 0 EET} - {2058397200 10800 1 EEST} - {2077146000 7200 0 EET} - {2090451600 10800 1 EEST} - {2108595600 7200 0 EET} - {2121901200 10800 1 EEST} - {2140045200 7200 0 EET} - {2153350800 10800 1 EEST} - {2172099600 7200 0 EET} - {2184800400 10800 1 EEST} - {2203549200 7200 0 EET} - {2216250000 10800 1 EEST} - {2234998800 7200 0 EET} - {2248304400 10800 1 EEST} - {2266448400 7200 0 EET} - {2279754000 10800 1 EEST} - {2297898000 7200 0 EET} - {2311203600 10800 1 EEST} - {2329347600 7200 0 EET} - {2342653200 10800 1 EEST} - {2361402000 7200 0 EET} - {2374102800 10800 1 EEST} - {2392851600 7200 0 EET} - {2405552400 10800 1 EEST} - {2424301200 7200 0 EET} - {2437606800 10800 1 EEST} - {2455750800 7200 0 EET} - {2469056400 10800 1 EEST} - {2487200400 7200 0 EET} - {2500506000 10800 1 EEST} - {2519254800 7200 0 EET} - {2531955600 10800 1 EEST} - {2550704400 7200 0 EET} - {2563405200 10800 1 EEST} - {2582154000 7200 0 EET} - {2595459600 10800 1 EEST} - {2613603600 7200 0 EET} - {2626909200 10800 1 EEST} - {2645053200 7200 0 EET} - {2658358800 10800 1 EEST} - {2676502800 7200 0 EET} - {2689808400 10800 1 EEST} - {2708557200 7200 0 EET} - {2721258000 10800 1 EEST} - {2740006800 7200 0 EET} - {2752707600 10800 1 EEST} - {2771456400 7200 0 EET} - {2784762000 10800 1 EEST} - {2802906000 7200 0 EET} - {2816211600 10800 1 EEST} - {2834355600 7200 0 EET} - {2847661200 10800 1 EEST} - {2866410000 7200 0 EET} - {2879110800 10800 1 EEST} - {2897859600 7200 0 EET} - {2910560400 10800 1 EEST} - {2929309200 7200 0 EET} - {2942010000 10800 1 EEST} - {2960758800 7200 0 EET} - {2974064400 10800 1 EEST} - {2992208400 7200 0 EET} - {3005514000 10800 1 EEST} - {3023658000 7200 0 EET} - {3036963600 10800 1 EEST} - {3055712400 7200 0 EET} - {3068413200 10800 1 EEST} - {3087162000 7200 0 EET} - {3099862800 10800 1 EEST} - {3118611600 7200 0 EET} - {3131917200 10800 1 EEST} - {3150061200 7200 0 EET} - {3163366800 10800 1 EEST} - {3181510800 7200 0 EET} - {3194816400 10800 1 EEST} - {3212960400 7200 0 EET} - {3226266000 10800 1 EEST} - {3245014800 7200 0 EET} - {3257715600 10800 1 EEST} - {3276464400 7200 0 EET} - {3289165200 10800 1 EEST} - {3307914000 7200 0 EET} - {3321219600 10800 1 EEST} - {3339363600 7200 0 EET} - {3352669200 10800 1 EEST} - {3370813200 7200 0 EET} - {3384118800 10800 1 EEST} - {3402867600 7200 0 EET} - {3415568400 10800 1 EEST} - {3434317200 7200 0 EET} - {3447018000 10800 1 EEST} - {3465766800 7200 0 EET} - {3479072400 10800 1 EEST} - {3497216400 7200 0 EET} - {3510522000 10800 1 EEST} - {3528666000 7200 0 EET} - {3541971600 10800 1 EEST} - {3560115600 7200 0 EET} - {3573421200 10800 1 EEST} - {3592170000 7200 0 EET} - {3604870800 10800 1 EEST} - {3623619600 7200 0 EET} - {3636320400 10800 1 EEST} - {3655069200 7200 0 EET} - {3668374800 10800 1 EEST} - {3686518800 7200 0 EET} - {3699824400 10800 1 EEST} - {3717968400 7200 0 EET} - {3731274000 10800 1 EEST} - {3750022800 7200 0 EET} - {3762723600 10800 1 EEST} - {3781472400 7200 0 EET} - {3794173200 10800 1 EEST} - {3812922000 7200 0 EET} - {3825622800 10800 1 EEST} - {3844371600 7200 0 EET} - {3857677200 10800 1 EEST} - {3875821200 7200 0 EET} - {3889126800 10800 1 EEST} - {3907270800 7200 0 EET} - {3920576400 10800 1 EEST} - {3939325200 7200 0 EET} - {3952026000 10800 1 EEST} - {3970774800 7200 0 EET} - {3983475600 10800 1 EEST} - {4002224400 7200 0 EET} - {4015530000 10800 1 EEST} - {4033674000 7200 0 EET} - {4046979600 10800 1 EEST} - {4065123600 7200 0 EET} - {4078429200 10800 1 EEST} - {4096573200 7200 0 EET} +if {![info exists TZData(Europe/Kyiv)]} { + LoadTimeZoneFile Europe/Kyiv } +set TZData(:Europe/Kiev) $TZData(:Europe/Kyiv) diff --git a/library/tzdata/Europe/Luxembourg b/library/tzdata/Europe/Luxembourg index 2a88c4b..da3ebe2 100644 --- a/library/tzdata/Europe/Luxembourg +++ b/library/tzdata/Europe/Luxembourg @@ -1,313 +1,5 @@ # created by tools/tclZIC.tcl - do not edit - -set TZData(:Europe/Luxembourg) { - {-9223372036854775808 1476 0 LMT} - {-2069713476 3600 0 CET} - {-1692496800 7200 1 CEST} - {-1680483600 3600 0 CET} - {-1662343200 7200 1 CEST} - {-1650157200 3600 0 CET} - {-1632006000 7200 1 CEST} - {-1618700400 3600 0 CET} - {-1612659600 0 0 WET} - {-1604278800 3600 1 WEST} - {-1585519200 0 0 WET} - {-1574038800 3600 1 WEST} - {-1552258800 0 0 WET} - {-1539997200 3600 1 WEST} - {-1520550000 0 0 WET} - {-1507510800 3600 1 WEST} - {-1490572800 0 0 WET} - {-1473642000 3600 1 WEST} - {-1459119600 0 0 WET} - {-1444006800 3600 1 WEST} - {-1427673600 0 0 WET} - {-1411866000 3600 1 WEST} - {-1396224000 0 0 WET} - {-1379293200 3600 1 WEST} - {-1364774400 0 0 WET} - {-1348448400 3600 1 WEST} - {-1333324800 0 0 WET} - {-1316394000 3600 1 WEST} - {-1301270400 0 0 WET} - {-1284339600 3600 1 WEST} - {-1269813600 0 0 WET} - {-1253484000 3600 1 WEST} - {-1238364000 0 0 WET} - {-1221429600 3600 1 WEST} - {-1206914400 0 0 WET} - {-1191189600 3600 1 WEST} - {-1175464800 0 0 WET} - {-1160344800 3600 1 WEST} - {-1143410400 0 0 WET} - {-1127685600 3600 1 WEST} - {-1111960800 0 0 WET} - {-1096840800 3600 1 WEST} - {-1080511200 0 0 WET} - {-1063576800 3600 1 WEST} - {-1049061600 0 0 WET} - {-1033336800 3600 1 WEST} - {-1017612000 0 0 WET} - {-1002492000 3600 1 WEST} - {-986162400 0 0 WET} - {-969228000 3600 1 WEST} - {-950479200 0 0 WET} - {-942012000 3600 1 WEST} - {-935186400 7200 0 WEST} - {-857257200 3600 0 WET} - {-844556400 7200 1 WEST} - {-828226800 3600 0 WET} - {-812502000 7200 1 WEST} - {-797983200 3600 0 CET} - {-781052400 7200 1 CEST} - {-766623600 3600 0 CET} - {-745455600 7200 1 CEST} - {-733273200 3600 0 CET} - {220921200 3600 0 CET} - {228877200 7200 1 CEST} - {243997200 3600 0 CET} - {260326800 7200 1 CEST} - {276051600 3600 0 CET} - {291776400 7200 1 CEST} - {307501200 3600 0 CET} - {323830800 7200 1 CEST} - {338950800 3600 0 CET} - {354675600 7200 1 CEST} - {370400400 3600 0 CET} - {386125200 7200 1 CEST} - {401850000 3600 0 CET} - {417574800 7200 1 CEST} - {433299600 3600 0 CET} - {449024400 7200 1 CEST} - {465354000 3600 0 CET} - {481078800 7200 1 CEST} - {496803600 3600 0 CET} - {512528400 7200 1 CEST} - {528253200 3600 0 CET} - {543978000 7200 1 CEST} - {559702800 3600 0 CET} - {575427600 7200 1 CEST} - {591152400 3600 0 CET} - {606877200 7200 1 CEST} - {622602000 3600 0 CET} - {638326800 7200 1 CEST} - {654656400 3600 0 CET} - {670381200 7200 1 CEST} - {686106000 3600 0 CET} - {701830800 7200 1 CEST} - {717555600 3600 0 CET} - {733280400 7200 1 CEST} - {749005200 3600 0 CET} - {764730000 7200 1 CEST} - {780454800 3600 0 CET} - {796179600 7200 1 CEST} - {811904400 3600 0 CET} - {828234000 7200 1 CEST} - {846378000 3600 0 CET} - {859683600 7200 1 CEST} - {877827600 3600 0 CET} - {891133200 7200 1 CEST} - {909277200 3600 0 CET} - {922582800 7200 1 CEST} - {941331600 3600 0 CET} - {954032400 7200 1 CEST} - {972781200 3600 0 CET} - {985482000 7200 1 CEST} - {1004230800 3600 0 CET} - {1017536400 7200 1 CEST} - {1035680400 3600 0 CET} - {1048986000 7200 1 CEST} - {1067130000 3600 0 CET} - {1080435600 7200 1 CEST} - {1099184400 3600 0 CET} - {1111885200 7200 1 CEST} - {1130634000 3600 0 CET} - {1143334800 7200 1 CEST} - {1162083600 3600 0 CET} - {1174784400 7200 1 CEST} - {1193533200 3600 0 CET} - {1206838800 7200 1 CEST} - {1224982800 3600 0 CET} - {1238288400 7200 1 CEST} - {1256432400 3600 0 CET} - {1269738000 7200 1 CEST} - {1288486800 3600 0 CET} - {1301187600 7200 1 CEST} - {1319936400 3600 0 CET} - {1332637200 7200 1 CEST} - {1351386000 3600 0 CET} - {1364691600 7200 1 CEST} - {1382835600 3600 0 CET} - {1396141200 7200 1 CEST} - {1414285200 3600 0 CET} - {1427590800 7200 1 CEST} - {1445734800 3600 0 CET} - {1459040400 7200 1 CEST} - {1477789200 3600 0 CET} - {1490490000 7200 1 CEST} - {1509238800 3600 0 CET} - {1521939600 7200 1 CEST} - {1540688400 3600 0 CET} - {1553994000 7200 1 CEST} - {1572138000 3600 0 CET} - {1585443600 7200 1 CEST} - {1603587600 3600 0 CET} - {1616893200 7200 1 CEST} - {1635642000 3600 0 CET} - {1648342800 7200 1 CEST} - {1667091600 3600 0 CET} - {1679792400 7200 1 CEST} - {1698541200 3600 0 CET} - {1711846800 7200 1 CEST} - {1729990800 3600 0 CET} - {1743296400 7200 1 CEST} - {1761440400 3600 0 CET} - {1774746000 7200 1 CEST} - {1792890000 3600 0 CET} - {1806195600 7200 1 CEST} - {1824944400 3600 0 CET} - {1837645200 7200 1 CEST} - {1856394000 3600 0 CET} - {1869094800 7200 1 CEST} - {1887843600 3600 0 CET} - {1901149200 7200 1 CEST} - {1919293200 3600 0 CET} - {1932598800 7200 1 CEST} - {1950742800 3600 0 CET} - {1964048400 7200 1 CEST} - {1982797200 3600 0 CET} - {1995498000 7200 1 CEST} - {2014246800 3600 0 CET} - {2026947600 7200 1 CEST} - {2045696400 3600 0 CET} - {2058397200 7200 1 CEST} - {2077146000 3600 0 CET} - {2090451600 7200 1 CEST} - {2108595600 3600 0 CET} - {2121901200 7200 1 CEST} - {2140045200 3600 0 CET} - {2153350800 7200 1 CEST} - {2172099600 3600 0 CET} - {2184800400 7200 1 CEST} - {2203549200 3600 0 CET} - {2216250000 7200 1 CEST} - {2234998800 3600 0 CET} - {2248304400 7200 1 CEST} - {2266448400 3600 0 CET} - {2279754000 7200 1 CEST} - {2297898000 3600 0 CET} - {2311203600 7200 1 CEST} - {2329347600 3600 0 CET} - {2342653200 7200 1 CEST} - {2361402000 3600 0 CET} - {2374102800 7200 1 CEST} - {2392851600 3600 0 CET} - {2405552400 7200 1 CEST} - {2424301200 3600 0 CET} - {2437606800 7200 1 CEST} - {2455750800 3600 0 CET} - {2469056400 7200 1 CEST} - {2487200400 3600 0 CET} - {2500506000 7200 1 CEST} - {2519254800 3600 0 CET} - {2531955600 7200 1 CEST} - {2550704400 3600 0 CET} - {2563405200 7200 1 CEST} - {2582154000 3600 0 CET} - {2595459600 7200 1 CEST} - {2613603600 3600 0 CET} - {2626909200 7200 1 CEST} - {2645053200 3600 0 CET} - {2658358800 7200 1 CEST} - {2676502800 3600 0 CET} - {2689808400 7200 1 CEST} - {2708557200 3600 0 CET} - {2721258000 7200 1 CEST} - {2740006800 3600 0 CET} - {2752707600 7200 1 CEST} - {2771456400 3600 0 CET} - {2784762000 7200 1 CEST} - {2802906000 3600 0 CET} - {2816211600 7200 1 CEST} - {2834355600 3600 0 CET} - {2847661200 7200 1 CEST} - {2866410000 3600 0 CET} - {2879110800 7200 1 CEST} - {2897859600 3600 0 CET} - {2910560400 7200 1 CEST} - {2929309200 3600 0 CET} - {2942010000 7200 1 CEST} - {2960758800 3600 0 CET} - {2974064400 7200 1 CEST} - {2992208400 3600 0 CET} - {3005514000 7200 1 CEST} - {3023658000 3600 0 CET} - {3036963600 7200 1 CEST} - {3055712400 3600 0 CET} - {3068413200 7200 1 CEST} - {3087162000 3600 0 CET} - {3099862800 7200 1 CEST} - {3118611600 3600 0 CET} - {3131917200 7200 1 CEST} - {3150061200 3600 0 CET} - {3163366800 7200 1 CEST} - {3181510800 3600 0 CET} - {3194816400 7200 1 CEST} - {3212960400 3600 0 CET} - {3226266000 7200 1 CEST} - {3245014800 3600 0 CET} - {3257715600 7200 1 CEST} - {3276464400 3600 0 CET} - {3289165200 7200 1 CEST} - {3307914000 3600 0 CET} - {3321219600 7200 1 CEST} - {3339363600 3600 0 CET} - {3352669200 7200 1 CEST} - {3370813200 3600 0 CET} - {3384118800 7200 1 CEST} - {3402867600 3600 0 CET} - {3415568400 7200 1 CEST} - {3434317200 3600 0 CET} - {3447018000 7200 1 CEST} - {3465766800 3600 0 CET} - {3479072400 7200 1 CEST} - {3497216400 3600 0 CET} - {3510522000 7200 1 CEST} - {3528666000 3600 0 CET} - {3541971600 7200 1 CEST} - {3560115600 3600 0 CET} - {3573421200 7200 1 CEST} - {3592170000 3600 0 CET} - {3604870800 7200 1 CEST} - {3623619600 3600 0 CET} - {3636320400 7200 1 CEST} - {3655069200 3600 0 CET} - {3668374800 7200 1 CEST} - {3686518800 3600 0 CET} - {3699824400 7200 1 CEST} - {3717968400 3600 0 CET} - {3731274000 7200 1 CEST} - {3750022800 3600 0 CET} - {3762723600 7200 1 CEST} - {3781472400 3600 0 CET} - {3794173200 7200 1 CEST} - {3812922000 3600 0 CET} - {3825622800 7200 1 CEST} - {3844371600 3600 0 CET} - {3857677200 7200 1 CEST} - {3875821200 3600 0 CET} - {3889126800 7200 1 CEST} - {3907270800 3600 0 CET} - {3920576400 7200 1 CEST} - {3939325200 3600 0 CET} - {3952026000 7200 1 CEST} - {3970774800 3600 0 CET} - {3983475600 7200 1 CEST} - {4002224400 3600 0 CET} - {4015530000 7200 1 CEST} - {4033674000 3600 0 CET} - {4046979600 7200 1 CEST} - {4065123600 3600 0 CET} - {4078429200 7200 1 CEST} - {4096573200 3600 0 CET} +if {![info exists TZData(Europe/Brussels)]} { + LoadTimeZoneFile Europe/Brussels } +set TZData(:Europe/Luxembourg) $TZData(:Europe/Brussels) diff --git a/library/tzdata/Europe/Monaco b/library/tzdata/Europe/Monaco index 7428b2f..54f9d27 100644 --- a/library/tzdata/Europe/Monaco +++ b/library/tzdata/Europe/Monaco @@ -1,315 +1,5 @@ # created by tools/tclZIC.tcl - do not edit - -set TZData(:Europe/Monaco) { - {-9223372036854775808 1772 0 LMT} - {-2448318572 561 0 PMT} - {-1854403761 0 0 WET} - {-1689814800 3600 1 WEST} - {-1680397200 0 0 WET} - {-1665363600 3600 1 WEST} - {-1648342800 0 0 WET} - {-1635123600 3600 1 WEST} - {-1616893200 0 0 WET} - {-1604278800 3600 1 WEST} - {-1585443600 0 0 WET} - {-1574038800 3600 1 WEST} - {-1552266000 0 0 WET} - {-1539997200 3600 1 WEST} - {-1520557200 0 0 WET} - {-1507510800 3600 1 WEST} - {-1490576400 0 0 WET} - {-1470618000 3600 1 WEST} - {-1459126800 0 0 WET} - {-1444006800 3600 1 WEST} - {-1427677200 0 0 WET} - {-1411952400 3600 1 WEST} - {-1396227600 0 0 WET} - {-1379293200 3600 1 WEST} - {-1364778000 0 0 WET} - {-1348448400 3600 1 WEST} - {-1333328400 0 0 WET} - {-1316394000 3600 1 WEST} - {-1301274000 0 0 WET} - {-1284339600 3600 1 WEST} - {-1269824400 0 0 WET} - {-1253494800 3600 1 WEST} - {-1238374800 0 0 WET} - {-1221440400 3600 1 WEST} - {-1206925200 0 0 WET} - {-1191200400 3600 1 WEST} - {-1175475600 0 0 WET} - {-1160355600 3600 1 WEST} - {-1143421200 0 0 WET} - {-1127696400 3600 1 WEST} - {-1111971600 0 0 WET} - {-1096851600 3600 1 WEST} - {-1080522000 0 0 WET} - {-1063587600 3600 1 WEST} - {-1049072400 0 0 WET} - {-1033347600 3600 1 WEST} - {-1017622800 0 0 WET} - {-1002502800 3600 1 WEST} - {-986173200 0 0 WET} - {-969238800 3600 1 WEST} - {-950490000 0 0 WET} - {-942012000 3600 1 WEST} - {-904438800 7200 1 WEMT} - {-891136800 3600 1 WEST} - {-877827600 7200 1 WEMT} - {-857257200 3600 1 WEST} - {-844556400 7200 1 WEMT} - {-828226800 3600 1 WEST} - {-812502000 7200 1 WEMT} - {-796266000 3600 1 WEST} - {-781052400 7200 1 WEMT} - {-766616400 3600 0 CET} - {196819200 7200 1 CEST} - {212540400 3600 0 CET} - {220921200 3600 0 CET} - {228877200 7200 1 CEST} - {243997200 3600 0 CET} - {260326800 7200 1 CEST} - {276051600 3600 0 CET} - {291776400 7200 1 CEST} - {307501200 3600 0 CET} - {323830800 7200 1 CEST} - {338950800 3600 0 CET} - {354675600 7200 1 CEST} - {370400400 3600 0 CET} - {386125200 7200 1 CEST} - {401850000 3600 0 CET} - {417574800 7200 1 CEST} - {433299600 3600 0 CET} - {449024400 7200 1 CEST} - {465354000 3600 0 CET} - {481078800 7200 1 CEST} - {496803600 3600 0 CET} - {512528400 7200 1 CEST} - {528253200 3600 0 CET} - {543978000 7200 1 CEST} - {559702800 3600 0 CET} - {575427600 7200 1 CEST} - {591152400 3600 0 CET} - {606877200 7200 1 CEST} - {622602000 3600 0 CET} - {638326800 7200 1 CEST} - {654656400 3600 0 CET} - {670381200 7200 1 CEST} - {686106000 3600 0 CET} - {701830800 7200 1 CEST} - {717555600 3600 0 CET} - {733280400 7200 1 CEST} - {749005200 3600 0 CET} - {764730000 7200 1 CEST} - {780454800 3600 0 CET} - {796179600 7200 1 CEST} - {811904400 3600 0 CET} - {828234000 7200 1 CEST} - {846378000 3600 0 CET} - {859683600 7200 1 CEST} - {877827600 3600 0 CET} - {891133200 7200 1 CEST} - {909277200 3600 0 CET} - {922582800 7200 1 CEST} - {941331600 3600 0 CET} - {954032400 7200 1 CEST} - {972781200 3600 0 CET} - {985482000 7200 1 CEST} - {1004230800 3600 0 CET} - {1017536400 7200 1 CEST} - {1035680400 3600 0 CET} - {1048986000 7200 1 CEST} - {1067130000 3600 0 CET} - {1080435600 7200 1 CEST} - {1099184400 3600 0 CET} - {1111885200 7200 1 CEST} - {1130634000 3600 0 CET} - {1143334800 7200 1 CEST} - {1162083600 3600 0 CET} - {1174784400 7200 1 CEST} - {1193533200 3600 0 CET} - {1206838800 7200 1 CEST} - {1224982800 3600 0 CET} - {1238288400 7200 1 CEST} - {1256432400 3600 0 CET} - {1269738000 7200 1 CEST} - {1288486800 3600 0 CET} - {1301187600 7200 1 CEST} - {1319936400 3600 0 CET} - {1332637200 7200 1 CEST} - {1351386000 3600 0 CET} - {1364691600 7200 1 CEST} - {1382835600 3600 0 CET} - {1396141200 7200 1 CEST} - {1414285200 3600 0 CET} - {1427590800 7200 1 CEST} - {1445734800 3600 0 CET} - {1459040400 7200 1 CEST} - {1477789200 3600 0 CET} - {1490490000 7200 1 CEST} - {1509238800 3600 0 CET} - {1521939600 7200 1 CEST} - {1540688400 3600 0 CET} - {1553994000 7200 1 CEST} - {1572138000 3600 0 CET} - {1585443600 7200 1 CEST} - {1603587600 3600 0 CET} - {1616893200 7200 1 CEST} - {1635642000 3600 0 CET} - {1648342800 7200 1 CEST} - {1667091600 3600 0 CET} - {1679792400 7200 1 CEST} - {1698541200 3600 0 CET} - {1711846800 7200 1 CEST} - {1729990800 3600 0 CET} - {1743296400 7200 1 CEST} - {1761440400 3600 0 CET} - {1774746000 7200 1 CEST} - {1792890000 3600 0 CET} - {1806195600 7200 1 CEST} - {1824944400 3600 0 CET} - {1837645200 7200 1 CEST} - {1856394000 3600 0 CET} - {1869094800 7200 1 CEST} - {1887843600 3600 0 CET} - {1901149200 7200 1 CEST} - {1919293200 3600 0 CET} - {1932598800 7200 1 CEST} - {1950742800 3600 0 CET} - {1964048400 7200 1 CEST} - {1982797200 3600 0 CET} - {1995498000 7200 1 CEST} - {2014246800 3600 0 CET} - {2026947600 7200 1 CEST} - {2045696400 3600 0 CET} - {2058397200 7200 1 CEST} - {2077146000 3600 0 CET} - {2090451600 7200 1 CEST} - {2108595600 3600 0 CET} - {2121901200 7200 1 CEST} - {2140045200 3600 0 CET} - {2153350800 7200 1 CEST} - {2172099600 3600 0 CET} - {2184800400 7200 1 CEST} - {2203549200 3600 0 CET} - {2216250000 7200 1 CEST} - {2234998800 3600 0 CET} - {2248304400 7200 1 CEST} - {2266448400 3600 0 CET} - {2279754000 7200 1 CEST} - {2297898000 3600 0 CET} - {2311203600 7200 1 CEST} - {2329347600 3600 0 CET} - {2342653200 7200 1 CEST} - {2361402000 3600 0 CET} - {2374102800 7200 1 CEST} - {2392851600 3600 0 CET} - {2405552400 7200 1 CEST} - {2424301200 3600 0 CET} - {2437606800 7200 1 CEST} - {2455750800 3600 0 CET} - {2469056400 7200 1 CEST} - {2487200400 3600 0 CET} - {2500506000 7200 1 CEST} - {2519254800 3600 0 CET} - {2531955600 7200 1 CEST} - {2550704400 3600 0 CET} - {2563405200 7200 1 CEST} - {2582154000 3600 0 CET} - {2595459600 7200 1 CEST} - {2613603600 3600 0 CET} - {2626909200 7200 1 CEST} - {2645053200 3600 0 CET} - {2658358800 7200 1 CEST} - {2676502800 3600 0 CET} - {2689808400 7200 1 CEST} - {2708557200 3600 0 CET} - {2721258000 7200 1 CEST} - {2740006800 3600 0 CET} - {2752707600 7200 1 CEST} - {2771456400 3600 0 CET} - {2784762000 7200 1 CEST} - {2802906000 3600 0 CET} - {2816211600 7200 1 CEST} - {2834355600 3600 0 CET} - {2847661200 7200 1 CEST} - {2866410000 3600 0 CET} - {2879110800 7200 1 CEST} - {2897859600 3600 0 CET} - {2910560400 7200 1 CEST} - {2929309200 3600 0 CET} - {2942010000 7200 1 CEST} - {2960758800 3600 0 CET} - {2974064400 7200 1 CEST} - {2992208400 3600 0 CET} - {3005514000 7200 1 CEST} - {3023658000 3600 0 CET} - {3036963600 7200 1 CEST} - {3055712400 3600 0 CET} - {3068413200 7200 1 CEST} - {3087162000 3600 0 CET} - {3099862800 7200 1 CEST} - {3118611600 3600 0 CET} - {3131917200 7200 1 CEST} - {3150061200 3600 0 CET} - {3163366800 7200 1 CEST} - {3181510800 3600 0 CET} - {3194816400 7200 1 CEST} - {3212960400 3600 0 CET} - {3226266000 7200 1 CEST} - {3245014800 3600 0 CET} - {3257715600 7200 1 CEST} - {3276464400 3600 0 CET} - {3289165200 7200 1 CEST} - {3307914000 3600 0 CET} - {3321219600 7200 1 CEST} - {3339363600 3600 0 CET} - {3352669200 7200 1 CEST} - {3370813200 3600 0 CET} - {3384118800 7200 1 CEST} - {3402867600 3600 0 CET} - {3415568400 7200 1 CEST} - {3434317200 3600 0 CET} - {3447018000 7200 1 CEST} - {3465766800 3600 0 CET} - {3479072400 7200 1 CEST} - {3497216400 3600 0 CET} - {3510522000 7200 1 CEST} - {3528666000 3600 0 CET} - {3541971600 7200 1 CEST} - {3560115600 3600 0 CET} - {3573421200 7200 1 CEST} - {3592170000 3600 0 CET} - {3604870800 7200 1 CEST} - {3623619600 3600 0 CET} - {3636320400 7200 1 CEST} - {3655069200 3600 0 CET} - {3668374800 7200 1 CEST} - {3686518800 3600 0 CET} - {3699824400 7200 1 CEST} - {3717968400 3600 0 CET} - {3731274000 7200 1 CEST} - {3750022800 3600 0 CET} - {3762723600 7200 1 CEST} - {3781472400 3600 0 CET} - {3794173200 7200 1 CEST} - {3812922000 3600 0 CET} - {3825622800 7200 1 CEST} - {3844371600 3600 0 CET} - {3857677200 7200 1 CEST} - {3875821200 3600 0 CET} - {3889126800 7200 1 CEST} - {3907270800 3600 0 CET} - {3920576400 7200 1 CEST} - {3939325200 3600 0 CET} - {3952026000 7200 1 CEST} - {3970774800 3600 0 CET} - {3983475600 7200 1 CEST} - {4002224400 3600 0 CET} - {4015530000 7200 1 CEST} - {4033674000 3600 0 CET} - {4046979600 7200 1 CEST} - {4065123600 3600 0 CET} - {4078429200 7200 1 CEST} - {4096573200 3600 0 CET} +if {![info exists TZData(Europe/Paris)]} { + LoadTimeZoneFile Europe/Paris } +set TZData(:Europe/Monaco) $TZData(:Europe/Paris) diff --git a/library/tzdata/Europe/Oslo b/library/tzdata/Europe/Oslo index 6787c1e..d6d564d 100644 --- a/library/tzdata/Europe/Oslo +++ b/library/tzdata/Europe/Oslo @@ -1,271 +1,5 @@ # created by tools/tclZIC.tcl - do not edit - -set TZData(:Europe/Oslo) { - {-9223372036854775808 2580 0 LMT} - {-2366757780 3600 0 CET} - {-1691884800 7200 1 CEST} - {-1680573600 3600 0 CET} - {-927511200 7200 0 CEST} - {-857257200 3600 0 CET} - {-844556400 7200 1 CEST} - {-828226800 3600 0 CET} - {-812502000 7200 1 CEST} - {-796777200 3600 0 CET} - {-781052400 7200 0 CEST} - {-765327600 3600 0 CET} - {-340844400 7200 1 CEST} - {-324514800 3600 0 CET} - {-308790000 7200 1 CEST} - {-293065200 3600 0 CET} - {-277340400 7200 1 CEST} - {-261615600 3600 0 CET} - {-245890800 7200 1 CEST} - {-230166000 3600 0 CET} - {-214441200 7200 1 CEST} - {-198716400 3600 0 CET} - {-182991600 7200 1 CEST} - {-166662000 3600 0 CET} - {-147913200 7200 1 CEST} - {-135212400 3600 0 CET} - {315529200 3600 0 CET} - {323830800 7200 1 CEST} - {338950800 3600 0 CET} - {354675600 7200 1 CEST} - {370400400 3600 0 CET} - {386125200 7200 1 CEST} - {401850000 3600 0 CET} - {417574800 7200 1 CEST} - {433299600 3600 0 CET} - {449024400 7200 1 CEST} - {465354000 3600 0 CET} - {481078800 7200 1 CEST} - {496803600 3600 0 CET} - {512528400 7200 1 CEST} - {528253200 3600 0 CET} - {543978000 7200 1 CEST} - {559702800 3600 0 CET} - {575427600 7200 1 CEST} - {591152400 3600 0 CET} - {606877200 7200 1 CEST} - {622602000 3600 0 CET} - {638326800 7200 1 CEST} - {654656400 3600 0 CET} - {670381200 7200 1 CEST} - {686106000 3600 0 CET} - {701830800 7200 1 CEST} - {717555600 3600 0 CET} - {733280400 7200 1 CEST} - {749005200 3600 0 CET} - {764730000 7200 1 CEST} - {780454800 3600 0 CET} - {796179600 7200 1 CEST} - {811904400 3600 0 CET} - {828234000 7200 1 CEST} - {846378000 3600 0 CET} - {859683600 7200 1 CEST} - {877827600 3600 0 CET} - {891133200 7200 1 CEST} - {909277200 3600 0 CET} - {922582800 7200 1 CEST} - {941331600 3600 0 CET} - {954032400 7200 1 CEST} - {972781200 3600 0 CET} - {985482000 7200 1 CEST} - {1004230800 3600 0 CET} - {1017536400 7200 1 CEST} - {1035680400 3600 0 CET} - {1048986000 7200 1 CEST} - {1067130000 3600 0 CET} - {1080435600 7200 1 CEST} - {1099184400 3600 0 CET} - {1111885200 7200 1 CEST} - {1130634000 3600 0 CET} - {1143334800 7200 1 CEST} - {1162083600 3600 0 CET} - {1174784400 7200 1 CEST} - {1193533200 3600 0 CET} - {1206838800 7200 1 CEST} - {1224982800 3600 0 CET} - {1238288400 7200 1 CEST} - {1256432400 3600 0 CET} - {1269738000 7200 1 CEST} - {1288486800 3600 0 CET} - {1301187600 7200 1 CEST} - {1319936400 3600 0 CET} - {1332637200 7200 1 CEST} - {1351386000 3600 0 CET} - {1364691600 7200 1 CEST} - {1382835600 3600 0 CET} - {1396141200 7200 1 CEST} - {1414285200 3600 0 CET} - {1427590800 7200 1 CEST} - {1445734800 3600 0 CET} - {1459040400 7200 1 CEST} - {1477789200 3600 0 CET} - {1490490000 7200 1 CEST} - {1509238800 3600 0 CET} - {1521939600 7200 1 CEST} - {1540688400 3600 0 CET} - {1553994000 7200 1 CEST} - {1572138000 3600 0 CET} - {1585443600 7200 1 CEST} - {1603587600 3600 0 CET} - {1616893200 7200 1 CEST} - {1635642000 3600 0 CET} - {1648342800 7200 1 CEST} - {1667091600 3600 0 CET} - {1679792400 7200 1 CEST} - {1698541200 3600 0 CET} - {1711846800 7200 1 CEST} - {1729990800 3600 0 CET} - {1743296400 7200 1 CEST} - {1761440400 3600 0 CET} - {1774746000 7200 1 CEST} - {1792890000 3600 0 CET} - {1806195600 7200 1 CEST} - {1824944400 3600 0 CET} - {1837645200 7200 1 CEST} - {1856394000 3600 0 CET} - {1869094800 7200 1 CEST} - {1887843600 3600 0 CET} - {1901149200 7200 1 CEST} - {1919293200 3600 0 CET} - {1932598800 7200 1 CEST} - {1950742800 3600 0 CET} - {1964048400 7200 1 CEST} - {1982797200 3600 0 CET} - {1995498000 7200 1 CEST} - {2014246800 3600 0 CET} - {2026947600 7200 1 CEST} - {2045696400 3600 0 CET} - {2058397200 7200 1 CEST} - {2077146000 3600 0 CET} - {2090451600 7200 1 CEST} - {2108595600 3600 0 CET} - {2121901200 7200 1 CEST} - {2140045200 3600 0 CET} - {2153350800 7200 1 CEST} - {2172099600 3600 0 CET} - {2184800400 7200 1 CEST} - {2203549200 3600 0 CET} - {2216250000 7200 1 CEST} - {2234998800 3600 0 CET} - {2248304400 7200 1 CEST} - {2266448400 3600 0 CET} - {2279754000 7200 1 CEST} - {2297898000 3600 0 CET} - {2311203600 7200 1 CEST} - {2329347600 3600 0 CET} - {2342653200 7200 1 CEST} - {2361402000 3600 0 CET} - {2374102800 7200 1 CEST} - {2392851600 3600 0 CET} - {2405552400 7200 1 CEST} - {2424301200 3600 0 CET} - {2437606800 7200 1 CEST} - {2455750800 3600 0 CET} - {2469056400 7200 1 CEST} - {2487200400 3600 0 CET} - {2500506000 7200 1 CEST} - {2519254800 3600 0 CET} - {2531955600 7200 1 CEST} - {2550704400 3600 0 CET} - {2563405200 7200 1 CEST} - {2582154000 3600 0 CET} - {2595459600 7200 1 CEST} - {2613603600 3600 0 CET} - {2626909200 7200 1 CEST} - {2645053200 3600 0 CET} - {2658358800 7200 1 CEST} - {2676502800 3600 0 CET} - {2689808400 7200 1 CEST} - {2708557200 3600 0 CET} - {2721258000 7200 1 CEST} - {2740006800 3600 0 CET} - {2752707600 7200 1 CEST} - {2771456400 3600 0 CET} - {2784762000 7200 1 CEST} - {2802906000 3600 0 CET} - {2816211600 7200 1 CEST} - {2834355600 3600 0 CET} - {2847661200 7200 1 CEST} - {2866410000 3600 0 CET} - {2879110800 7200 1 CEST} - {2897859600 3600 0 CET} - {2910560400 7200 1 CEST} - {2929309200 3600 0 CET} - {2942010000 7200 1 CEST} - {2960758800 3600 0 CET} - {2974064400 7200 1 CEST} - {2992208400 3600 0 CET} - {3005514000 7200 1 CEST} - {3023658000 3600 0 CET} - {3036963600 7200 1 CEST} - {3055712400 3600 0 CET} - {3068413200 7200 1 CEST} - {3087162000 3600 0 CET} - {3099862800 7200 1 CEST} - {3118611600 3600 0 CET} - {3131917200 7200 1 CEST} - {3150061200 3600 0 CET} - {3163366800 7200 1 CEST} - {3181510800 3600 0 CET} - {3194816400 7200 1 CEST} - {3212960400 3600 0 CET} - {3226266000 7200 1 CEST} - {3245014800 3600 0 CET} - {3257715600 7200 1 CEST} - {3276464400 3600 0 CET} - {3289165200 7200 1 CEST} - {3307914000 3600 0 CET} - {3321219600 7200 1 CEST} - {3339363600 3600 0 CET} - {3352669200 7200 1 CEST} - {3370813200 3600 0 CET} - {3384118800 7200 1 CEST} - {3402867600 3600 0 CET} - {3415568400 7200 1 CEST} - {3434317200 3600 0 CET} - {3447018000 7200 1 CEST} - {3465766800 3600 0 CET} - {3479072400 7200 1 CEST} - {3497216400 3600 0 CET} - {3510522000 7200 1 CEST} - {3528666000 3600 0 CET} - {3541971600 7200 1 CEST} - {3560115600 3600 0 CET} - {3573421200 7200 1 CEST} - {3592170000 3600 0 CET} - {3604870800 7200 1 CEST} - {3623619600 3600 0 CET} - {3636320400 7200 1 CEST} - {3655069200 3600 0 CET} - {3668374800 7200 1 CEST} - {3686518800 3600 0 CET} - {3699824400 7200 1 CEST} - {3717968400 3600 0 CET} - {3731274000 7200 1 CEST} - {3750022800 3600 0 CET} - {3762723600 7200 1 CEST} - {3781472400 3600 0 CET} - {3794173200 7200 1 CEST} - {3812922000 3600 0 CET} - {3825622800 7200 1 CEST} - {3844371600 3600 0 CET} - {3857677200 7200 1 CEST} - {3875821200 3600 0 CET} - {3889126800 7200 1 CEST} - {3907270800 3600 0 CET} - {3920576400 7200 1 CEST} - {3939325200 3600 0 CET} - {3952026000 7200 1 CEST} - {3970774800 3600 0 CET} - {3983475600 7200 1 CEST} - {4002224400 3600 0 CET} - {4015530000 7200 1 CEST} - {4033674000 3600 0 CET} - {4046979600 7200 1 CEST} - {4065123600 3600 0 CET} - {4078429200 7200 1 CEST} - {4096573200 3600 0 CET} +if {![info exists TZData(Europe/Berlin)]} { + LoadTimeZoneFile Europe/Berlin } +set TZData(:Europe/Oslo) $TZData(:Europe/Berlin) diff --git a/library/tzdata/Europe/Simferopol b/library/tzdata/Europe/Simferopol index e296862..4a5a77f 100644 --- a/library/tzdata/Europe/Simferopol +++ b/library/tzdata/Europe/Simferopol @@ -38,11 +38,11 @@ set TZData(:Europe/Simferopol) { {749001600 7200 0 EET} {764726400 10800 1 EEST} {767743200 14400 0 MSD} - {780436800 10800 0 MSK} - {796165200 14400 1 MSD} - {811886400 10800 0 MSK} + {780447600 10800 0 MSK} + {796172400 14400 1 MSD} + {811897200 10800 0 MSK} {828219600 14400 1 MSD} - {852066000 10800 0 MSK} + {846374400 10800 0 MSK} {859683600 10800 0 EEST} {877827600 7200 0 EET} {891133200 10800 1 EEST} diff --git a/library/tzdata/Europe/Stockholm b/library/tzdata/Europe/Stockholm index b74d327..6b5c55a 100644 --- a/library/tzdata/Europe/Stockholm +++ b/library/tzdata/Europe/Stockholm @@ -1,250 +1,5 @@ # created by tools/tclZIC.tcl - do not edit - -set TZData(:Europe/Stockholm) { - {-9223372036854775808 4332 0 LMT} - {-2871681132 3614 0 SET} - {-2208992414 3600 0 CET} - {-1692496800 7200 1 CEST} - {-1680483600 3600 0 CET} - {315529200 3600 0 CET} - {323830800 7200 1 CEST} - {338950800 3600 0 CET} - {354675600 7200 1 CEST} - {370400400 3600 0 CET} - {386125200 7200 1 CEST} - {401850000 3600 0 CET} - {417574800 7200 1 CEST} - {433299600 3600 0 CET} - {449024400 7200 1 CEST} - {465354000 3600 0 CET} - {481078800 7200 1 CEST} - {496803600 3600 0 CET} - {512528400 7200 1 CEST} - {528253200 3600 0 CET} - {543978000 7200 1 CEST} - {559702800 3600 0 CET} - {575427600 7200 1 CEST} - {591152400 3600 0 CET} - {606877200 7200 1 CEST} - {622602000 3600 0 CET} - {638326800 7200 1 CEST} - {654656400 3600 0 CET} - {670381200 7200 1 CEST} - {686106000 3600 0 CET} - {701830800 7200 1 CEST} - {717555600 3600 0 CET} - {733280400 7200 1 CEST} - {749005200 3600 0 CET} - {764730000 7200 1 CEST} - {780454800 3600 0 CET} - {796179600 7200 1 CEST} - {811904400 3600 0 CET} - {828234000 7200 1 CEST} - {846378000 3600 0 CET} - {859683600 7200 1 CEST} - {877827600 3600 0 CET} - {891133200 7200 1 CEST} - {909277200 3600 0 CET} - {922582800 7200 1 CEST} - {941331600 3600 0 CET} - {954032400 7200 1 CEST} - {972781200 3600 0 CET} - {985482000 7200 1 CEST} - {1004230800 3600 0 CET} - {1017536400 7200 1 CEST} - {1035680400 3600 0 CET} - {1048986000 7200 1 CEST} - {1067130000 3600 0 CET} - {1080435600 7200 1 CEST} - {1099184400 3600 0 CET} - {1111885200 7200 1 CEST} - {1130634000 3600 0 CET} - {1143334800 7200 1 CEST} - {1162083600 3600 0 CET} - {1174784400 7200 1 CEST} - {1193533200 3600 0 CET} - {1206838800 7200 1 CEST} - {1224982800 3600 0 CET} - {1238288400 7200 1 CEST} - {1256432400 3600 0 CET} - {1269738000 7200 1 CEST} - {1288486800 3600 0 CET} - {1301187600 7200 1 CEST} - {1319936400 3600 0 CET} - {1332637200 7200 1 CEST} - {1351386000 3600 0 CET} - {1364691600 7200 1 CEST} - {1382835600 3600 0 CET} - {1396141200 7200 1 CEST} - {1414285200 3600 0 CET} - {1427590800 7200 1 CEST} - {1445734800 3600 0 CET} - {1459040400 7200 1 CEST} - {1477789200 3600 0 CET} - {1490490000 7200 1 CEST} - {1509238800 3600 0 CET} - {1521939600 7200 1 CEST} - {1540688400 3600 0 CET} - {1553994000 7200 1 CEST} - {1572138000 3600 0 CET} - {1585443600 7200 1 CEST} - {1603587600 3600 0 CET} - {1616893200 7200 1 CEST} - {1635642000 3600 0 CET} - {1648342800 7200 1 CEST} - {1667091600 3600 0 CET} - {1679792400 7200 1 CEST} - {1698541200 3600 0 CET} - {1711846800 7200 1 CEST} - {1729990800 3600 0 CET} - {1743296400 7200 1 CEST} - {1761440400 3600 0 CET} - {1774746000 7200 1 CEST} - {1792890000 3600 0 CET} - {1806195600 7200 1 CEST} - {1824944400 3600 0 CET} - {1837645200 7200 1 CEST} - {1856394000 3600 0 CET} - {1869094800 7200 1 CEST} - {1887843600 3600 0 CET} - {1901149200 7200 1 CEST} - {1919293200 3600 0 CET} - {1932598800 7200 1 CEST} - {1950742800 3600 0 CET} - {1964048400 7200 1 CEST} - {1982797200 3600 0 CET} - {1995498000 7200 1 CEST} - {2014246800 3600 0 CET} - {2026947600 7200 1 CEST} - {2045696400 3600 0 CET} - {2058397200 7200 1 CEST} - {2077146000 3600 0 CET} - {2090451600 7200 1 CEST} - {2108595600 3600 0 CET} - {2121901200 7200 1 CEST} - {2140045200 3600 0 CET} - {2153350800 7200 1 CEST} - {2172099600 3600 0 CET} - {2184800400 7200 1 CEST} - {2203549200 3600 0 CET} - {2216250000 7200 1 CEST} - {2234998800 3600 0 CET} - {2248304400 7200 1 CEST} - {2266448400 3600 0 CET} - {2279754000 7200 1 CEST} - {2297898000 3600 0 CET} - {2311203600 7200 1 CEST} - {2329347600 3600 0 CET} - {2342653200 7200 1 CEST} - {2361402000 3600 0 CET} - {2374102800 7200 1 CEST} - {2392851600 3600 0 CET} - {2405552400 7200 1 CEST} - {2424301200 3600 0 CET} - {2437606800 7200 1 CEST} - {2455750800 3600 0 CET} - {2469056400 7200 1 CEST} - {2487200400 3600 0 CET} - {2500506000 7200 1 CEST} - {2519254800 3600 0 CET} - {2531955600 7200 1 CEST} - {2550704400 3600 0 CET} - {2563405200 7200 1 CEST} - {2582154000 3600 0 CET} - {2595459600 7200 1 CEST} - {2613603600 3600 0 CET} - {2626909200 7200 1 CEST} - {2645053200 3600 0 CET} - {2658358800 7200 1 CEST} - {2676502800 3600 0 CET} - {2689808400 7200 1 CEST} - {2708557200 3600 0 CET} - {2721258000 7200 1 CEST} - {2740006800 3600 0 CET} - {2752707600 7200 1 CEST} - {2771456400 3600 0 CET} - {2784762000 7200 1 CEST} - {2802906000 3600 0 CET} - {2816211600 7200 1 CEST} - {2834355600 3600 0 CET} - {2847661200 7200 1 CEST} - {2866410000 3600 0 CET} - {2879110800 7200 1 CEST} - {2897859600 3600 0 CET} - {2910560400 7200 1 CEST} - {2929309200 3600 0 CET} - {2942010000 7200 1 CEST} - {2960758800 3600 0 CET} - {2974064400 7200 1 CEST} - {2992208400 3600 0 CET} - {3005514000 7200 1 CEST} - {3023658000 3600 0 CET} - {3036963600 7200 1 CEST} - {3055712400 3600 0 CET} - {3068413200 7200 1 CEST} - {3087162000 3600 0 CET} - {3099862800 7200 1 CEST} - {3118611600 3600 0 CET} - {3131917200 7200 1 CEST} - {3150061200 3600 0 CET} - {3163366800 7200 1 CEST} - {3181510800 3600 0 CET} - {3194816400 7200 1 CEST} - {3212960400 3600 0 CET} - {3226266000 7200 1 CEST} - {3245014800 3600 0 CET} - {3257715600 7200 1 CEST} - {3276464400 3600 0 CET} - {3289165200 7200 1 CEST} - {3307914000 3600 0 CET} - {3321219600 7200 1 CEST} - {3339363600 3600 0 CET} - {3352669200 7200 1 CEST} - {3370813200 3600 0 CET} - {3384118800 7200 1 CEST} - {3402867600 3600 0 CET} - {3415568400 7200 1 CEST} - {3434317200 3600 0 CET} - {3447018000 7200 1 CEST} - {3465766800 3600 0 CET} - {3479072400 7200 1 CEST} - {3497216400 3600 0 CET} - {3510522000 7200 1 CEST} - {3528666000 3600 0 CET} - {3541971600 7200 1 CEST} - {3560115600 3600 0 CET} - {3573421200 7200 1 CEST} - {3592170000 3600 0 CET} - {3604870800 7200 1 CEST} - {3623619600 3600 0 CET} - {3636320400 7200 1 CEST} - {3655069200 3600 0 CET} - {3668374800 7200 1 CEST} - {3686518800 3600 0 CET} - {3699824400 7200 1 CEST} - {3717968400 3600 0 CET} - {3731274000 7200 1 CEST} - {3750022800 3600 0 CET} - {3762723600 7200 1 CEST} - {3781472400 3600 0 CET} - {3794173200 7200 1 CEST} - {3812922000 3600 0 CET} - {3825622800 7200 1 CEST} - {3844371600 3600 0 CET} - {3857677200 7200 1 CEST} - {3875821200 3600 0 CET} - {3889126800 7200 1 CEST} - {3907270800 3600 0 CET} - {3920576400 7200 1 CEST} - {3939325200 3600 0 CET} - {3952026000 7200 1 CEST} - {3970774800 3600 0 CET} - {3983475600 7200 1 CEST} - {4002224400 3600 0 CET} - {4015530000 7200 1 CEST} - {4033674000 3600 0 CET} - {4046979600 7200 1 CEST} - {4065123600 3600 0 CET} - {4078429200 7200 1 CEST} - {4096573200 3600 0 CET} +if {![info exists TZData(Europe/Berlin)]} { + LoadTimeZoneFile Europe/Berlin } +set TZData(:Europe/Stockholm) $TZData(:Europe/Berlin) diff --git a/library/tzdata/Iceland b/library/tzdata/Iceland index eb3f3eb..3e7cd0c 100644 --- a/library/tzdata/Iceland +++ b/library/tzdata/Iceland @@ -1,5 +1,5 @@ # created by tools/tclZIC.tcl - do not edit -if {![info exists TZData(Atlantic/Reykjavik)]} { - LoadTimeZoneFile Atlantic/Reykjavik +if {![info exists TZData(Africa/Abidjan)]} { + LoadTimeZoneFile Africa/Abidjan } -set TZData(:Iceland) $TZData(:Atlantic/Reykjavik) +set TZData(:Iceland) $TZData(:Africa/Abidjan) diff --git a/library/tzdata/Indian/Christmas b/library/tzdata/Indian/Christmas index 76f8cbe..dea9f90 100644 --- a/library/tzdata/Indian/Christmas +++ b/library/tzdata/Indian/Christmas @@ -1,6 +1,5 @@ # created by tools/tclZIC.tcl - do not edit - -set TZData(:Indian/Christmas) { - {-9223372036854775808 25372 0 LMT} - {-2364102172 25200 0 +07} +if {![info exists TZData(Asia/Bangkok)]} { + LoadTimeZoneFile Asia/Bangkok } +set TZData(:Indian/Christmas) $TZData(:Asia/Bangkok) diff --git a/library/tzdata/Indian/Cocos b/library/tzdata/Indian/Cocos index 833eb20..cb474c9 100644 --- a/library/tzdata/Indian/Cocos +++ b/library/tzdata/Indian/Cocos @@ -1,6 +1,5 @@ # created by tools/tclZIC.tcl - do not edit - -set TZData(:Indian/Cocos) { - {-9223372036854775808 23260 0 LMT} - {-2209012060 23400 0 +0630} +if {![info exists TZData(Asia/Yangon)]} { + LoadTimeZoneFile Asia/Yangon } +set TZData(:Indian/Cocos) $TZData(:Asia/Yangon) diff --git a/library/tzdata/Indian/Kerguelen b/library/tzdata/Indian/Kerguelen index 93f2d94..b3cbeee 100644 --- a/library/tzdata/Indian/Kerguelen +++ b/library/tzdata/Indian/Kerguelen @@ -1,6 +1,5 @@ # created by tools/tclZIC.tcl - do not edit - -set TZData(:Indian/Kerguelen) { - {-9223372036854775808 0 0 -00} - {-631152000 18000 0 +05} +if {![info exists TZData(Indian/Maldives)]} { + LoadTimeZoneFile Indian/Maldives } +set TZData(:Indian/Kerguelen) $TZData(:Indian/Maldives) diff --git a/library/tzdata/Indian/Mahe b/library/tzdata/Indian/Mahe index dcafc36..3c728d2 100644 --- a/library/tzdata/Indian/Mahe +++ b/library/tzdata/Indian/Mahe @@ -1,6 +1,5 @@ # created by tools/tclZIC.tcl - do not edit - -set TZData(:Indian/Mahe) { - {-9223372036854775808 13308 0 LMT} - {-1988163708 14400 0 +04} +if {![info exists TZData(Asia/Dubai)]} { + LoadTimeZoneFile Asia/Dubai } +set TZData(:Indian/Mahe) $TZData(:Asia/Dubai) diff --git a/library/tzdata/Indian/Reunion b/library/tzdata/Indian/Reunion index aa78dec..14f2320 100644 --- a/library/tzdata/Indian/Reunion +++ b/library/tzdata/Indian/Reunion @@ -1,6 +1,5 @@ # created by tools/tclZIC.tcl - do not edit - -set TZData(:Indian/Reunion) { - {-9223372036854775808 13312 0 LMT} - {-1848886912 14400 0 +04} +if {![info exists TZData(Asia/Dubai)]} { + LoadTimeZoneFile Asia/Dubai } +set TZData(:Indian/Reunion) $TZData(:Asia/Dubai) diff --git a/library/tzdata/Pacific/Chuuk b/library/tzdata/Pacific/Chuuk index ea1cba2..5e2960c 100644 --- a/library/tzdata/Pacific/Chuuk +++ b/library/tzdata/Pacific/Chuuk @@ -1,11 +1,5 @@ # created by tools/tclZIC.tcl - do not edit - -set TZData(:Pacific/Chuuk) { - {-9223372036854775808 -49972 0 LMT} - {-3944628428 36428 0 LMT} - {-2177489228 36000 0 +10} - {-1743674400 32400 0 +09} - {-1606813200 36000 0 +10} - {-907408800 32400 0 +09} - {-770634000 36000 0 +10} +if {![info exists TZData(Pacific/Port_Moresby)]} { + LoadTimeZoneFile Pacific/Port_Moresby } +set TZData(:Pacific/Chuuk) $TZData(:Pacific/Port_Moresby) diff --git a/library/tzdata/Pacific/Easter b/library/tzdata/Pacific/Easter index 7a8d525..97e1f4f 100644 --- a/library/tzdata/Pacific/Easter +++ b/library/tzdata/Pacific/Easter @@ -110,7 +110,7 @@ set TZData(:Pacific/Easter) { {1617505200 -21600 0 -06} {1630814400 -18000 1 -06} {1648954800 -21600 0 -06} - {1662264000 -18000 1 -06} + {1662868800 -18000 1 -06} {1680404400 -21600 0 -06} {1693713600 -18000 1 -06} {1712458800 -21600 0 -06} diff --git a/library/tzdata/Pacific/Funafuti b/library/tzdata/Pacific/Funafuti index d806525..d932469 100644 --- a/library/tzdata/Pacific/Funafuti +++ b/library/tzdata/Pacific/Funafuti @@ -1,6 +1,5 @@ # created by tools/tclZIC.tcl - do not edit - -set TZData(:Pacific/Funafuti) { - {-9223372036854775808 43012 0 LMT} - {-2177495812 43200 0 +12} +if {![info exists TZData(Pacific/Tarawa)]} { + LoadTimeZoneFile Pacific/Tarawa } +set TZData(:Pacific/Funafuti) $TZData(:Pacific/Tarawa) diff --git a/library/tzdata/Pacific/Majuro b/library/tzdata/Pacific/Majuro index a263a62..b30f494 100644 --- a/library/tzdata/Pacific/Majuro +++ b/library/tzdata/Pacific/Majuro @@ -1,12 +1,5 @@ # created by tools/tclZIC.tcl - do not edit - -set TZData(:Pacific/Majuro) { - {-9223372036854775808 41088 0 LMT} - {-2177493888 39600 0 +11} - {-1743678000 32400 0 +09} - {-1606813200 39600 0 +11} - {-1041418800 36000 0 +10} - {-907408800 32400 0 +09} - {-818067600 39600 0 +11} - {-7988400 43200 0 +12} +if {![info exists TZData(Pacific/Tarawa)]} { + LoadTimeZoneFile Pacific/Tarawa } +set TZData(:Pacific/Majuro) $TZData(:Pacific/Tarawa) diff --git a/library/tzdata/Pacific/Pohnpei b/library/tzdata/Pacific/Pohnpei index 7d0adf3..a8d9779 100644 --- a/library/tzdata/Pacific/Pohnpei +++ b/library/tzdata/Pacific/Pohnpei @@ -1,12 +1,5 @@ # created by tools/tclZIC.tcl - do not edit - -set TZData(:Pacific/Pohnpei) { - {-9223372036854775808 -48428 0 LMT} - {-3944629972 37972 0 LMT} - {-2177490772 39600 0 +11} - {-1743678000 32400 0 +09} - {-1606813200 39600 0 +11} - {-1041418800 36000 0 +10} - {-907408800 32400 0 +09} - {-770634000 39600 0 +11} +if {![info exists TZData(Pacific/Guadalcanal)]} { + LoadTimeZoneFile Pacific/Guadalcanal } +set TZData(:Pacific/Pohnpei) $TZData(:Pacific/Guadalcanal) diff --git a/library/tzdata/Pacific/Ponape b/library/tzdata/Pacific/Ponape index 89644f7..1211f14 100644 --- a/library/tzdata/Pacific/Ponape +++ b/library/tzdata/Pacific/Ponape @@ -1,5 +1,5 @@ # created by tools/tclZIC.tcl - do not edit -if {![info exists TZData(Pacific/Pohnpei)]} { - LoadTimeZoneFile Pacific/Pohnpei +if {![info exists TZData(Pacific/Guadalcanal)]} { + LoadTimeZoneFile Pacific/Guadalcanal } -set TZData(:Pacific/Ponape) $TZData(:Pacific/Pohnpei) +set TZData(:Pacific/Ponape) $TZData(:Pacific/Guadalcanal) diff --git a/library/tzdata/Pacific/Truk b/library/tzdata/Pacific/Truk index c9b1894..7ddbad7 100644 --- a/library/tzdata/Pacific/Truk +++ b/library/tzdata/Pacific/Truk @@ -1,5 +1,5 @@ # created by tools/tclZIC.tcl - do not edit -if {![info exists TZData(Pacific/Chuuk)]} { - LoadTimeZoneFile Pacific/Chuuk +if {![info exists TZData(Pacific/Port_Moresby)]} { + LoadTimeZoneFile Pacific/Port_Moresby } -set TZData(:Pacific/Truk) $TZData(:Pacific/Chuuk) +set TZData(:Pacific/Truk) $TZData(:Pacific/Port_Moresby) diff --git a/library/tzdata/Pacific/Wake b/library/tzdata/Pacific/Wake index 67eab37..945a863 100644 --- a/library/tzdata/Pacific/Wake +++ b/library/tzdata/Pacific/Wake @@ -1,6 +1,5 @@ # created by tools/tclZIC.tcl - do not edit - -set TZData(:Pacific/Wake) { - {-9223372036854775808 39988 0 LMT} - {-2177492788 43200 0 +12} +if {![info exists TZData(Pacific/Tarawa)]} { + LoadTimeZoneFile Pacific/Tarawa } +set TZData(:Pacific/Wake) $TZData(:Pacific/Tarawa) diff --git a/library/tzdata/Pacific/Wallis b/library/tzdata/Pacific/Wallis index 152e6af..92748f4 100644 --- a/library/tzdata/Pacific/Wallis +++ b/library/tzdata/Pacific/Wallis @@ -1,6 +1,5 @@ # created by tools/tclZIC.tcl - do not edit - -set TZData(:Pacific/Wallis) { - {-9223372036854775808 44120 0 LMT} - {-2177496920 43200 0 +12} +if {![info exists TZData(Pacific/Tarawa)]} { + LoadTimeZoneFile Pacific/Tarawa } +set TZData(:Pacific/Wallis) $TZData(:Pacific/Tarawa) diff --git a/library/tzdata/Pacific/Yap b/library/tzdata/Pacific/Yap index 4931030..f0b6ae7 100644 --- a/library/tzdata/Pacific/Yap +++ b/library/tzdata/Pacific/Yap @@ -1,5 +1,5 @@ # created by tools/tclZIC.tcl - do not edit -if {![info exists TZData(Pacific/Chuuk)]} { - LoadTimeZoneFile Pacific/Chuuk +if {![info exists TZData(Pacific/Port_Moresby)]} { + LoadTimeZoneFile Pacific/Port_Moresby } -set TZData(:Pacific/Yap) $TZData(:Pacific/Chuuk) +set TZData(:Pacific/Yap) $TZData(:Pacific/Port_Moresby) diff --git a/library/tzdata/US/Pacific-New b/library/tzdata/US/Pacific-New deleted file mode 100644 index 2eb30f8..0000000 --- a/library/tzdata/US/Pacific-New +++ /dev/null @@ -1,5 +0,0 @@ -# created by tools/tclZIC.tcl - do not edit -if {![info exists TZData(America/Los_Angeles)]} { - LoadTimeZoneFile America/Los_Angeles -} -set TZData(:US/Pacific-New) $TZData(:America/Los_Angeles) -- cgit v0.12 From 2f8f82a2b16cc444c327e2d3e49d9c858b8270ae Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 23 Aug 2022 06:41:53 +0000 Subject: Add Europe/Kyiv to tzdata (missing from previous commit) --- library/tzdata/Europe/Kyiv | 251 +++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 251 insertions(+) create mode 100644 library/tzdata/Europe/Kyiv diff --git a/library/tzdata/Europe/Kyiv b/library/tzdata/Europe/Kyiv new file mode 100644 index 0000000..c7c0e2f --- /dev/null +++ b/library/tzdata/Europe/Kyiv @@ -0,0 +1,251 @@ +# created by tools/tclZIC.tcl - do not edit + +set TZData(:Europe/Kyiv) { + {-9223372036854775808 7324 0 LMT} + {-2840148124 7324 0 KMT} + {-1441159324 7200 0 EET} + {-1247536800 10800 0 MSK} + {-892522800 3600 0 CET} + {-857257200 3600 0 CET} + {-844556400 7200 1 CEST} + {-828226800 3600 0 CET} + {-825382800 10800 0 MSD} + {354920400 14400 1 MSD} + {370728000 10800 0 MSK} + {386456400 14400 1 MSD} + {402264000 10800 0 MSK} + {417992400 14400 1 MSD} + {433800000 10800 0 MSK} + {449614800 14400 1 MSD} + {465346800 10800 0 MSK} + {481071600 14400 1 MSD} + {496796400 10800 0 MSK} + {512521200 14400 1 MSD} + {528246000 10800 0 MSK} + {543970800 14400 1 MSD} + {559695600 10800 0 MSK} + {575420400 14400 1 MSD} + {591145200 10800 0 MSK} + {606870000 14400 1 MSD} + {622594800 10800 0 MSK} + {638319600 14400 1 MSD} + {646786800 10800 1 EEST} + {686102400 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} + {891133200 10800 1 EEST} + {909277200 7200 0 EET} + {922582800 10800 1 EEST} + {941331600 7200 0 EET} + {954032400 10800 1 EEST} + {972781200 7200 0 EET} + {985482000 10800 1 EEST} + {1004230800 7200 0 EET} + {1017536400 10800 1 EEST} + {1035680400 7200 0 EET} + {1048986000 10800 1 EEST} + {1067130000 7200 0 EET} + {1080435600 10800 1 EEST} + {1099184400 7200 0 EET} + {1111885200 10800 1 EEST} + {1130634000 7200 0 EET} + {1143334800 10800 1 EEST} + {1162083600 7200 0 EET} + {1174784400 10800 1 EEST} + {1193533200 7200 0 EET} + {1206838800 10800 1 EEST} + {1224982800 7200 0 EET} + {1238288400 10800 1 EEST} + {1256432400 7200 0 EET} + {1269738000 10800 1 EEST} + {1288486800 7200 0 EET} + {1301187600 10800 1 EEST} + {1319936400 7200 0 EET} + {1332637200 10800 1 EEST} + {1351386000 7200 0 EET} + {1364691600 10800 1 EEST} + {1382835600 7200 0 EET} + {1396141200 10800 1 EEST} + {1414285200 7200 0 EET} + {1427590800 10800 1 EEST} + {1445734800 7200 0 EET} + {1459040400 10800 1 EEST} + {1477789200 7200 0 EET} + {1490490000 10800 1 EEST} + {1509238800 7200 0 EET} + {1521939600 10800 1 EEST} + {1540688400 7200 0 EET} + {1553994000 10800 1 EEST} + {1572138000 7200 0 EET} + {1585443600 10800 1 EEST} + {1603587600 7200 0 EET} + {1616893200 10800 1 EEST} + {1635642000 7200 0 EET} + {1648342800 10800 1 EEST} + {1667091600 7200 0 EET} + {1679792400 10800 1 EEST} + {1698541200 7200 0 EET} + {1711846800 10800 1 EEST} + {1729990800 7200 0 EET} + {1743296400 10800 1 EEST} + {1761440400 7200 0 EET} + {1774746000 10800 1 EEST} + {1792890000 7200 0 EET} + {1806195600 10800 1 EEST} + {1824944400 7200 0 EET} + {1837645200 10800 1 EEST} + {1856394000 7200 0 EET} + {1869094800 10800 1 EEST} + {1887843600 7200 0 EET} + {1901149200 10800 1 EEST} + {1919293200 7200 0 EET} + {1932598800 10800 1 EEST} + {1950742800 7200 0 EET} + {1964048400 10800 1 EEST} + {1982797200 7200 0 EET} + {1995498000 10800 1 EEST} + {2014246800 7200 0 EET} + {2026947600 10800 1 EEST} + {2045696400 7200 0 EET} + {2058397200 10800 1 EEST} + {2077146000 7200 0 EET} + {2090451600 10800 1 EEST} + {2108595600 7200 0 EET} + {2121901200 10800 1 EEST} + {2140045200 7200 0 EET} + {2153350800 10800 1 EEST} + {2172099600 7200 0 EET} + {2184800400 10800 1 EEST} + {2203549200 7200 0 EET} + {2216250000 10800 1 EEST} + {2234998800 7200 0 EET} + {2248304400 10800 1 EEST} + {2266448400 7200 0 EET} + {2279754000 10800 1 EEST} + {2297898000 7200 0 EET} + {2311203600 10800 1 EEST} + {2329347600 7200 0 EET} + {2342653200 10800 1 EEST} + {2361402000 7200 0 EET} + {2374102800 10800 1 EEST} + {2392851600 7200 0 EET} + {2405552400 10800 1 EEST} + {2424301200 7200 0 EET} + {2437606800 10800 1 EEST} + {2455750800 7200 0 EET} + {2469056400 10800 1 EEST} + {2487200400 7200 0 EET} + {2500506000 10800 1 EEST} + {2519254800 7200 0 EET} + {2531955600 10800 1 EEST} + {2550704400 7200 0 EET} + {2563405200 10800 1 EEST} + {2582154000 7200 0 EET} + {2595459600 10800 1 EEST} + {2613603600 7200 0 EET} + {2626909200 10800 1 EEST} + {2645053200 7200 0 EET} + {2658358800 10800 1 EEST} + {2676502800 7200 0 EET} + {2689808400 10800 1 EEST} + {2708557200 7200 0 EET} + {2721258000 10800 1 EEST} + {2740006800 7200 0 EET} + {2752707600 10800 1 EEST} + {2771456400 7200 0 EET} + {2784762000 10800 1 EEST} + {2802906000 7200 0 EET} + {2816211600 10800 1 EEST} + {2834355600 7200 0 EET} + {2847661200 10800 1 EEST} + {2866410000 7200 0 EET} + {2879110800 10800 1 EEST} + {2897859600 7200 0 EET} + {2910560400 10800 1 EEST} + {2929309200 7200 0 EET} + {2942010000 10800 1 EEST} + {2960758800 7200 0 EET} + {2974064400 10800 1 EEST} + {2992208400 7200 0 EET} + {3005514000 10800 1 EEST} + {3023658000 7200 0 EET} + {3036963600 10800 1 EEST} + {3055712400 7200 0 EET} + {3068413200 10800 1 EEST} + {3087162000 7200 0 EET} + {3099862800 10800 1 EEST} + {3118611600 7200 0 EET} + {3131917200 10800 1 EEST} + {3150061200 7200 0 EET} + {3163366800 10800 1 EEST} + {3181510800 7200 0 EET} + {3194816400 10800 1 EEST} + {3212960400 7200 0 EET} + {3226266000 10800 1 EEST} + {3245014800 7200 0 EET} + {3257715600 10800 1 EEST} + {3276464400 7200 0 EET} + {3289165200 10800 1 EEST} + {3307914000 7200 0 EET} + {3321219600 10800 1 EEST} + {3339363600 7200 0 EET} + {3352669200 10800 1 EEST} + {3370813200 7200 0 EET} + {3384118800 10800 1 EEST} + {3402867600 7200 0 EET} + {3415568400 10800 1 EEST} + {3434317200 7200 0 EET} + {3447018000 10800 1 EEST} + {3465766800 7200 0 EET} + {3479072400 10800 1 EEST} + {3497216400 7200 0 EET} + {3510522000 10800 1 EEST} + {3528666000 7200 0 EET} + {3541971600 10800 1 EEST} + {3560115600 7200 0 EET} + {3573421200 10800 1 EEST} + {3592170000 7200 0 EET} + {3604870800 10800 1 EEST} + {3623619600 7200 0 EET} + {3636320400 10800 1 EEST} + {3655069200 7200 0 EET} + {3668374800 10800 1 EEST} + {3686518800 7200 0 EET} + {3699824400 10800 1 EEST} + {3717968400 7200 0 EET} + {3731274000 10800 1 EEST} + {3750022800 7200 0 EET} + {3762723600 10800 1 EEST} + {3781472400 7200 0 EET} + {3794173200 10800 1 EEST} + {3812922000 7200 0 EET} + {3825622800 10800 1 EEST} + {3844371600 7200 0 EET} + {3857677200 10800 1 EEST} + {3875821200 7200 0 EET} + {3889126800 10800 1 EEST} + {3907270800 7200 0 EET} + {3920576400 10800 1 EEST} + {3939325200 7200 0 EET} + {3952026000 10800 1 EEST} + {3970774800 7200 0 EET} + {3983475600 10800 1 EEST} + {4002224400 7200 0 EET} + {4015530000 10800 1 EEST} + {4033674000 7200 0 EET} + {4046979600 10800 1 EEST} + {4065123600 7200 0 EET} + {4078429200 10800 1 EEST} + {4096573200 7200 0 EET} +} -- cgit v0.12 From ce60b9f9bf7ea98961297c9757251a4abcdaa4de Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 23 Aug 2022 07:27:08 +0000 Subject: Patch (8) from [37108037b9]: Code cleanups to support CHERI --- generic/tclCompCmdsSZ.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/generic/tclCompCmdsSZ.c b/generic/tclCompCmdsSZ.c index 4c325c2..bfa1957 100644 --- a/generic/tclCompCmdsSZ.c +++ b/generic/tclCompCmdsSZ.c @@ -2383,7 +2383,7 @@ IssueSwitchJumpTable( * point to here. */ - Tcl_SetHashValue(hPtr, CurrentOffset(envPtr) - jumpLocation); + Tcl_SetHashValue(hPtr, INT2PTR(CurrentOffset(envPtr) - jumpLocation)); } Tcl_DStringFree(&buffer); } else { -- cgit v0.12 From ec609cef016b8d3c191e599f4ca70aace4e11c53 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 25 Aug 2022 20:36:39 +0000 Subject: [37108037b9]: Code cleanups to support CHERI. Apply patch 0001 and 0003 (and a few more potential alignment problems, inspired by those patches) --- generic/tclCompile.c | 8 ++++++-- generic/tclDisassemble.c | 13 +++++++------ generic/tclExecute.c | 4 ++-- generic/tclInt.h | 26 +++++++++++++++++++------- 4 files changed, 34 insertions(+), 17 deletions(-) diff --git a/generic/tclCompile.c b/generic/tclCompile.c index 80d8a09..2d22dc1 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -2838,9 +2838,13 @@ TclInitByteCode( /* * Compute the total number of bytes needed for this bytecode. + * + * Note that code bytes need not be aligned but since later elements are we + * need to pad anyway, either directly after ByteCode or after codeBytes, + * and it's easier and more consistent to do the former. */ - structureSize = sizeof(ByteCode); + structureSize = TCL_ALIGN(sizeof(ByteCode)); /* align code bytes */ structureSize += TCL_ALIGN(codeBytes); /* align object array */ structureSize += TCL_ALIGN(objArrayBytes); /* align exc range arr */ structureSize += TCL_ALIGN(exceptArrayBytes); /* align AuxData array */ @@ -2879,7 +2883,7 @@ TclInitByteCode( codePtr->maxExceptDepth = envPtr->maxExceptDepth; codePtr->maxStackDepth = envPtr->maxStackDepth; - p += sizeof(ByteCode); + p += TCL_ALIGN(sizeof(ByteCode)); /* align code bytes */ codePtr->codeStart = p; memcpy(p, envPtr->codeStart, codeBytes); diff --git a/generic/tclDisassemble.c b/generic/tclDisassemble.c index 2653630..0bc3de1 100644 --- a/generic/tclDisassemble.c +++ b/generic/tclDisassemble.c @@ -301,13 +301,14 @@ DisassembleByteCodeObj( #ifdef TCL_COMPILE_STATS Tcl_AppendPrintfToObj(bufferObj, - " Code %lu = header %lu+inst %d+litObj %lu+exc %lu+aux %lu+cmdMap %d\n", - (unsigned long) codePtr->structureSize, - (unsigned long) (sizeof(ByteCode) - sizeof(size_t) - sizeof(Tcl_Time)), + " Code %" TCL_Z_MODIFIER "u = header %" TCL_Z_MODIFIER "u+inst %d+litObj %" + TCL_Z_MODIFIER "u+exc %" TCL_Z_MODIFIER "u+aux %" TCL_Z_MODIFIER "u+cmdMap %d\n", + codePtr->structureSize, + offsetof(ByteCode, localCachePtr), codePtr->numCodeBytes, - (unsigned long) (codePtr->numLitObjects * sizeof(Tcl_Obj *)), - (unsigned long) (codePtr->numExceptRanges*sizeof(ExceptionRange)), - (unsigned long) (codePtr->numAuxDataItems * sizeof(AuxData)), + codePtr->numLitObjects * sizeof(Tcl_Obj *), + codePtr->numExceptRanges*sizeof(ExceptionRange), + codePtr->numAuxDataItems * sizeof(AuxData), codePtr->numCmdLocBytes); #endif /* TCL_COMPILE_STATS */ diff --git a/generic/tclExecute.c b/generic/tclExecute.c index dd50be0..3fb7e07 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -9080,7 +9080,7 @@ PrintByteCodeInfo( #ifdef TCL_COMPILE_STATS fprintf(stdout, " Code %lu = header %lu+inst %d+litObj %lu+exc %lu+aux %lu+cmdMap %d\n", (unsigned long) codePtr->structureSize, - (unsigned long) (sizeof(ByteCode)-sizeof(size_t)-sizeof(Tcl_Time)), + (unsigned long) offsetof(ByteCode, localCachePtr), codePtr->numCodeBytes, (unsigned long) (codePtr->numLitObjects * sizeof(Tcl_Obj *)), (unsigned long) (codePtr->numExceptRanges*sizeof(ExceptionRange)), @@ -9723,7 +9723,7 @@ EvalStatsCmd( numCurrentByteCodes = statsPtr->numCompilations - statsPtr->numByteCodesFreed; currentHeaderBytes = numCurrentByteCodes - * (sizeof(ByteCode) - sizeof(size_t) - sizeof(Tcl_Time)); + * offsetof(ByteCode, localCachePtr); literalMgmtBytes = sizeof(LiteralTable) + (iPtr->literalTable.numBuckets * sizeof(LiteralEntry *)) + (iPtr->literalTable.numEntries * sizeof(LiteralEntry)); diff --git a/generic/tclInt.h b/generic/tclInt.h index ac6fb54..f032efb 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -2358,22 +2358,34 @@ typedef struct Interp { #endif /* - * This macro is used to determine the offset needed to safely allocate any + * TCL_ALIGN is used to determine the offset needed to safely allocate any * data structure in memory. Given a starting offset or size, it "rounds up" - * or "aligns" the offset to the next 8-byte boundary so that any data - * structure can be placed at the resulting offset without fear of an - * alignment error. + * or "aligns" the offset to the next aligned (typically 8-byte) boundary so + * that any data structure can be placed at the resulting offset without fear + * of an alignment error. Note this is clamped to a minimum of 8 for API + * compatibility. * * WARNING!! DO NOT USE THIS MACRO TO ALIGN POINTERS: it will produce the - * wrong result on platforms that allocate addresses that are divisible by 4 - * or 2. Only use it for offsets or sizes. + * wrong result on platforms that allocate addresses that are divisible by a + * non-trivial factor of this alignment. Only use it for offsets or sizes. * * This macro is only used by tclCompile.c in the core (Bug 926445). It * however not be made file static, as extensions that touch bytecodes * (notably tbcload) require it. */ -#define TCL_ALIGN(x) (((int)(x) + 7) & ~7) +struct TclMaxAlignment { + char unalign[8]; + union { + long long maxAlignLongLong; + double maxAlignDouble; + void *maxAlignPointer; + } aligned; +}; +#define TCL_ALIGN_BYTES \ + offsetof(struct TclMaxAlignment, aligned) +#define TCL_ALIGN(x) \ + (((x) + (TCL_ALIGN_BYTES - 1)) & ~(TCL_ALIGN_BYTES - 1)) /* * A common panic alert when memory allocation fails. -- cgit v0.12 From 17775db55f95232f3821a717f6df97c4a1f3f010 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 26 Aug 2022 20:23:14 +0000 Subject: [37108037b9]: Code cleanups to support CHERI: Apply patch 0007 (modified) --- generic/tclHash.c | 28 ++++++---------------------- generic/tclProc.c | 2 +- 2 files changed, 7 insertions(+), 23 deletions(-) diff --git a/generic/tclHash.c b/generic/tclHash.c index 606d26b..37e45e7 100644 --- a/generic/tclHash.c +++ b/generic/tclHash.c @@ -685,21 +685,16 @@ AllocArrayEntry( Tcl_HashTable *tablePtr, /* Hash table. */ void *keyPtr) /* Key to store in the hash table entry. */ { - int *array = (int *) keyPtr; - int *iPtr1, *iPtr2; Tcl_HashEntry *hPtr; - int count = tablePtr->keyType; - TCL_HASH_TYPE size = sizeof(Tcl_HashEntry) + (count*sizeof(int)) - sizeof(hPtr->key); + TCL_HASH_TYPE count = tablePtr->keyType * sizeof(int); + TCL_HASH_TYPE size = offsetof(Tcl_HashEntry, key) + count; if (size < sizeof(Tcl_HashEntry)) { size = sizeof(Tcl_HashEntry); } hPtr = (Tcl_HashEntry *)ckalloc(size); - for (iPtr1 = array, iPtr2 = hPtr->key.words; - count > 0; count--, iPtr1++, iPtr2++) { - *iPtr2 = *iPtr1; - } + memcpy(hPtr->key.string, keyPtr, count); Tcl_SetHashValue(hPtr, NULL); return hPtr; @@ -727,20 +722,9 @@ CompareArrayKeys( void *keyPtr, /* New key to compare. */ Tcl_HashEntry *hPtr) /* Existing key to compare. */ { - const int *iPtr1 = (const int *)keyPtr; - const int *iPtr2 = hPtr->key.words; - Tcl_HashTable *tablePtr = hPtr->tablePtr; - int count; + size_t count = hPtr->tablePtr->keyType * sizeof(int); - for (count = tablePtr->keyType; ; count--, iPtr1++, iPtr2++) { - if (count == 0) { - return 1; - } - if (*iPtr1 != *iPtr2) { - break; - } - } - return 0; + return !memcmp(keyPtr, hPtr->key.string, count); } /* @@ -807,7 +791,7 @@ AllocStringEntry( allocsize = sizeof(hPtr->key); } hPtr = (Tcl_HashEntry *)ckalloc(offsetof(Tcl_HashEntry, key) + allocsize); - memset(hPtr, 0, sizeof(Tcl_HashEntry) + allocsize - sizeof(hPtr->key)); + memset(hPtr, 0, offsetof(Tcl_HashEntry, key) + allocsize); memcpy(hPtr->key.string, string, size); Tcl_SetHashValue(hPtr, NULL); return hPtr; diff --git a/generic/tclProc.c b/generic/tclProc.c index e6b1372..9a3785c 100644 --- a/generic/tclProc.c +++ b/generic/tclProc.c @@ -2163,7 +2163,7 @@ TclProcCleanupProc( if (bodyPtr != NULL) { /* procPtr is stored in body's ByteCode, so ensure to reset it. */ ByteCode *codePtr; - + ByteCodeGetInternalRep(bodyPtr, &tclByteCodeType, codePtr); if (codePtr != NULL && codePtr->procPtr == procPtr) { codePtr->procPtr = NULL; -- cgit v0.12 From c1b4a8688f530f2fb6ab049c3304c1d11e385ebc Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 26 Aug 2022 22:47:05 +0000 Subject: Use TclOffset() in stead of magic calculations using sizeof(), which might give unexpected results when padding is involved --- generic/tclDisassemble.c | 2 +- generic/tclExecute.c | 4 ++-- generic/tclHash.c | 4 ++-- 3 files changed, 5 insertions(+), 5 deletions(-) diff --git a/generic/tclDisassemble.c b/generic/tclDisassemble.c index 6f463ca..4a61f69 100644 --- a/generic/tclDisassemble.c +++ b/generic/tclDisassemble.c @@ -296,7 +296,7 @@ DisassembleByteCodeObj( Tcl_AppendPrintfToObj(bufferObj, " Code %lu = header %lu+inst %d+litObj %lu+exc %lu+aux %lu+cmdMap %d\n", (unsigned long) codePtr->structureSize, - (unsigned long) (sizeof(ByteCode) - sizeof(size_t) - sizeof(Tcl_Time)), + (unsigned long) (TclOffset(ByteCode, localCachePtr)), codePtr->numCodeBytes, (unsigned long) (codePtr->numLitObjects * sizeof(Tcl_Obj *)), (unsigned long) (codePtr->numExceptRanges*sizeof(ExceptionRange)), diff --git a/generic/tclExecute.c b/generic/tclExecute.c index 25b9409..a16334a 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -9629,7 +9629,7 @@ PrintByteCodeInfo( #ifdef TCL_COMPILE_STATS fprintf(stdout, " Code %lu = header %lu+inst %d+litObj %lu+exc %lu+aux %lu+cmdMap %d\n", (unsigned long) codePtr->structureSize, - (unsigned long) (sizeof(ByteCode)-sizeof(size_t)-sizeof(Tcl_Time)), + (unsigned long) (TclOffset(ByteCode, localCachePtr)), codePtr->numCodeBytes, (unsigned long) (codePtr->numLitObjects * sizeof(Tcl_Obj *)), (unsigned long) (codePtr->numExceptRanges*sizeof(ExceptionRange)), @@ -10272,7 +10272,7 @@ EvalStatsCmd( numCurrentByteCodes = statsPtr->numCompilations - statsPtr->numByteCodesFreed; currentHeaderBytes = numCurrentByteCodes - * (sizeof(ByteCode) - sizeof(size_t) - sizeof(Tcl_Time)); + * (TclOffset(ByteCode, localCachePtr)); literalMgmtBytes = sizeof(LiteralTable) + (iPtr->literalTable.numBuckets * sizeof(LiteralEntry *)) + (iPtr->literalTable.numEntries * sizeof(LiteralEntry)); diff --git a/generic/tclHash.c b/generic/tclHash.c index 5de8168..709831d 100644 --- a/generic/tclHash.c +++ b/generic/tclHash.c @@ -722,7 +722,7 @@ AllocArrayEntry( count = tablePtr->keyType; - size = sizeof(Tcl_HashEntry) + (count*sizeof(int)) - sizeof(hPtr->key); + size = TclOffset(Tcl_HashEntry, key) + count*sizeof(int); if (size < sizeof(Tcl_HashEntry)) { size = sizeof(Tcl_HashEntry); } @@ -839,7 +839,7 @@ AllocStringEntry( allocsize = sizeof(hPtr->key); } hPtr = ckalloc(TclOffset(Tcl_HashEntry, key) + allocsize); - memset(hPtr, 0, sizeof(Tcl_HashEntry) + allocsize - sizeof(hPtr->key)); + memset(hPtr, 0, TclOffset(Tcl_HashEntry, key) + allocsize); memcpy(hPtr->key.string, string, size); hPtr->clientData = 0; return hPtr; -- cgit v0.12 From 5e5b9a09942ea8a669f9652d4ede50a0afcc10b3 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 26 Aug 2022 23:11:44 +0000 Subject: [37108037b9]: Apply patch 0005 for CHERI --- generic/tclTest.c | 47 ++++++++++++++++++++++++++++++++++++++++------- 1 file changed, 40 insertions(+), 7 deletions(-) diff --git a/generic/tclTest.c b/generic/tclTest.c index ed5f34b..9284969 100644 --- a/generic/tclTest.c +++ b/generic/tclTest.c @@ -61,6 +61,21 @@ static Tcl_DString delString; static Tcl_Interp *delInterp; /* + * One of the following structures exists for each command created by the + * "testcmdtoken" command. + */ + +typedef struct TestCommandTokenRef { + int id; /* Identifier for this reference. */ + Tcl_Command token; /* Tcl's token for the command. */ + struct TestCommandTokenRef *nextPtr; + /* Next in list of references. */ +} TestCommandTokenRef; + +static TestCommandTokenRef *firstCommandTokenRef = NULL; +static int nextCommandTokenRefId = 1; + +/* * One of the following structures exists for each asynchronous handler * created by the "testasync" command". */ @@ -1196,9 +1211,9 @@ TestcmdtokenCmd( int argc, /* Number of arguments. */ const char **argv) /* Argument strings. */ { - Tcl_Command token; - int *l; + TestCommandTokenRef *refPtr; char buf[30]; + int id; if (argc != 3) { Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], @@ -1206,24 +1221,42 @@ TestcmdtokenCmd( return TCL_ERROR; } if (strcmp(argv[1], "create") == 0) { - token = Tcl_CreateCommand(interp, argv[2], CmdProc1, + refPtr = (TestCommandTokenRef *)Tcl_Alloc(sizeof(TestCommandTokenRef)); + refPtr->token = Tcl_CreateCommand(interp, argv[2], CmdProc1, (void *) "original", NULL); - sprintf(buf, "%p", (void *)token); + refPtr->id = nextCommandTokenRefId; + nextCommandTokenRefId++; + refPtr->nextPtr = firstCommandTokenRef; + firstCommandTokenRef = refPtr; + sprintf(buf, "%d", refPtr->id); Tcl_AppendResult(interp, buf, NULL); } else if (strcmp(argv[1], "name") == 0) { Tcl_Obj *objPtr; - if (sscanf(argv[2], "%p", &l) != 1) { + if (sscanf(argv[2], "%d", &id) != 1) { + Tcl_AppendResult(interp, "bad command token \"", argv[2], + "\"", NULL); + return TCL_ERROR; + } + + for (refPtr = firstCommandTokenRef; refPtr != NULL; + refPtr = refPtr->nextPtr) { + if (refPtr->id == id) { + break; + } + } + + if (refPtr == NULL) { Tcl_AppendResult(interp, "bad command token \"", argv[2], "\"", NULL); return TCL_ERROR; } objPtr = Tcl_NewObj(); - Tcl_GetCommandFullName(interp, (Tcl_Command) l, objPtr); + Tcl_GetCommandFullName(interp, refPtr->token, objPtr); Tcl_AppendElement(interp, - Tcl_GetCommandName(interp, (Tcl_Command) l)); + Tcl_GetCommandName(interp, refPtr->token)); Tcl_AppendElement(interp, Tcl_GetString(objPtr)); Tcl_DecrRefCount(objPtr); } else { -- cgit v0.12 From 8c034cf9ce62c27025614676e999df1db4e75686 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 29 Aug 2022 09:56:51 +0000 Subject: Remove TODO's already done. Only use ListSizeT for types which are 'size_t' in the Tcl 9 implementation --- generic/tclInt.h | 6 +++--- generic/tclListObj.c | 30 ++++++++++-------------------- 2 files changed, 13 insertions(+), 23 deletions(-) diff --git a/generic/tclInt.h b/generic/tclInt.h index ae88cfe..29fa847 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -2437,18 +2437,18 @@ typedef enum TclEolTranslation { #define TCL_INVOKE_NO_TRACEBACK (1<<2) /* - * TclListSizeT is the type for holding list element counts. It's defined + * ListSizeT is the type for holding list element counts. It's defined * simplify sharing source between Tcl8 and Tcl9. */ #if TCL_MAJOR_VERSION > 8 -typedef ptrdiff_t ListSizeT; /* TODO - may need to fix to match Tcl9's API */ +typedef size_t ListSizeT; /* * SSIZE_MAX, NOT SIZE_MAX as negative differences need to be expressed * between values of the ListSizeT type so limit the range to signed */ -#define ListSizeT_MAX PTRDIFF_MAX +#define ListSizeT_MAX ((ListSizeT)PTRDIFF_MAX) #else diff --git a/generic/tclListObj.c b/generic/tclListObj.c index 5100159..0d3b5a0 100644 --- a/generic/tclListObj.c +++ b/generic/tclListObj.c @@ -919,14 +919,6 @@ ListRepInit( { ListStore *storePtr; - /* - * The whole list implementation has an implicit assumption that lenths - * and indices used a signed integer type. Tcl9 API's currently use - * unsigned types. This assert is to remind that need to review code - * when adapting for Tcl9. - */ - LIST_ASSERT(((ListSizeT)-1) < 0); - storePtr = ListStoreNew(objc, objv, flags); if (storePtr) { repPtr->storePtr = storePtr; @@ -2078,12 +2070,12 @@ Tcl_ListObjReplace( { ListRep listRep; ListSizeT origListLen; - ListSizeT lenChange; - ListSizeT leadSegmentLen; - ListSizeT tailSegmentLen; + int lenChange; + int leadSegmentLen; + int tailSegmentLen; ListSizeT numFreeSlots; - ListSizeT leadShift; - ListSizeT tailShift; + int leadShift; + int tailShift; Tcl_Obj **listObjs; int favor; @@ -2386,9 +2378,9 @@ Tcl_ListObjReplace( * or need to shift both. In the former case, favor shifting the * smaller segment. */ - ListSizeT leadSpace = ListRepNumFreeHead(&listRep); - ListSizeT tailSpace = ListRepNumFreeTail(&listRep); - ListSizeT finalFreeSpace = leadSpace + tailSpace - lenChange; + int leadSpace = ListRepNumFreeHead(&listRep); + int tailSpace = ListRepNumFreeTail(&listRep); + int finalFreeSpace = leadSpace + tailSpace - lenChange; LIST_ASSERT((leadSpace + tailSpace) >= lenChange); if (leadSpace >= lenChange @@ -2405,7 +2397,7 @@ Tcl_ListObjReplace( * insertions. */ if (finalFreeSpace > 1 && (tailSpace == 0 || tailSegmentLen == 0)) { - ListSizeT postShiftLeadSpace = leadSpace - lenChange; + int postShiftLeadSpace = leadSpace - lenChange; if (postShiftLeadSpace > (finalFreeSpace/2)) { ListSizeT extraShift = postShiftLeadSpace - (finalFreeSpace / 2); leadShift -= extraShift; @@ -2422,7 +2414,7 @@ Tcl_ListObjReplace( * See comments above. This is analogous. */ if (finalFreeSpace > 1 && (leadSpace == 0 || leadSegmentLen == 0)) { - ListSizeT postShiftTailSpace = tailSpace - lenChange; + int postShiftTailSpace = tailSpace - lenChange; if (postShiftTailSpace > (finalFreeSpace/2)) { /* T:listrep-1.{1,3,14,18,21},3.{2,3,26,27} */ ListSizeT extraShift = postShiftTailSpace - (finalFreeSpace / 2); @@ -3431,11 +3423,9 @@ UpdateStringOfList( elem = TclGetStringFromObj(elemPtrs[i], &length); bytesNeeded += TclScanElement(elem, length, flagPtr+i); if (bytesNeeded < 0) { - /* TODO - what is the max #define for Tcl9? */ Tcl_Panic("max size for a Tcl value (%d bytes) exceeded", INT_MAX); } } - /* TODO - what is the max #define for Tcl9? */ if (bytesNeeded > INT_MAX - numElems + 1) { Tcl_Panic("max size for a Tcl value (%d bytes) exceeded", INT_MAX); } -- cgit v0.12 From b0aac11cdb0e31babc4c89aeda27223f4a731162 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 29 Aug 2022 20:53:44 +0000 Subject: Add 2 unused (internal) stub entries --- generic/tclInt.decls | 2 +- generic/tclIntDecls.h | 9 ++++++--- generic/tclStubInit.c | 3 ++- 3 files changed, 9 insertions(+), 5 deletions(-) diff --git a/generic/tclInt.decls b/generic/tclInt.decls index df39bef..b76d06b 100644 --- a/generic/tclInt.decls +++ b/generic/tclInt.decls @@ -957,7 +957,7 @@ declare 257 { Tcl_PackageInitProc *initProc, Tcl_PackageInitProc *safeInitProc) } -declare 260 { +declare 261 { void TclUnusedStubEntry(void) } diff --git a/generic/tclIntDecls.h b/generic/tclIntDecls.h index 4d98d00..a8bb18e 100644 --- a/generic/tclIntDecls.h +++ b/generic/tclIntDecls.h @@ -1078,9 +1078,10 @@ EXTERN void TclStaticPackage(Tcl_Interp *interp, #endif /* Slot 258 is reserved */ /* Slot 259 is reserved */ +/* Slot 260 is reserved */ #ifndef TclUnusedStubEntry_TCL_DECLARED #define TclUnusedStubEntry_TCL_DECLARED -/* 260 */ +/* 261 */ EXTERN void TclUnusedStubEntry(void); #endif @@ -1348,7 +1349,8 @@ typedef struct TclIntStubs { void (*tclStaticPackage) (Tcl_Interp *interp, CONST char *pkgName, Tcl_PackageInitProc *initProc, Tcl_PackageInitProc *safeInitProc); /* 257 */ VOID *reserved258; VOID *reserved259; - void (*tclUnusedStubEntry) (void); /* 260 */ + VOID *reserved260; + void (*tclUnusedStubEntry) (void); /* 261 */ } TclIntStubs; extern TclIntStubs *tclIntStubsPtr; @@ -2094,9 +2096,10 @@ extern TclIntStubs *tclIntStubsPtr; #endif /* Slot 258 is reserved */ /* Slot 259 is reserved */ +/* Slot 260 is reserved */ #ifndef TclUnusedStubEntry #define TclUnusedStubEntry \ - (tclIntStubsPtr->tclUnusedStubEntry) /* 260 */ + (tclIntStubsPtr->tclUnusedStubEntry) /* 261 */ #endif #endif /* defined(USE_TCL_STUBS) && !defined(USE_TCL_STUB_PROCS) */ diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c index 0bebc15..0d2a3c2 100644 --- a/generic/tclStubInit.c +++ b/generic/tclStubInit.c @@ -561,7 +561,8 @@ TclIntStubs tclIntStubs = { TclStaticPackage, /* 257 */ NULL, /* 258 */ NULL, /* 259 */ - TclUnusedStubEntry, /* 260 */ + NULL, /* 260 */ + TclUnusedStubEntry, /* 261 */ }; TclIntPlatStubs tclIntPlatStubs = { -- cgit v0.12 From 1aa64a54f72a97753e3cc7e75eb93ac625d66a33 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 29 Aug 2022 22:48:41 +0000 Subject: [37108037b9], patch 0004 --- generic/tclExecute.c | 18 +++++++++--------- 1 file changed, 9 insertions(+), 9 deletions(-) diff --git a/generic/tclExecute.c b/generic/tclExecute.c index 8ca56c9..af93636 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -169,11 +169,11 @@ static BuiltinFunc const tclBuiltinFuncTable[] = { typedef struct TEBCdata { ByteCode *codePtr; /* Constant until the BC returns */ /* -----------------------------------------*/ - ptrdiff_t *catchTop; /* These fields are used on return TO this */ + Tcl_Obj **catchTop; /* These fields are used on return TO this */ Tcl_Obj *auxObjList; /* this level: they record the state when a */ CmdFrame cmdFrame; /* new codePtr was received for NR */ /* execution. */ - void *stack[1]; /* Start of the actual combined catch and obj + Tcl_Obj *stack[1]; /* Start of the actual combined catch and obj * stacks; the struct will be expanded as * necessary */ } TEBCdata; @@ -1935,8 +1935,8 @@ ArgumentBCEnter( *---------------------------------------------------------------------- */ #define bcFramePtr (&TD->cmdFrame) -#define initCatchTop ((ptrdiff_t *) (TD->stack-1)) -#define initTosPtr ((Tcl_Obj **) (initCatchTop+codePtr->maxExceptDepth)) +#define initCatchTop (TD->stack-1) +#define initTosPtr (initCatchTop+codePtr->maxExceptDepth) #define esPtr (iPtr->execEnvPtr->execStackPtr) int @@ -6805,7 +6805,7 @@ TEBCresume( * stack. */ - *(++catchTop) = CURR_DEPTH; + *(++catchTop) = INT2PTR(CURR_DEPTH); TRACE(("%u => catchTop=%d, stackTop=%d\n", TclGetUInt4AtPtr(pc+1), (int) (catchTop - initCatchTop - 1), (int) CURR_DEPTH)); @@ -7717,8 +7717,8 @@ TEBCresume( while (auxObjList) { if ((catchTop != initCatchTop) - && (*catchTop > (ptrdiff_t) - auxObjList->internalRep.twoPtrValue.ptr2)) { + && (PTR2INT(*catchTop) > + PTR2INT(auxObjList->internalRep.twoPtrValue.ptr2))) { break; } POP_TAUX_OBJ(); @@ -7793,7 +7793,7 @@ TEBCresume( */ processCatch: - while (CURR_DEPTH > *catchTop) { + while (CURR_DEPTH > PTR2INT(*catchTop)) { valuePtr = POP_OBJECT(); TclDecrRefCount(valuePtr); } @@ -7802,7 +7802,7 @@ TEBCresume( fprintf(stdout, " ... found catch at %d, catchTop=%d, " "unwound to %ld, new pc %u\n", rangePtr->codeOffset, (int) (catchTop - initCatchTop - 1), - (long)*catchTop, (unsigned) rangePtr->catchOffset); + (long)PTR2INT(*catchTop), (unsigned) rangePtr->catchOffset); } #endif pc = (codePtr->codeStart + rangePtr->catchOffset); -- cgit v0.12 From b3500c7657421cc9309d8b22a9e40b8d70bd2d00 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 30 Aug 2022 06:53:35 +0000 Subject: gcc warning (-Wc++-compat) --- generic/tclExecute.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/generic/tclExecute.c b/generic/tclExecute.c index af93636..91cce46 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -6805,7 +6805,7 @@ TEBCresume( * stack. */ - *(++catchTop) = INT2PTR(CURR_DEPTH); + *(++catchTop) = (Tcl_Obj *)INT2PTR(CURR_DEPTH); TRACE(("%u => catchTop=%d, stackTop=%d\n", TclGetUInt4AtPtr(pc+1), (int) (catchTop - initCatchTop - 1), (int) CURR_DEPTH)); -- cgit v0.12 From 33fa3f7f1fd8342215ce4fe948434c6c87274deb Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 30 Aug 2022 22:30:20 +0000 Subject: More code cleanup, inspired by [37108037b9] --- generic/tclExecute.c | 78 ++++++++++++++++++++++++++-------------------------- 1 file changed, 39 insertions(+), 39 deletions(-) diff --git a/generic/tclExecute.c b/generic/tclExecute.c index 91cce46..27ebeec 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -424,7 +424,7 @@ VarHashCreateVar( #define OBJ_AT_DEPTH(n) *(tosPtr-(n)) -#define CURR_DEPTH ((ptrdiff_t) (tosPtr - initTosPtr)) +#define CURR_DEPTH ((size_t)(tosPtr - initTosPtr)) #define STACK_BASE(esPtr) ((esPtr)->stackWords - 1) @@ -437,9 +437,9 @@ VarHashCreateVar( #ifdef TCL_COMPILE_DEBUG # define TRACE(a) \ while (traceInstructions) { \ - fprintf(stdout, "%2d: %2d (%u) %s ", iPtr->numLevels, \ - (int) CURR_DEPTH, \ - (unsigned) (pc - codePtr->codeStart), \ + fprintf(stdout, "%2d: %2" TCL_Z_MODIFIER "u (%" TCL_Z_MODIFIER "u) %s ", iPtr->numLevels, \ + CURR_DEPTH, \ + (size_t)(pc - codePtr->codeStart), \ GetOpcodeName(pc)); \ printf a; \ break; \ @@ -453,9 +453,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, \ - (int) CURR_DEPTH, \ - (unsigned) (pc - codePtr->codeStart), \ + fprintf(stdout, "%2d: %2" TCL_Z_MODIFIER "u (%" TCL_Z_MODIFIER "u) %s ", iPtr->numLevels, \ + CURR_DEPTH, \ + (size_t)(pc - codePtr->codeStart), \ GetOpcodeName(pc)); \ printf a; \ TclPrintObject(stdout, objPtr, 30); \ @@ -678,7 +678,7 @@ static const char * GetOpcodeName(const unsigned char *pc); static void PrintByteCodeInfo(ByteCode *codePtr); static const char * StringForResultCode(int result); static void ValidatePcAndStackTop(ByteCode *codePtr, - const unsigned char *pc, int stackTop, + const unsigned char *pc, size_t stackTop, int checkStack); #endif /* TCL_COMPILE_DEBUG */ static ByteCode * CompileExprObj(Tcl_Interp *interp, Tcl_Obj *objPtr); @@ -2007,7 +2007,7 @@ TclNRExecuteByteCode( */ TclNRAddCallback(interp, TEBCresume, TD, /* pc */ NULL, - /* cleanup */ INT2PTR(0), INT2PTR(iPtr->evalFlags)); + /* cleanup */ NULL, INT2PTR(iPtr->evalFlags)); /* * Reset discard result flag - because it is applicable for this call only, @@ -2123,7 +2123,7 @@ TEBCresume( #ifdef TCL_COMPILE_DEBUG if (!pc && (tclTraceExec >= 2)) { PrintByteCodeInfo(codePtr); - fprintf(stdout, " Starting stack top=%d\n", (int) CURR_DEPTH); + fprintf(stdout, " Starting stack top=%" TCL_Z_MODIFIER "u\n", CURR_DEPTH); fflush(stdout); } #endif @@ -2327,7 +2327,7 @@ TEBCresume( CHECK_STACK(); if (traceInstructions) { - fprintf(stdout, "%2d: %2d ", iPtr->numLevels, (int) CURR_DEPTH); + fprintf(stdout, "%2d: %2" TCL_Z_MODIFIER "u ", iPtr->numLevels, CURR_DEPTH); TclPrintInstruction(codePtr, pc); fflush(stdout); } @@ -2694,10 +2694,10 @@ TEBCresume( */ TclNewObj(objPtr); - objPtr->internalRep.twoPtrValue.ptr2 = INT2PTR(CURR_DEPTH); + objPtr->internalRep.twoPtrValue.ptr2 = UINT2PTR(CURR_DEPTH); objPtr->length = 0; PUSH_TAUX_OBJ(objPtr); - TRACE(("=> mark depth as %d\n", (int) CURR_DEPTH)); + TRACE(("=> mark depth as %" TCL_Z_MODIFIER "u\n", CURR_DEPTH)); NEXT_INST_F(1, 0, 0); break; @@ -2709,7 +2709,7 @@ TEBCresume( */ CLANG_ASSERT(auxObjList); - objc = CURR_DEPTH - PTR2INT(auxObjList->internalRep.twoPtrValue.ptr2); + objc = CURR_DEPTH - PTR2UINT(auxObjList->internalRep.twoPtrValue.ptr2); POP_TAUX_OBJ(); #ifdef TCL_COMPILE_DEBUG /* Ugly abuse! */ @@ -2813,7 +2813,7 @@ TEBCresume( case INST_INVOKE_EXPANDED: CLANG_ASSERT(auxObjList); - objc = CURR_DEPTH - PTR2INT(auxObjList->internalRep.twoPtrValue.ptr2); + objc = CURR_DEPTH - PTR2UINT(auxObjList->internalRep.twoPtrValue.ptr2); POP_TAUX_OBJ(); if (objc) { pcAdjustment = 1; @@ -5998,7 +5998,7 @@ TEBCresume( * Handle shifts within the native long range. */ - if (((size_t) shift < CHAR_BIT*sizeof(long)) + if (((size_t)shift < CHAR_BIT*sizeof(long)) && !((w1>0 ? w1 : ~w1) & -(1UL<<(CHAR_BIT*sizeof(long) - 1 - shift)))) { wResult = (Tcl_WideUInt)w1 << shift; @@ -6805,10 +6805,10 @@ TEBCresume( * stack. */ - *(++catchTop) = (Tcl_Obj *)INT2PTR(CURR_DEPTH); - TRACE(("%u => catchTop=%d, stackTop=%d\n", - TclGetUInt4AtPtr(pc+1), (int) (catchTop - initCatchTop - 1), - (int) CURR_DEPTH)); + *(++catchTop) = (Tcl_Obj *)UINT2PTR(CURR_DEPTH); + TRACE(("%u => catchTop=%" TCL_Z_MODIFIER "u, stackTop=%" TCL_Z_MODIFIER "u\n", + TclGetUInt4AtPtr(pc+1), (size_t)(catchTop - initCatchTop - 1), + CURR_DEPTH)); NEXT_INST_F(5, 0, 0); break; @@ -6818,7 +6818,7 @@ TEBCresume( Tcl_ResetResult(interp); CACHE_STACK_INFO(); result = TCL_OK; - TRACE(("=> catchTop=%d\n", (int) (catchTop - initCatchTop - 1))); + TRACE(("=> catchTop=%" TCL_Z_MODIFIER "u\n", (size_t)(catchTop - initCatchTop - 1))); NEXT_INST_F(1, 0, 0); break; @@ -7717,8 +7717,8 @@ TEBCresume( while (auxObjList) { if ((catchTop != initCatchTop) - && (PTR2INT(*catchTop) > - PTR2INT(auxObjList->internalRep.twoPtrValue.ptr2))) { + && (PTR2UINT(*catchTop) > + PTR2UINT(auxObjList->internalRep.twoPtrValue.ptr2))) { break; } POP_TAUX_OBJ(); @@ -7793,16 +7793,16 @@ TEBCresume( */ processCatch: - while (CURR_DEPTH > PTR2INT(*catchTop)) { + while (CURR_DEPTH > PTR2UINT(*catchTop)) { valuePtr = POP_OBJECT(); TclDecrRefCount(valuePtr); } #ifdef TCL_COMPILE_DEBUG if (traceInstructions) { - fprintf(stdout, " ... found catch at %d, catchTop=%d, " - "unwound to %ld, new pc %u\n", - rangePtr->codeOffset, (int) (catchTop - initCatchTop - 1), - (long)PTR2INT(*catchTop), (unsigned) rangePtr->catchOffset); + fprintf(stdout, " ... found catch at %d, catchTop=%" TCL_Z_MODIFIER "u, " + "unwound to %" TCL_Z_MODIFIER "u, new pc %" TCL_Z_MODIFIER "u\n", + rangePtr->codeOffset, (size_t)(catchTop - initCatchTop - 1), + PTR2UINT(*catchTop), (size_t)rangePtr->catchOffset); } #endif pc = (codePtr->codeStart + rangePtr->catchOffset); @@ -7838,10 +7838,10 @@ TEBCresume( if (tosPtr < initTosPtr) { fprintf(stderr, - "\nTclNRExecuteByteCode: abnormal return at pc %u: " - "stack top %d < entry stack top %d\n", - (unsigned)(pc - codePtr->codeStart), - (unsigned) CURR_DEPTH, (unsigned) 0); + "\nTclNRExecuteByteCode: abnormal return at pc %" TCL_Z_MODIFIER "u: " + "stack top %" TCL_Z_MODIFIER "u < entry stack top %d\n", + (size_t)(pc - codePtr->codeStart), + CURR_DEPTH, 0); Tcl_Panic("TclNRExecuteByteCode execution failure: end stack top < start stack top"); } CLANG_ASSERT(bcFramePtr); @@ -9122,21 +9122,21 @@ ValidatePcAndStackTop( * stdout. */ const unsigned char *pc, /* Points to first byte of a bytecode * instruction. The program counter. */ - int stackTop, /* Current stack top. Must be between + size_t stackTop, /* Current stack top. Must be between * stackLowerBound and stackUpperBound * (inclusive). */ int checkStack) /* 0 if the stack depth check should be * skipped. */ { - int stackUpperBound = codePtr->maxStackDepth; + size_t stackUpperBound = codePtr->maxStackDepth; /* Greatest legal value for stackTop. */ - size_t relativePc = (size_t) (pc - codePtr->codeStart); - size_t codeStart = (size_t) codePtr->codeStart; + size_t relativePc = (size_t)(pc - codePtr->codeStart); + size_t codeStart = (size_t)codePtr->codeStart; size_t codeEnd = (size_t) (codePtr->codeStart + codePtr->numCodeBytes); unsigned char opCode = *pc; - if (((size_t) pc < codeStart) || ((size_t) pc > codeEnd)) { + if ((PTR2UINT(pc) < codeStart) || (PTR2UINT(pc) > codeEnd)) { fprintf(stderr, "\nBad instruction pc 0x%p in TclNRExecuteByteCode\n", pc); Tcl_Panic("TclNRExecuteByteCode execution failure: bad pc"); @@ -9147,11 +9147,11 @@ ValidatePcAndStackTop( Tcl_Panic("TclNRExecuteByteCode execution failure: bad opcode"); } if (checkStack && - ((stackTop < 0) || (stackTop > stackUpperBound))) { + (stackTop > stackUpperBound)) { int numChars; const char *cmd = GetSrcInfoForPc(pc, codePtr, &numChars, NULL, NULL); - fprintf(stderr, "\nBad stack top %d at pc %" TCL_Z_MODIFIER "u in TclNRExecuteByteCode (min 0, max %i)", + fprintf(stderr, "\nBad stack top %" TCL_Z_MODIFIER "u at pc %" TCL_Z_MODIFIER "u in TclNRExecuteByteCode (min 0, max %" TCL_Z_MODIFIER "u)", stackTop, relativePc, stackUpperBound); if (cmd != NULL) { Tcl_Obj *message; -- cgit v0.12 From 4f320507252b9d045785f3606b57bd776c30f64b Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 30 Aug 2022 23:02:16 +0000 Subject: Apply patch 0006 from [37108037b9]: Code cleanups to support CHERI --- generic/tclExecute.c | 17 ++++++++++------- 1 file changed, 10 insertions(+), 7 deletions(-) diff --git a/generic/tclExecute.c b/generic/tclExecute.c index 27ebeec..8aa3bb2 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -2720,7 +2720,8 @@ TEBCresume( case INST_EXPAND_STKTOP: { int i; - ptrdiff_t moved; + TEBCdata *newTD; + ptrdiff_t oldCatchTopOff, oldTosPtrOff; /* * Make sure that the element at stackTop is a list; if not, just @@ -2749,19 +2750,21 @@ TEBCresume( + codePtr->maxStackDepth /* Beyond the original max */ - CURR_DEPTH; /* Relative to where we are */ DECACHE_STACK_INFO(); - moved = GrowEvaluationStack(iPtr->execEnvPtr, length, 1) - - (Tcl_Obj **) TD; - if (moved) { + oldCatchTopOff = catchTop - initCatchTop; + oldTosPtrOff = tosPtr - initTosPtr; + newTD = (TEBCdata *) + GrowEvaluationStack(iPtr->execEnvPtr, length, 1); + if (newTD != TD) { /* * Change the global data to point to the new stack: move the * TEBCdataPtr TD, recompute the position of every other * stack-allocated parameter, update the stack pointers. */ - TD = (TEBCdata *) (((Tcl_Obj **)TD) + moved); + TD = newTD; - catchTop += moved; - tosPtr += moved; + catchTop = initCatchTop + oldCatchTopOff; + tosPtr = initTosPtr + oldTosPtrOff; } } -- cgit v0.12 From 78e661957cafca9e2f11726f4bbdded4e824d53f Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 31 Aug 2022 10:00:33 +0000 Subject: Fix [0aa7638534]: .gitignore ignores library/tcltest.tcl --- .gitignore | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.gitignore b/.gitignore index 74bf502..504f1e4 100644 --- a/.gitignore +++ b/.gitignore @@ -26,7 +26,7 @@ manifest.uuid _FOSSIL_ */tclConfig.sh */tclsh* -*/tcltest* +*/tcltest */versions.vc */version.vc */libtcl.vfs -- cgit v0.12 From e1d37a6c49a751970baba2aed8e4b824744b7e8f Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 1 Sep 2022 14:49:57 +0000 Subject: Change refCount (in ListStore/ListSpan) to size_t. More ClientData -> void *. Eliminate warning about unused functions --- generic/tclInt.h | 276 +++++++++++++++++++++++++-------------------------- generic/tclListObj.c | 23 +---- 2 files changed, 140 insertions(+), 159 deletions(-) diff --git a/generic/tclInt.h b/generic/tclInt.h index 29fa847..a7c5c2c 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -1439,7 +1439,7 @@ typedef int (CompileProc)(Tcl_Interp *interp, Tcl_Parse *parsePtr, */ typedef int (CompileHookProc)(Tcl_Interp *interp, - struct CompileEnv *compEnvPtr, ClientData clientData); + struct CompileEnv *compEnvPtr, void *clientData); /* * The data structure for a (linked list of) execution stacks. @@ -2486,7 +2486,7 @@ typedef struct ListStore { ListSizeT firstUsed; /* Index of first slot in use within slots[] */ ListSizeT numUsed; /* Number of slots in use (starting firstUsed) */ ListSizeT numAllocated; /* Total number of slots[] array slots. */ - int refCount; /* Number of references to this instance */ + size_t refCount; /* Number of references to this instance */ int flags; /* LISTSTORE_* flags */ Tcl_Obj *slots[TCLFLEXARRAY]; /* Variable size array. Grown as needed */ } ListStore; @@ -2510,7 +2510,7 @@ typedef struct ListStore { typedef struct ListSpan { ListSizeT spanStart; /* Starting index of the span */ ListSizeT spanLength; /* Number of elements in the span */ - int refCount; /* Count of references to this span record */ + size_t refCount; /* Count of references to this span record */ } ListSpan; #ifndef LIST_SPAN_THRESHOLD /* May be set on build line */ #define LIST_SPAN_THRESHOLD 101 @@ -2747,7 +2747,7 @@ typedef struct ListRep { */ #define TCL_FILESYSTEM_VERSION_2 ((Tcl_FSVersion) 0x2) -typedef ClientData (TclFSGetCwdProc2)(ClientData clientData); +typedef void *(TclFSGetCwdProc2)(void *clientData); typedef int (Tcl_FSLoadFileProc2) (Tcl_Interp *interp, Tcl_Obj *pathPtr, Tcl_LoadHandle *handlePtr, Tcl_FSUnloadFileProc **unloadProcPtr, int flags); @@ -2909,7 +2909,7 @@ MODULE_SCOPE Tcl_Encoding tclIdentityEncoding; MODULE_SCOPE Tcl_GetTimeProc *tclGetTimeProcPtr; MODULE_SCOPE Tcl_ScaleTimeProc *tclScaleTimeProcPtr; -MODULE_SCOPE ClientData tclTimeClientData; +MODULE_SCOPE void *tclTimeClientData; /* * Variables denoting the Tcl object types defined in the core. @@ -3085,7 +3085,7 @@ MODULE_SCOPE void TclArgumentBCRelease(Tcl_Interp *interp, MODULE_SCOPE void TclArgumentGet(Tcl_Interp *interp, Tcl_Obj *obj, CmdFrame **cfPtrPtr, int *wordPtr); MODULE_SCOPE int TclAsyncNotifier(int sigNumber, Tcl_ThreadId threadId, - ClientData clientData, int *flagPtr, int value); + void *clientData, int *flagPtr, int value); MODULE_SCOPE void TclAsyncMarkFromNotifier(void); MODULE_SCOPE double TclBignumToDouble(const void *bignum); MODULE_SCOPE int TclByteArrayMatch(const unsigned char *string, @@ -3116,7 +3116,7 @@ MODULE_SCOPE int TclConvertElement(const char *src, int length, char *dst, int flags); MODULE_SCOPE Tcl_Command TclCreateObjCommandInNs(Tcl_Interp *interp, const char *cmdName, Tcl_Namespace *nsPtr, - Tcl_ObjCmdProc *proc, ClientData clientData, + Tcl_ObjCmdProc *proc, void *clientData, Tcl_CmdDeleteProc *deleteProc); MODULE_SCOPE Tcl_Command TclCreateEnsembleInNs(Tcl_Interp *interp, const char *name, Tcl_Namespace *nameNamespacePtr, @@ -3141,9 +3141,9 @@ MODULE_SCOPE Tcl_ObjCmdProc TclFileRenameCmd; MODULE_SCOPE Tcl_ObjCmdProc TclFileTempDirCmd; MODULE_SCOPE Tcl_ObjCmdProc TclFileTemporaryCmd; MODULE_SCOPE void TclCreateLateExitHandler(Tcl_ExitProc *proc, - ClientData clientData); + void *clientData); MODULE_SCOPE void TclDeleteLateExitHandler(Tcl_ExitProc *proc, - ClientData clientData); + void *clientData); MODULE_SCOPE char * TclDStringAppendObj(Tcl_DString *dsPtr, Tcl_Obj *objPtr); MODULE_SCOPE char * TclDStringAppendDString(Tcl_DString *dsPtr, @@ -3198,7 +3198,7 @@ MODULE_SCOPE int TclGetCompletionCodeFromObj(Tcl_Interp *interp, MODULE_SCOPE Proc * TclGetLambdaFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr, Tcl_Obj **nsObjPtrPtr); MODULE_SCOPE int TclGetNumberFromObj(Tcl_Interp *interp, - Tcl_Obj *objPtr, ClientData *clientDataPtr, + Tcl_Obj *objPtr, void **clientDataPtr, int *typePtr); MODULE_SCOPE int TclGetOpenModeEx(Tcl_Interp *interp, const char *modeString, int *seekFlagPtr, @@ -3220,16 +3220,16 @@ MODULE_SCOPE int TclIncrObj(Tcl_Interp *interp, Tcl_Obj *valuePtr, Tcl_Obj *incrPtr); MODULE_SCOPE Tcl_Obj * TclIncrObjVar2(Tcl_Interp *interp, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, Tcl_Obj *incrPtr, int flags); -MODULE_SCOPE int TclInfoExistsCmd(ClientData dummy, Tcl_Interp *interp, +MODULE_SCOPE int TclInfoExistsCmd(void *dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); -MODULE_SCOPE int TclInfoCoroutineCmd(ClientData dummy, Tcl_Interp *interp, +MODULE_SCOPE int TclInfoCoroutineCmd(void *dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); MODULE_SCOPE Tcl_Obj * TclInfoFrame(Tcl_Interp *interp, CmdFrame *framePtr); -MODULE_SCOPE int TclInfoGlobalsCmd(ClientData dummy, Tcl_Interp *interp, +MODULE_SCOPE int TclInfoGlobalsCmd(void *dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); -MODULE_SCOPE int TclInfoLocalsCmd(ClientData dummy, Tcl_Interp *interp, +MODULE_SCOPE int TclInfoLocalsCmd(void *dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); -MODULE_SCOPE int TclInfoVarsCmd(ClientData dummy, Tcl_Interp *interp, +MODULE_SCOPE int TclInfoVarsCmd(void *dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); MODULE_SCOPE void TclInitAlloc(void); MODULE_SCOPE void TclInitDbCkalloc(void); @@ -3304,18 +3304,18 @@ MODULE_SCOPE Tcl_Obj * TclpTempFileNameForLibrary(Tcl_Interp *interp, Tcl_Obj* pathPtr); MODULE_SCOPE Tcl_Obj * TclNewFSPathObj(Tcl_Obj *dirPtr, const char *addStrRep, int len); -MODULE_SCOPE void TclpAlertNotifier(ClientData clientData); -MODULE_SCOPE ClientData TclpNotifierData(void); +MODULE_SCOPE void TclpAlertNotifier(void *clientData); +MODULE_SCOPE void *TclpNotifierData(void); MODULE_SCOPE void TclpServiceModeHook(int mode); MODULE_SCOPE void TclpSetTimer(const Tcl_Time *timePtr); MODULE_SCOPE int TclpWaitForEvent(const Tcl_Time *timePtr); MODULE_SCOPE void TclpCreateFileHandler(int fd, int mask, - Tcl_FileProc *proc, ClientData clientData); + Tcl_FileProc *proc, void *clientData); MODULE_SCOPE int TclpDeleteFile(const void *path); MODULE_SCOPE void TclpDeleteFileHandler(int fd); MODULE_SCOPE void TclpFinalizeCondition(Tcl_Condition *condPtr); MODULE_SCOPE void TclpFinalizeMutex(Tcl_Mutex *mutexPtr); -MODULE_SCOPE void TclpFinalizeNotifier(ClientData clientData); +MODULE_SCOPE void TclpFinalizeNotifier(void *clientData); MODULE_SCOPE void TclpFinalizePipes(void); MODULE_SCOPE void TclpFinalizeSockets(void); MODULE_SCOPE int TclCreateSocketAddress(Tcl_Interp *interp, @@ -3323,13 +3323,13 @@ MODULE_SCOPE int TclCreateSocketAddress(Tcl_Interp *interp, const char *host, int port, int willBind, const char **errorMsgPtr); MODULE_SCOPE int TclpThreadCreate(Tcl_ThreadId *idPtr, - Tcl_ThreadCreateProc *proc, ClientData clientData, + Tcl_ThreadCreateProc *proc, void *clientData, int stackSize, int flags); MODULE_SCOPE int TclpFindVariable(const char *name, int *lengthPtr); MODULE_SCOPE void TclpInitLibraryPath(char **valuePtr, TCL_HASH_TYPE *lengthPtr, Tcl_Encoding *encodingPtr); MODULE_SCOPE void TclpInitLock(void); -MODULE_SCOPE ClientData TclpInitNotifier(void); +MODULE_SCOPE void *TclpInitNotifier(void); MODULE_SCOPE void TclpInitPlatform(void); MODULE_SCOPE void TclpInitUnlock(void); MODULE_SCOPE Tcl_Obj * TclpObjListVolumes(void); @@ -3348,7 +3348,7 @@ MODULE_SCOPE int TclCrossFilesystemCopy(Tcl_Interp *interp, MODULE_SCOPE int TclpMatchInDirectory(Tcl_Interp *interp, Tcl_Obj *resultPtr, Tcl_Obj *pathPtr, const char *pattern, Tcl_GlobTypeData *types); -MODULE_SCOPE ClientData TclpGetNativeCwd(ClientData clientData); +MODULE_SCOPE void *TclpGetNativeCwd(void *clientData); MODULE_SCOPE Tcl_FSDupInternalRepProc TclNativeDupInternalRep; MODULE_SCOPE Tcl_Obj * TclpObjLink(Tcl_Obj *pathPtr, Tcl_Obj *toPtr, int linkType); @@ -3437,7 +3437,7 @@ MODULE_SCOPE int TclUtfCount(int ch); MODULE_SCOPE int TclUniCharToUCS4(const Tcl_UniChar *, int *); MODULE_SCOPE const Tcl_UniChar *TclUCS4Prev(const Tcl_UniChar *, const Tcl_UniChar *); #endif -MODULE_SCOPE Tcl_Obj * TclpNativeToNormalized(ClientData clientData); +MODULE_SCOPE Tcl_Obj * TclpNativeToNormalized(void *clientData); MODULE_SCOPE Tcl_Obj * TclpFilesystemPathType(Tcl_Obj *pathPtr); MODULE_SCOPE int TclpDlopen(Tcl_Interp *interp, Tcl_Obj *pathPtr, Tcl_LoadHandle *loadHandle, @@ -3533,60 +3533,60 @@ MODULE_SCOPE int TclIsSpaceProc(int byte); *---------------------------------------------------------------- */ -MODULE_SCOPE int Tcl_AfterObjCmd(ClientData clientData, +MODULE_SCOPE int Tcl_AfterObjCmd(void *clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_AppendObjCmd(ClientData clientData, +MODULE_SCOPE int Tcl_AppendObjCmd(void *clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_ApplyObjCmd(ClientData clientData, +MODULE_SCOPE int Tcl_ApplyObjCmd(void *clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); MODULE_SCOPE Tcl_Command TclInitArrayCmd(Tcl_Interp *interp); MODULE_SCOPE Tcl_Command TclInitBinaryCmd(Tcl_Interp *interp); -MODULE_SCOPE int Tcl_BreakObjCmd(ClientData clientData, +MODULE_SCOPE int Tcl_BreakObjCmd(void *clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); #if !defined(TCL_NO_DEPRECATED) -MODULE_SCOPE int Tcl_CaseObjCmd(ClientData clientData, +MODULE_SCOPE int Tcl_CaseObjCmd(void *clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); #endif -MODULE_SCOPE int Tcl_CatchObjCmd(ClientData clientData, +MODULE_SCOPE int Tcl_CatchObjCmd(void *clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_CdObjCmd(ClientData clientData, +MODULE_SCOPE int Tcl_CdObjCmd(void *clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); MODULE_SCOPE Tcl_Command TclInitChanCmd(Tcl_Interp *interp); -MODULE_SCOPE int TclChanCreateObjCmd(ClientData clientData, +MODULE_SCOPE int TclChanCreateObjCmd(void *clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); -MODULE_SCOPE int TclChanPostEventObjCmd(ClientData clientData, +MODULE_SCOPE int TclChanPostEventObjCmd(void *clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); -MODULE_SCOPE int TclChanPopObjCmd(ClientData clientData, +MODULE_SCOPE int TclChanPopObjCmd(void *clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); -MODULE_SCOPE int TclChanPushObjCmd(ClientData clientData, +MODULE_SCOPE int TclChanPushObjCmd(void *clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); MODULE_SCOPE void TclClockInit(Tcl_Interp *interp); MODULE_SCOPE int TclClockOldscanObjCmd( void *clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_CloseObjCmd(ClientData clientData, +MODULE_SCOPE int Tcl_CloseObjCmd(void *clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_ConcatObjCmd(ClientData clientData, +MODULE_SCOPE int Tcl_ConcatObjCmd(void *clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_ContinueObjCmd(ClientData clientData, +MODULE_SCOPE int Tcl_ContinueObjCmd(void *clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); MODULE_SCOPE Tcl_TimerToken TclCreateAbsoluteTimerHandler( Tcl_Time *timePtr, Tcl_TimerProc *proc, - ClientData clientData); + void *clientData); MODULE_SCOPE int TclDefaultBgErrorHandlerObjCmd( - ClientData clientData, Tcl_Interp *interp, + void *clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); MODULE_SCOPE Tcl_Command TclInitDictCmd(Tcl_Interp *interp); MODULE_SCOPE int TclDictWithFinish(Tcl_Interp *interp, Var *varPtr, @@ -3595,236 +3595,236 @@ MODULE_SCOPE int TclDictWithFinish(Tcl_Interp *interp, Var *varPtr, Tcl_Obj *const pathv[], Tcl_Obj *keysPtr); MODULE_SCOPE Tcl_Obj * TclDictWithInit(Tcl_Interp *interp, Tcl_Obj *dictPtr, int pathc, Tcl_Obj *const pathv[]); -MODULE_SCOPE int Tcl_DisassembleObjCmd(ClientData clientData, +MODULE_SCOPE int Tcl_DisassembleObjCmd(void *clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); /* Assemble command function */ -MODULE_SCOPE int Tcl_AssembleObjCmd(ClientData clientData, +MODULE_SCOPE int Tcl_AssembleObjCmd(void *clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); -MODULE_SCOPE int TclNRAssembleObjCmd(ClientData clientData, +MODULE_SCOPE int TclNRAssembleObjCmd(void *clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); MODULE_SCOPE Tcl_Command TclInitEncodingCmd(Tcl_Interp *interp); -MODULE_SCOPE int Tcl_EofObjCmd(ClientData clientData, +MODULE_SCOPE int Tcl_EofObjCmd(void *clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_ErrorObjCmd(ClientData clientData, +MODULE_SCOPE int Tcl_ErrorObjCmd(void *clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_EvalObjCmd(ClientData clientData, +MODULE_SCOPE int Tcl_EvalObjCmd(void *clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_ExecObjCmd(ClientData clientData, +MODULE_SCOPE int Tcl_ExecObjCmd(void *clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_ExitObjCmd(ClientData clientData, +MODULE_SCOPE int Tcl_ExitObjCmd(void *clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_ExprObjCmd(ClientData clientData, +MODULE_SCOPE int Tcl_ExprObjCmd(void *clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_FblockedObjCmd(ClientData clientData, +MODULE_SCOPE int Tcl_FblockedObjCmd(void *clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); MODULE_SCOPE int Tcl_FconfigureObjCmd( - ClientData clientData, Tcl_Interp *interp, + void *clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_FcopyObjCmd(ClientData dummy, +MODULE_SCOPE int Tcl_FcopyObjCmd(void *dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); MODULE_SCOPE Tcl_Command TclInitFileCmd(Tcl_Interp *interp); -MODULE_SCOPE int Tcl_FileEventObjCmd(ClientData clientData, +MODULE_SCOPE int Tcl_FileEventObjCmd(void *clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_FlushObjCmd(ClientData clientData, +MODULE_SCOPE int Tcl_FlushObjCmd(void *clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_ForObjCmd(ClientData clientData, +MODULE_SCOPE int Tcl_ForObjCmd(void *clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_ForeachObjCmd(ClientData clientData, +MODULE_SCOPE int Tcl_ForeachObjCmd(void *clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_FormatObjCmd(ClientData dummy, +MODULE_SCOPE int Tcl_FormatObjCmd(void *dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_GetsObjCmd(ClientData clientData, +MODULE_SCOPE int Tcl_GetsObjCmd(void *clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_GlobalObjCmd(ClientData clientData, +MODULE_SCOPE int Tcl_GlobalObjCmd(void *clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_GlobObjCmd(ClientData clientData, +MODULE_SCOPE int Tcl_GlobObjCmd(void *clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_IfObjCmd(ClientData clientData, +MODULE_SCOPE int Tcl_IfObjCmd(void *clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_IncrObjCmd(ClientData clientData, +MODULE_SCOPE int Tcl_IncrObjCmd(void *clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); MODULE_SCOPE Tcl_Command TclInitInfoCmd(Tcl_Interp *interp); -MODULE_SCOPE int Tcl_InterpObjCmd(ClientData clientData, +MODULE_SCOPE int Tcl_InterpObjCmd(void *clientData, Tcl_Interp *interp, int argc, Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_JoinObjCmd(ClientData clientData, +MODULE_SCOPE int Tcl_JoinObjCmd(void *clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_LappendObjCmd(ClientData clientData, +MODULE_SCOPE int Tcl_LappendObjCmd(void *clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_LassignObjCmd(ClientData clientData, +MODULE_SCOPE int Tcl_LassignObjCmd(void *clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_LindexObjCmd(ClientData clientData, +MODULE_SCOPE int Tcl_LindexObjCmd(void *clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_LinsertObjCmd(ClientData clientData, +MODULE_SCOPE int Tcl_LinsertObjCmd(void *clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_LlengthObjCmd(ClientData clientData, +MODULE_SCOPE int Tcl_LlengthObjCmd(void *clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_ListObjCmd(ClientData clientData, +MODULE_SCOPE int Tcl_ListObjCmd(void *clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_LmapObjCmd(ClientData clientData, +MODULE_SCOPE int Tcl_LmapObjCmd(void *clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_LoadObjCmd(ClientData clientData, +MODULE_SCOPE int Tcl_LoadObjCmd(void *clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_LpopObjCmd(ClientData clientData, +MODULE_SCOPE int Tcl_LpopObjCmd(void *clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_LrangeObjCmd(ClientData clientData, +MODULE_SCOPE int Tcl_LrangeObjCmd(void *clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_LremoveObjCmd(ClientData clientData, +MODULE_SCOPE int Tcl_LremoveObjCmd(void *clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_LrepeatObjCmd(ClientData clientData, +MODULE_SCOPE int Tcl_LrepeatObjCmd(void *clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_LreplaceObjCmd(ClientData clientData, +MODULE_SCOPE int Tcl_LreplaceObjCmd(void *clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_LreverseObjCmd(ClientData clientData, +MODULE_SCOPE int Tcl_LreverseObjCmd(void *clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_LsearchObjCmd(ClientData clientData, +MODULE_SCOPE int Tcl_LsearchObjCmd(void *clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_LsetObjCmd(ClientData clientData, +MODULE_SCOPE int Tcl_LsetObjCmd(void *clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_LsortObjCmd(ClientData clientData, +MODULE_SCOPE int Tcl_LsortObjCmd(void *clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); MODULE_SCOPE Tcl_Command TclInitNamespaceCmd(Tcl_Interp *interp); -MODULE_SCOPE int TclNamespaceEnsembleCmd(ClientData dummy, +MODULE_SCOPE int TclNamespaceEnsembleCmd(void *dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_OpenObjCmd(ClientData clientData, +MODULE_SCOPE int Tcl_OpenObjCmd(void *clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_PackageObjCmd(ClientData clientData, +MODULE_SCOPE int Tcl_PackageObjCmd(void *clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_PidObjCmd(ClientData clientData, +MODULE_SCOPE int Tcl_PidObjCmd(void *clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); MODULE_SCOPE Tcl_Command TclInitPrefixCmd(Tcl_Interp *interp); -MODULE_SCOPE int Tcl_PutsObjCmd(ClientData clientData, +MODULE_SCOPE int Tcl_PutsObjCmd(void *clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_PwdObjCmd(ClientData clientData, +MODULE_SCOPE int Tcl_PwdObjCmd(void *clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_ReadObjCmd(ClientData clientData, +MODULE_SCOPE int Tcl_ReadObjCmd(void *clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_RegexpObjCmd(ClientData clientData, +MODULE_SCOPE int Tcl_RegexpObjCmd(void *clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_RegsubObjCmd(ClientData clientData, +MODULE_SCOPE int Tcl_RegsubObjCmd(void *clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_RenameObjCmd(ClientData clientData, +MODULE_SCOPE int Tcl_RenameObjCmd(void *clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_RepresentationCmd(ClientData clientData, +MODULE_SCOPE int Tcl_RepresentationCmd(void *clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_ReturnObjCmd(ClientData clientData, +MODULE_SCOPE int Tcl_ReturnObjCmd(void *clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_ScanObjCmd(ClientData clientData, +MODULE_SCOPE int Tcl_ScanObjCmd(void *clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_SeekObjCmd(ClientData clientData, +MODULE_SCOPE int Tcl_SeekObjCmd(void *clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_SetObjCmd(ClientData clientData, +MODULE_SCOPE int Tcl_SetObjCmd(void *clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_SplitObjCmd(ClientData clientData, +MODULE_SCOPE int Tcl_SplitObjCmd(void *clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_SocketObjCmd(ClientData clientData, +MODULE_SCOPE int Tcl_SocketObjCmd(void *clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_SourceObjCmd(ClientData clientData, +MODULE_SCOPE int Tcl_SourceObjCmd(void *clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); MODULE_SCOPE Tcl_Command TclInitStringCmd(Tcl_Interp *interp); -MODULE_SCOPE int Tcl_SubstObjCmd(ClientData clientData, +MODULE_SCOPE int Tcl_SubstObjCmd(void *clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_SwitchObjCmd(ClientData clientData, +MODULE_SCOPE int Tcl_SwitchObjCmd(void *clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_TellObjCmd(ClientData clientData, +MODULE_SCOPE int Tcl_TellObjCmd(void *clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_ThrowObjCmd(ClientData dummy, Tcl_Interp *interp, +MODULE_SCOPE int Tcl_ThrowObjCmd(void *dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_TimeObjCmd(ClientData clientData, +MODULE_SCOPE int Tcl_TimeObjCmd(void *clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_TimeRateObjCmd(ClientData clientData, +MODULE_SCOPE int Tcl_TimeRateObjCmd(void *clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_TraceObjCmd(ClientData clientData, +MODULE_SCOPE int Tcl_TraceObjCmd(void *clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_TryObjCmd(ClientData clientData, +MODULE_SCOPE int Tcl_TryObjCmd(void *clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_UnloadObjCmd(ClientData clientData, +MODULE_SCOPE int Tcl_UnloadObjCmd(void *clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_UnsetObjCmd(ClientData clientData, +MODULE_SCOPE int Tcl_UnsetObjCmd(void *clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_UpdateObjCmd(ClientData clientData, +MODULE_SCOPE int Tcl_UpdateObjCmd(void *clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_UplevelObjCmd(ClientData clientData, +MODULE_SCOPE int Tcl_UplevelObjCmd(void *clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_UpvarObjCmd(ClientData clientData, +MODULE_SCOPE int Tcl_UpvarObjCmd(void *clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_VariableObjCmd(ClientData clientData, +MODULE_SCOPE int Tcl_VariableObjCmd(void *clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_VwaitObjCmd(ClientData clientData, +MODULE_SCOPE int Tcl_VwaitObjCmd(void *clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_WhileObjCmd(ClientData clientData, +MODULE_SCOPE int Tcl_WhileObjCmd(void *clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); @@ -4156,103 +4156,103 @@ MODULE_SCOPE int TclCompileBasicMin2ArgCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); -MODULE_SCOPE int TclInvertOpCmd(ClientData clientData, +MODULE_SCOPE int TclInvertOpCmd(void *clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); MODULE_SCOPE int TclCompileInvertOpCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); -MODULE_SCOPE int TclNotOpCmd(ClientData clientData, +MODULE_SCOPE int TclNotOpCmd(void *clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); MODULE_SCOPE int TclCompileNotOpCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); -MODULE_SCOPE int TclAddOpCmd(ClientData clientData, +MODULE_SCOPE int TclAddOpCmd(void *clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); MODULE_SCOPE int TclCompileAddOpCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); -MODULE_SCOPE int TclMulOpCmd(ClientData clientData, +MODULE_SCOPE int TclMulOpCmd(void *clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); MODULE_SCOPE int TclCompileMulOpCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); -MODULE_SCOPE int TclAndOpCmd(ClientData clientData, +MODULE_SCOPE int TclAndOpCmd(void *clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); MODULE_SCOPE int TclCompileAndOpCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); -MODULE_SCOPE int TclOrOpCmd(ClientData clientData, +MODULE_SCOPE int TclOrOpCmd(void *clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); MODULE_SCOPE int TclCompileOrOpCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); -MODULE_SCOPE int TclXorOpCmd(ClientData clientData, +MODULE_SCOPE int TclXorOpCmd(void *clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); MODULE_SCOPE int TclCompileXorOpCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); -MODULE_SCOPE int TclPowOpCmd(ClientData clientData, +MODULE_SCOPE int TclPowOpCmd(void *clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); MODULE_SCOPE int TclCompilePowOpCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); -MODULE_SCOPE int TclLshiftOpCmd(ClientData clientData, +MODULE_SCOPE int TclLshiftOpCmd(void *clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); MODULE_SCOPE int TclCompileLshiftOpCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); -MODULE_SCOPE int TclRshiftOpCmd(ClientData clientData, +MODULE_SCOPE int TclRshiftOpCmd(void *clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); MODULE_SCOPE int TclCompileRshiftOpCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); -MODULE_SCOPE int TclModOpCmd(ClientData clientData, +MODULE_SCOPE int TclModOpCmd(void *clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); MODULE_SCOPE int TclCompileModOpCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); -MODULE_SCOPE int TclNeqOpCmd(ClientData clientData, +MODULE_SCOPE int TclNeqOpCmd(void *clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); MODULE_SCOPE int TclCompileNeqOpCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); -MODULE_SCOPE int TclStrneqOpCmd(ClientData clientData, +MODULE_SCOPE int TclStrneqOpCmd(void *clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); MODULE_SCOPE int TclCompileStrneqOpCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); -MODULE_SCOPE int TclInOpCmd(ClientData clientData, +MODULE_SCOPE int TclInOpCmd(void *clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); MODULE_SCOPE int TclCompileInOpCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); -MODULE_SCOPE int TclNiOpCmd(ClientData clientData, +MODULE_SCOPE int TclNiOpCmd(void *clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); MODULE_SCOPE int TclCompileNiOpCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); -MODULE_SCOPE int TclMinusOpCmd(ClientData clientData, +MODULE_SCOPE int TclMinusOpCmd(void *clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); MODULE_SCOPE int TclCompileMinusOpCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); -MODULE_SCOPE int TclDivOpCmd(ClientData clientData, +MODULE_SCOPE int TclDivOpCmd(void *clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); MODULE_SCOPE int TclCompileDivOpCmd(Tcl_Interp *interp, @@ -5336,7 +5336,7 @@ void Tcl_Panic(const char *, ...) __attribute__((analyzer_noreturn)); typedef struct NRE_callback { Tcl_NRPostProc *procPtr; - ClientData data[4]; + void *data[4]; struct NRE_callback *nextPtr; } NRE_callback; @@ -5351,10 +5351,10 @@ typedef struct NRE_callback { NRE_callback *_callbackPtr; \ TCLNR_ALLOC((interp), (_callbackPtr)); \ _callbackPtr->procPtr = (postProcPtr); \ - _callbackPtr->data[0] = (ClientData)(data0); \ - _callbackPtr->data[1] = (ClientData)(data1); \ - _callbackPtr->data[2] = (ClientData)(data2); \ - _callbackPtr->data[3] = (ClientData)(data3); \ + _callbackPtr->data[0] = (void *)(data0); \ + _callbackPtr->data[1] = (void *)(data1); \ + _callbackPtr->data[2] = (void *)(data2); \ + _callbackPtr->data[3] = (void *)(data3); \ _callbackPtr->nextPtr = TOP_CB(interp); \ TOP_CB(interp) = _callbackPtr; \ } while (0) @@ -5410,8 +5410,8 @@ typedef struct NRE_callback { * Other externals. */ -MODULE_SCOPE size_t TclEnvEpoch; /* Epoch of the tcl environment - * (if changed with tcl-env). */ +MODULE_SCOPE size_t TclEnvEpoch; /* Epoch of the tcl environment + * (if changed with tcl-env). */ #endif /* _TCLINT */ diff --git a/generic/tclListObj.c b/generic/tclListObj.c index 0d3b5a0..7a702e0 100644 --- a/generic/tclListObj.c +++ b/generic/tclListObj.c @@ -249,27 +249,6 @@ ListSpanNew( /* *------------------------------------------------------------------------ * - * ListSpanIncrRefs -- - * - * Increments the reference count on the spanPtr - * - * Results: - * None. - * - * Side effects: - * The obvious. - * - *------------------------------------------------------------------------ - */ -static inline void -ListSpanIncrRefs(ListSpan *spanPtr) -{ - spanPtr->refCount += 1; -} - -/* - *------------------------------------------------------------------------ - * * ListSpanDecrRefs -- * * Decrements the reference count on a span, freeing the memory if @@ -620,6 +599,7 @@ ListRepUnsharedShiftDown(ListRep *repPtr, ListSizeT shiftCount) * *------------------------------------------------------------------------ */ +#if 0 static inline void ListRepUnsharedShiftUp(ListRep *repPtr, ListSizeT shiftCount) { @@ -648,6 +628,7 @@ ListRepUnsharedShiftUp(ListRep *repPtr, ListSizeT shiftCount) LISTREP_CHECK(repPtr); } +#endif /* *------------------------------------------------------------------------ -- cgit v0.12 From 2ad836a4e03d557997264f6e8647abcb34cdaa64 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 1 Sep 2022 15:40:55 +0000 Subject: Fix [36ec49db6abc3b1a]: Tcl_TraceVar manpage : missing `const` on char* fields --- doc/TraceVar.3 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/doc/TraceVar.3 b/doc/TraceVar.3 index c3edfa4..3d506b3 100644 --- a/doc/TraceVar.3 +++ b/doc/TraceVar.3 @@ -126,8 +126,8 @@ It should have arguments and result that match the type typedef char *\fBTcl_VarTraceProc\fR( ClientData \fIclientData\fR, Tcl_Interp *\fIinterp\fR, - char *\fIname1\fR, - char *\fIname2\fR, + const char *\fIname1\fR, + const char *\fIname2\fR, int \fIflags\fR); .CE .PP -- cgit v0.12 From 9cc16840e841d6cf4f857d9853838cd86f42b48d Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 2 Sep 2022 12:32:10 +0000 Subject: -1 -> TCL_INDEX_NONE, where appropriate --- generic/tclTest.c | 174 +++++++++++++++++++++++++++++------------------------- 1 file changed, 92 insertions(+), 82 deletions(-) diff --git a/generic/tclTest.c b/generic/tclTest.c index 8d106f9..d13b7ce 100644 --- a/generic/tclTest.c +++ b/generic/tclTest.c @@ -560,6 +560,12 @@ Tcltest_Init( } if (Tcl_GetCommandInfo(interp, "::tcl::build-info", &info)) { +#if TCL_MAJOR_VERSION > 8 + if (info.isNativeObjectProc == 2) { + Tcl_CreateObjCommand2(interp, "::tcl::test::build-info", + info.objProc2, (void *)version, NULL); + } else +#endif Tcl_CreateObjCommand(interp, "::tcl::test::build-info", info.objProc, (void *)version, NULL); } @@ -772,7 +778,7 @@ Tcltest_Init( return TCL_ERROR; } case 3: - if (objc-1) { + if (objc > 1) { Tcl_SetVar2Ex(interp, "tcl_rcFileName", NULL, objv[1], TCL_GLOBAL_ONLY); } @@ -817,6 +823,12 @@ Tcltest_SafeInit( return TCL_ERROR; } if (Tcl_GetCommandInfo(interp, "::tcl::build-info", &info)) { +#if TCL_MAJOR_VERSION > 8 + if (info.isNativeObjectProc == 2) { + Tcl_CreateObjCommand2(interp, "::tcl::test::build-info", + info.objProc2, (void *)version, NULL); + } else +#endif Tcl_CreateObjCommand(interp, "::tcl::test::build-info", info.objProc, (void *)version, NULL); } @@ -927,7 +939,7 @@ TestasyncCmd( break; } } - Tcl_SetObjResult(interp, Tcl_NewStringObj(argv[3], -1)); + Tcl_SetObjResult(interp, Tcl_NewStringObj(argv[3], TCL_INDEX_NONE)); Tcl_MutexUnlock(&asyncTestMutex); return code; } else if (strcmp(argv[1], "marklater") == 0) { @@ -995,7 +1007,7 @@ AsyncHandlerProc( listArgv[3] = NULL; cmd = Tcl_Merge(3, listArgv); if (interp != NULL) { - code = Tcl_EvalEx(interp, cmd, -1, 0); + code = Tcl_EvalEx(interp, cmd, TCL_INDEX_NONE, 0); } else { /* * this should not happen, but by definition of how async handlers are @@ -1176,8 +1188,8 @@ CmdDelProc1( void *clientData) /* String to save. */ { Tcl_DStringInit(&delString); - Tcl_DStringAppend(&delString, "CmdDelProc1 ", -1); - Tcl_DStringAppend(&delString, (char *) clientData, -1); + Tcl_DStringAppend(&delString, "CmdDelProc1 ", TCL_INDEX_NONE); + Tcl_DStringAppend(&delString, (char *) clientData, TCL_INDEX_NONE); } static void @@ -1185,8 +1197,8 @@ CmdDelProc2( void *clientData) /* String to save. */ { Tcl_DStringInit(&delString); - Tcl_DStringAppend(&delString, "CmdDelProc2 ", -1); - Tcl_DStringAppend(&delString, (char *) clientData, -1); + Tcl_DStringAppend(&delString, "CmdDelProc2 ", TCL_INDEX_NONE); + Tcl_DStringAppend(&delString, (char *) clientData, TCL_INDEX_NONE); } /* @@ -1306,7 +1318,7 @@ TestcmdtraceCmd( if (strcmp(argv[1], "tracetest") == 0) { Tcl_DStringInit(&buffer); cmdTrace = Tcl_CreateTrace(interp, 50000, CmdTraceProc, &buffer); - result = Tcl_EvalEx(interp, argv[2], -1, 0); + result = Tcl_EvalEx(interp, argv[2], TCL_INDEX_NONE, 0); if (result == TCL_OK) { Tcl_ResetResult(interp); Tcl_AppendResult(interp, Tcl_DStringValue(&buffer), NULL); @@ -1322,13 +1334,13 @@ TestcmdtraceCmd( */ cmdTrace = Tcl_CreateTrace(interp, 50000, CmdTraceDeleteProc, NULL); - Tcl_EvalEx(interp, argv[2], -1, 0); + Tcl_EvalEx(interp, argv[2], TCL_INDEX_NONE, 0); } else if (strcmp(argv[1], "leveltest") == 0) { Interp *iPtr = (Interp *) interp; Tcl_DStringInit(&buffer); cmdTrace = Tcl_CreateTrace(interp, iPtr->numLevels + 4, CmdTraceProc, &buffer); - result = Tcl_EvalEx(interp, argv[2], -1, 0); + result = Tcl_EvalEx(interp, argv[2], TCL_INDEX_NONE, 0); if (result == TCL_OK) { Tcl_ResetResult(interp); Tcl_AppendResult(interp, Tcl_DStringValue(&buffer), NULL); @@ -1346,7 +1358,7 @@ TestcmdtraceCmd( cmdTrace = Tcl_CreateObjTrace(interp, 50000, TCL_ALLOW_INLINE_COMPILATION, ObjTraceProc, &deleteCalled, ObjTraceDeleteProc); - result = Tcl_EvalEx(interp, argv[2], -1, 0); + result = Tcl_EvalEx(interp, argv[2], TCL_INDEX_NONE, 0); Tcl_DeleteTrace(interp, cmdTrace); if (!deleteCalled) { Tcl_AppendResult(interp, "Delete wasn't called", NULL); @@ -1360,7 +1372,7 @@ TestcmdtraceCmd( Tcl_DStringInit(&buffer); t1 = Tcl_CreateTrace(interp, 1, CmdTraceProc, &buffer); t2 = Tcl_CreateTrace(interp, 50000, CmdTraceProc, &buffer); - result = Tcl_EvalEx(interp, argv[2], -1, 0); + result = Tcl_EvalEx(interp, argv[2], TCL_INDEX_NONE, 0); if (result == TCL_OK) { Tcl_ResetResult(interp); Tcl_AppendResult(interp, Tcl_DStringValue(&buffer), NULL); @@ -1435,7 +1447,7 @@ ObjTraceProc( const char *word = Tcl_GetString(objv[0]); if (!strcmp(word, "Error")) { - Tcl_SetObjResult(interp, Tcl_NewStringObj(command, -1)); + Tcl_SetObjResult(interp, Tcl_NewStringObj(command, TCL_INDEX_NONE)); return TCL_ERROR; } else if (!strcmp(word, "Break")) { return TCL_BREAK; @@ -1684,7 +1696,7 @@ DelDeleteProc( { DelCmd *dPtr = (DelCmd *)clientData; - Tcl_EvalEx(dPtr->interp, dPtr->deleteCmd, -1, 0); + Tcl_EvalEx(dPtr->interp, dPtr->deleteCmd, TCL_INDEX_NONE, 0); Tcl_ResetResult(dPtr->interp); ckfree(dPtr->deleteCmd); ckfree(dPtr); @@ -1799,7 +1811,7 @@ TestdoubledigitsObjCmd( type = types[type]; if (objc > 4) { if (strcmp(Tcl_GetString(objv[4]), "shorten")) { - Tcl_SetObjResult(interp, Tcl_NewStringObj("bad flag", -1)); + Tcl_SetObjResult(interp, Tcl_NewStringObj("bad flag", TCL_INDEX_NONE)); return TCL_ERROR; } type |= TCL_DD_SHORTEST; @@ -2043,7 +2055,7 @@ EncodingToUtfProc( TclEncoding *encodingPtr; encodingPtr = (TclEncoding *) clientData; - Tcl_EvalEx(encodingPtr->interp, encodingPtr->toUtfCmd, -1, TCL_EVAL_GLOBAL); + Tcl_EvalEx(encodingPtr->interp, encodingPtr->toUtfCmd, TCL_INDEX_NONE, TCL_EVAL_GLOBAL); len = strlen(Tcl_GetStringResult(encodingPtr->interp)); if (len > dstLen) { @@ -2075,7 +2087,7 @@ EncodingFromUtfProc( TclEncoding *encodingPtr; encodingPtr = (TclEncoding *) clientData; - Tcl_EvalEx(encodingPtr->interp, encodingPtr->fromUtfCmd, -1, TCL_EVAL_GLOBAL); + Tcl_EvalEx(encodingPtr->interp, encodingPtr->fromUtfCmd, TCL_INDEX_NONE, TCL_EVAL_GLOBAL); len = strlen(Tcl_GetStringResult(encodingPtr->interp)); if (len > dstLen) { @@ -3114,7 +3126,7 @@ TestlinkCmd( } } if (argv[6][0] != 0) { - tmp = Tcl_NewStringObj(argv[6], -1); + tmp = Tcl_NewStringObj(argv[6], TCL_INDEX_NONE); if (Tcl_GetWideIntFromObj(interp, tmp, &wideVar) != TCL_OK) { Tcl_DecrRefCount(tmp); return TCL_ERROR; @@ -3172,7 +3184,7 @@ TestlinkCmd( } if (argv[15][0]) { Tcl_WideInt w; - tmp = Tcl_NewStringObj(argv[15], -1); + tmp = Tcl_NewStringObj(argv[15], TCL_INDEX_NONE); if (Tcl_GetWideIntFromObj(interp, tmp, &w) != TCL_OK) { Tcl_DecrRefCount(tmp); return TCL_ERROR; @@ -3222,7 +3234,7 @@ TestlinkCmd( Tcl_UpdateLinkedVar(interp, "string"); } if (argv[6][0] != 0) { - tmp = Tcl_NewStringObj(argv[6], -1); + tmp = Tcl_NewStringObj(argv[6], TCL_INDEX_NONE); if (Tcl_GetWideIntFromObj(interp, tmp, &wideVar) != TCL_OK) { Tcl_DecrRefCount(tmp); return TCL_ERROR; @@ -3289,7 +3301,7 @@ TestlinkCmd( } if (argv[15][0]) { Tcl_WideInt w; - tmp = Tcl_NewStringObj(argv[15], -1); + tmp = Tcl_NewStringObj(argv[15], TCL_INDEX_NONE); if (Tcl_GetWideIntFromObj(interp, tmp, &w) != TCL_OK) { Tcl_DecrRefCount(tmp); return TCL_ERROR; @@ -3396,7 +3408,7 @@ TestlinkarrayCmd( return TCL_ERROR; } if (Tcl_GetIntFromObj(interp, objv[i++], &size) == TCL_ERROR) { - Tcl_SetObjResult(interp, Tcl_NewStringObj("wrong size value", -1)); + Tcl_SetObjResult(interp, Tcl_NewStringObj("wrong size value", TCL_INDEX_NONE)); return TCL_ERROR; } name = Tcl_GetString(objv[i++]); @@ -3408,7 +3420,7 @@ TestlinkarrayCmd( if (i < objc) { if (Tcl_GetWideIntFromObj(interp, objv[i], &addr) == TCL_ERROR) { Tcl_SetObjResult(interp, Tcl_NewStringObj( - "wrong address value", -1)); + "wrong address value", TCL_INDEX_NONE)); return TCL_ERROR; } } else { @@ -3504,7 +3516,7 @@ TestlistrepCmd( #define APPEND_FIELD(targetObj_, structPtr_, fld_) \ do { \ Tcl_ListObjAppendElement( \ - interp, (targetObj_), Tcl_NewStringObj(#fld_, -1)); \ + interp, (targetObj_), Tcl_NewStringObj(#fld_, TCL_INDEX_NONE)); \ Tcl_ListObjAppendElement( \ interp, (targetObj_), Tcl_NewWideIntObj((structPtr_)->fld_)); \ } while (0) @@ -3522,10 +3534,10 @@ TestlistrepCmd( return TCL_ERROR; } ListObjGetRep(objv[2], &listRep); - listRepObjs[0] = Tcl_NewStringObj("store", -1); + listRepObjs[0] = Tcl_NewStringObj("store", TCL_INDEX_NONE); listRepObjs[1] = Tcl_NewListObj(12, NULL); Tcl_ListObjAppendElement( - interp, listRepObjs[1], Tcl_NewStringObj("memoryAddress", -1)); + interp, listRepObjs[1], Tcl_NewStringObj("memoryAddress", TCL_INDEX_NONE)); Tcl_ListObjAppendElement( interp, listRepObjs[1], Tcl_ObjPrintf("%p", listRep.storePtr)); APPEND_FIELD(listRepObjs[1], listRep.storePtr, firstUsed); @@ -3534,11 +3546,11 @@ TestlistrepCmd( APPEND_FIELD(listRepObjs[1], listRep.storePtr, refCount); APPEND_FIELD(listRepObjs[1], listRep.storePtr, flags); if (listRep.spanPtr) { - listRepObjs[2] = Tcl_NewStringObj("span", -1); + listRepObjs[2] = Tcl_NewStringObj("span", TCL_INDEX_NONE); listRepObjs[3] = Tcl_NewListObj(8, NULL); Tcl_ListObjAppendElement(interp, listRepObjs[3], - Tcl_NewStringObj("memoryAddress", -1)); + Tcl_NewStringObj("memoryAddress", TCL_INDEX_NONE)); Tcl_ListObjAppendElement( interp, listRepObjs[3], Tcl_ObjPrintf("%p", listRep.spanPtr)); APPEND_FIELD(listRepObjs[3], listRep.spanPtr, spanStart); @@ -3558,7 +3570,7 @@ TestlistrepCmd( } resultObj = Tcl_NewListObj(2, NULL); Tcl_ListObjAppendElement( - NULL, resultObj, Tcl_NewStringObj("LIST_SPAN_THRESHOLD", -1)); + NULL, resultObj, Tcl_NewStringObj("LIST_SPAN_THRESHOLD", TCL_INDEX_NONE)); Tcl_ListObjAppendElement( NULL, resultObj, Tcl_NewWideIntObj(LIST_SPAN_THRESHOLD)); break; @@ -3632,7 +3644,7 @@ TestlocaleCmd( } locale = setlocale(lcTypes[index], locale); if (locale) { - Tcl_SetStringObj(Tcl_GetObjResult(interp), locale, -1); + Tcl_SetStringObj(Tcl_GetObjResult(interp), locale, TCL_INDEX_NONE); } return TCL_OK; } @@ -3854,7 +3866,7 @@ PrintParse( break; } Tcl_ListObjAppendElement(NULL, objPtr, - Tcl_NewStringObj(typeString, -1)); + Tcl_NewStringObj(typeString, TCL_INDEX_NONE)); Tcl_ListObjAppendElement(NULL, objPtr, Tcl_NewStringObj(tokenPtr->start, tokenPtr->size)); Tcl_ListObjAppendElement(NULL, objPtr, @@ -3863,7 +3875,7 @@ PrintParse( Tcl_ListObjAppendElement(NULL, objPtr, parsePtr->commandStart ? Tcl_NewStringObj(parsePtr->commandStart + parsePtr->commandSize, - -1) : Tcl_NewObj()); + TCL_INDEX_NONE) : Tcl_NewObj()); } /* @@ -4182,7 +4194,7 @@ TestregexpObjCmd( char resinfo[TCL_INTEGER_SPACE * 2]; varName = Tcl_GetString(objv[2]); - TclRegExpRangeUniChar(regExpr, -1, &start, &end); + TclRegExpRangeUniChar(regExpr, TCL_INDEX_NONE, &start, &end); sprintf(resinfo, "%d %d", start, end-1); value = Tcl_SetVar2(interp, varName, NULL, resinfo, 0); if (value == NULL) { @@ -4222,15 +4234,15 @@ TestregexpObjCmd( Tcl_Obj *newPtr, *varPtr, *valuePtr; varPtr = objv[i]; - ii = ((cflags®_EXPECT) && i == objc-1) ? -1 : i; + ii = ((cflags®_EXPECT) && i == objc-1) ? TCL_INDEX_NONE : i; if (indices) { Tcl_Obj *objs[2]; - if (ii == -1) { + if (ii == TCL_INDEX_NONE) { TclRegExpRangeUniChar(regExpr, ii, &start, &end); } else if (ii > info.nsubs) { - start = -1; - end = -1; + start = TCL_INDEX_NONE; + end = TCL_INDEX_NONE; } else { start = info.matches[ii].start; end = info.matches[ii].end; @@ -4250,7 +4262,7 @@ TestregexpObjCmd( newPtr = Tcl_NewListObj(2, objs); } else { - if (ii == -1) { + if (ii == TCL_INDEX_NONE) { TclRegExpRangeUniChar(regExpr, ii, &start, &end); newPtr = Tcl_GetRange(objPtr, start, end); } else if (ii > info.nsubs || info.matches[ii].end <= 0) { @@ -4298,7 +4310,8 @@ TestregexpXflags( int *cflagsPtr, /* compile flags word */ int *eflagsPtr) /* exec flags word */ { - int i, cflags, eflags; + int i; + int cflags, eflags; cflags = *cflagsPtr; eflags = *eflagsPtr; @@ -4756,7 +4769,7 @@ TestfeventCmd( return TCL_ERROR; } if (interp2 != NULL) { - code = Tcl_EvalEx(interp2, argv[2], -1, TCL_EVAL_GLOBAL); + code = Tcl_EvalEx(interp2, argv[2], TCL_INDEX_NONE, TCL_EVAL_GLOBAL); Tcl_SetObjResult(interp, Tcl_GetObjResult(interp2)); return code; } else { @@ -5050,15 +5063,15 @@ GetTimesObjCmd( ckfree(objv); /* TclGetString 100000 times */ - fprintf(stderr, "TclGetStringFromObj of \"12345\" 100000 times\n"); - objPtr = Tcl_NewStringObj("12345", -1); + fprintf(stderr, "Tcl_GetStringFromObj of \"12345\" 100000 times\n"); + objPtr = Tcl_NewStringObj("12345", TCL_INDEX_NONE); Tcl_GetTime(&start); for (i = 0; i < 100000; i++) { (void) TclGetString(objPtr); } Tcl_GetTime(&stop); timePer = (stop.sec - start.sec)*1000000 + (stop.usec - start.usec); - fprintf(stderr, " %.3f usec per TclGetStringFromObj of \"12345\"\n", + fprintf(stderr, " %.3f usec per Tcl_GetStringFromObj of \"12345\"\n", timePer/100000); /* Tcl_GetIntFromObj 100000 times */ @@ -5398,7 +5411,7 @@ Testutf16stringObjCmd( } p = Tcl_GetUnicode(objv[1]); - Tcl_SetObjResult(interp, Tcl_NewUnicodeObj(p, -1)); + Tcl_SetObjResult(interp, Tcl_NewUnicodeObj(p, TCL_INDEX_NONE)); return TCL_OK; } @@ -5536,7 +5549,7 @@ TestsaveresultCmd( } freeCount = 0; - objPtr = NULL; /* Lint. */ + objPtr = NULL; switch ((enum options) index) { case RESULT_SMALL: Tcl_AppendResult(interp, "small result", NULL); @@ -5555,7 +5568,7 @@ TestsaveresultCmd( Tcl_SetResult(interp, (char *)"dynamic result", TestsaveresultFree); break; case RESULT_OBJECT: - objPtr = Tcl_NewStringObj("object result", -1); + objPtr = Tcl_NewStringObj("object result", TCL_INDEX_NONE); Tcl_SetObjResult(interp, objPtr); break; } @@ -5565,7 +5578,7 @@ TestsaveresultCmd( if (((enum options) index) == RESULT_OBJECT) { result = Tcl_EvalObjEx(interp, objv[2], 0); } else { - result = Tcl_EvalEx(interp, Tcl_GetString(objv[2]), -1, 0); + result = Tcl_EvalEx(interp, Tcl_GetString(objv[2]), TCL_INDEX_NONE, 0); } if (discard) { @@ -5817,7 +5830,7 @@ TestChannelCmd( if ((cmdName[0] == 's') && (strncmp(cmdName, "setchannelerror", len) == 0)) { - Tcl_Obj *msg = Tcl_NewStringObj(argv[3],-1); + Tcl_Obj *msg = Tcl_NewStringObj(argv[3], TCL_INDEX_NONE); Tcl_IncrRefCount(msg); Tcl_SetChannelError(chan, msg); @@ -5830,7 +5843,7 @@ TestChannelCmd( } if ((cmdName[0] == 's') && (strncmp(cmdName, "setchannelerrorinterp", len) == 0)) { - Tcl_Obj *msg = Tcl_NewStringObj(argv[3],-1); + Tcl_Obj *msg = Tcl_NewStringObj(argv[3], TCL_INDEX_NONE); Tcl_IncrRefCount(msg); Tcl_SetChannelErrorInterp(interp, msg); @@ -6178,7 +6191,7 @@ TestChannelCmd( } return TclChannelTransform(interp, chan, - Tcl_NewStringObj(argv[4], -1)); + Tcl_NewStringObj(argv[4], TCL_INDEX_NONE)); } if ((cmdName[0] == 'u') && (strncmp(cmdName, "unstack", len) == 0)) { @@ -6269,7 +6282,7 @@ TestChannelEventCmd( esPtr->chanPtr = chanPtr; esPtr->interp = interp; esPtr->mask = mask; - esPtr->scriptPtr = Tcl_NewStringObj(argv[4], -1); + esPtr->scriptPtr = Tcl_NewStringObj(argv[4], TCL_INDEX_NONE); Tcl_IncrRefCount(esPtr->scriptPtr); Tcl_CreateChannelHandler((Tcl_Channel) chanPtr, mask, @@ -6336,10 +6349,10 @@ TestChannelEventCmd( esPtr = esPtr->nextPtr) { if (esPtr->mask) { Tcl_ListObjAppendElement(interp, resultListPtr, Tcl_NewStringObj( - (esPtr->mask == TCL_READABLE) ? "readable" : "writable", -1)); + (esPtr->mask == TCL_READABLE) ? "readable" : "writable", TCL_INDEX_NONE)); } else { Tcl_ListObjAppendElement(interp, resultListPtr, - Tcl_NewStringObj("none", -1)); + Tcl_NewStringObj("none", TCL_INDEX_NONE)); } Tcl_ListObjAppendElement(interp, resultListPtr, esPtr->scriptPtr); } @@ -6551,16 +6564,12 @@ TestWrongNumArgsObjCmd( int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - int i, length; + int i; + int length; const char *msg; if (objc < 3) { - /* - * Don't use Tcl_WrongNumArgs here, as that is the function - * we want to test! - */ - Tcl_AppendResult(interp, "insufficient arguments", NULL); - return TCL_ERROR; + goto insufArgs; } if (Tcl_GetIntFromObj(interp, objv[1], &i) != TCL_OK) { @@ -6576,6 +6585,7 @@ TestWrongNumArgsObjCmd( /* * Asked for more arguments than were given. */ + insufArgs: Tcl_AppendResult(interp, "insufficient arguments", NULL); return TCL_ERROR; } @@ -6686,7 +6696,7 @@ TestFilesystemObjCmd( res = Tcl_FSUnregister(&testReportingFilesystem); msg = (res == TCL_OK) ? "unregistered" : "failed"; } - Tcl_SetObjResult(interp, Tcl_NewStringObj(msg , -1)); + Tcl_SetObjResult(interp, Tcl_NewStringObj(msg , TCL_INDEX_NONE)); return res; } @@ -6768,7 +6778,7 @@ TestReport( Tcl_DString ds; Tcl_DStringInit(&ds); - Tcl_DStringAppend(&ds, "lappend filesystemReport ", -1); + Tcl_DStringAppend(&ds, "lappend filesystemReport ", TCL_INDEX_NONE); Tcl_DStringStartSublist(&ds); Tcl_DStringAppendElement(&ds, cmd); if (path != NULL) { @@ -6781,7 +6791,7 @@ TestReport( savedResult = Tcl_GetObjResult(interp); Tcl_IncrRefCount(savedResult); Tcl_SetObjResult(interp, Tcl_NewObj()); - Tcl_EvalEx(interp, Tcl_DStringValue(&ds), -1, 0); + Tcl_EvalEx(interp, Tcl_DStringValue(&ds), TCL_INDEX_NONE, 0); Tcl_DStringFree(&ds); Tcl_ResetResult(interp); Tcl_SetObjResult(interp, savedResult); @@ -7057,7 +7067,7 @@ TestSimpleFilesystemObjCmd( res = Tcl_FSUnregister(&simpleFilesystem); msg = (res == TCL_OK) ? "unregistered" : "failed"; } - Tcl_SetObjResult(interp, Tcl_NewStringObj(msg , -1)); + Tcl_SetObjResult(interp, Tcl_NewStringObj(msg , TCL_INDEX_NONE)); return res; } @@ -7084,7 +7094,7 @@ SimpleRedirect( Tcl_IncrRefCount(pathPtr); return pathPtr; } - origPtr = Tcl_NewStringObj(str+10,-1); + origPtr = Tcl_NewStringObj(str+10, TCL_INDEX_NONE); Tcl_IncrRefCount(origPtr); return origPtr; } @@ -7184,7 +7194,7 @@ SimpleListVolumes(void) /* Add one new volume */ Tcl_Obj *retVal; - retVal = Tcl_NewStringObj("simplefs:/", -1); + retVal = Tcl_NewStringObj("simplefs:/", TCL_INDEX_NONE); Tcl_IncrRefCount(retVal); return retVal; } @@ -7304,7 +7314,7 @@ TestNumUtfCharsCmd( Tcl_Obj *const objv[]) { if (objc > 1) { - int numBytes, len, limit = -1; + int numBytes, len, limit = TCL_INDEX_NONE; const char *bytes = Tcl_GetStringFromObj(objv[1], &numBytes); if (objc > 2) { @@ -7338,7 +7348,7 @@ TestFindFirstCmd( if (objc > 2) { (void) Tcl_GetIntFromObj(interp, objv[2], &len); } - Tcl_SetObjResult(interp, Tcl_NewStringObj(Tcl_UtfFindFirst(Tcl_GetString(objv[1]), len), -1)); + Tcl_SetObjResult(interp, Tcl_NewStringObj(Tcl_UtfFindFirst(Tcl_GetString(objv[1]), len), TCL_INDEX_NONE)); } return TCL_OK; } @@ -7360,7 +7370,7 @@ TestFindLastCmd( if (objc > 2) { (void) Tcl_GetIntFromObj(interp, objv[2], &len); } - Tcl_SetObjResult(interp, Tcl_NewStringObj(Tcl_UtfFindLast(Tcl_GetString(objv[1]), len), -1)); + Tcl_SetObjResult(interp, Tcl_NewStringObj(Tcl_UtfFindLast(Tcl_GetString(objv[1]), len), TCL_INDEX_NONE)); } return TCL_OK; } @@ -7437,7 +7447,7 @@ TestcpuidCmd( status = TclWinCPUID(index, regs); if (status != TCL_OK) { Tcl_SetObjResult(interp, - Tcl_NewStringObj("operation not available", -1)); + Tcl_NewStringObj("operation not available", TCL_INDEX_NONE)); return status; } for (i=0 ; i<4 ; ++i) { @@ -7483,7 +7493,7 @@ TestHashSystemHashCmd( hPtr = Tcl_CreateHashEntry(&hash, INT2PTR(i), &isNew); if (!isNew) { Tcl_SetObjResult(interp, Tcl_NewWideIntObj(i)); - Tcl_AppendToObj(Tcl_GetObjResult(interp)," creation problem",-1); + Tcl_AppendToObj(Tcl_GetObjResult(interp)," creation problem", TCL_INDEX_NONE); Tcl_DeleteHashTable(&hash); return TCL_ERROR; } @@ -7500,13 +7510,13 @@ TestHashSystemHashCmd( hPtr = Tcl_FindHashEntry(&hash, (char *) INT2PTR(i)); if (hPtr == NULL) { Tcl_SetObjResult(interp, Tcl_NewWideIntObj(i)); - Tcl_AppendToObj(Tcl_GetObjResult(interp)," lookup problem",-1); + Tcl_AppendToObj(Tcl_GetObjResult(interp)," lookup problem", TCL_INDEX_NONE); Tcl_DeleteHashTable(&hash); return TCL_ERROR; } if (PTR2INT(Tcl_GetHashValue(hPtr)) != i+42) { Tcl_SetObjResult(interp, Tcl_NewWideIntObj(i)); - Tcl_AppendToObj(Tcl_GetObjResult(interp)," value problem",-1); + Tcl_AppendToObj(Tcl_GetObjResult(interp)," value problem", TCL_INDEX_NONE); Tcl_DeleteHashTable(&hash); return TCL_ERROR; } @@ -7589,9 +7599,9 @@ NREUnwind_callback( &none, NULL); } else { Tcl_Obj *idata[3]; - idata[0] = Tcl_NewWideIntObj((int) ((char *) data[1] - (char *) data[0])); - idata[1] = Tcl_NewWideIntObj((int) ((char *) data[2] - (char *) data[0])); - idata[2] = Tcl_NewWideIntObj((int) ((char *) &none - (char *) data[0])); + idata[0] = Tcl_NewWideIntObj(((char *) data[1] - (char *) data[0])); + idata[1] = Tcl_NewWideIntObj(((char *) data[2] - (char *) data[0])); + idata[2] = Tcl_NewWideIntObj(((char *) &none - (char *) data[0])); Tcl_SetObjResult(interp, Tcl_NewListObj(3, idata)); } return TCL_OK; @@ -7689,15 +7699,15 @@ TestconcatobjCmd( */ Tcl_SetObjResult(interp, - Tcl_NewStringObj("Tcl_ConcatObj is unsafe:", -1)); + Tcl_NewStringObj("Tcl_ConcatObj is unsafe:", TCL_INDEX_NONE)); emptyPtr = Tcl_NewObj(); - list1Ptr = Tcl_NewStringObj("foo bar sum", -1); + list1Ptr = Tcl_NewStringObj("foo bar sum", TCL_INDEX_NONE); Tcl_ListObjLength(NULL, list1Ptr, &len); Tcl_InvalidateStringRep(list1Ptr); - list2Ptr = Tcl_NewStringObj("eeny meeny", -1); + list2Ptr = Tcl_NewStringObj("eeny meeny", TCL_INDEX_NONE); Tcl_ListObjLength(NULL, list2Ptr, &len); Tcl_InvalidateStringRep(list2Ptr); @@ -8260,7 +8270,7 @@ InterpCompiledVarResolver( resVarInfo->vInfo.fetchProc = MyCompiledVarFetch; resVarInfo->vInfo.deleteProc = MyCompiledVarFree; resVarInfo->var = NULL; - resVarInfo->nameObj = Tcl_NewStringObj(name, -1); + resVarInfo->nameObj = Tcl_NewStringObj(name, TCL_INDEX_NONE); Tcl_IncrRefCount(resVarInfo->nameObj); *rPtr = &resVarInfo->vInfo; return TCL_OK; @@ -8344,12 +8354,12 @@ int TestApplyLambdaObjCmd ( /* Create a lambda {{} {set a 42}} */ lambdaObjs[0] = Tcl_NewObj(); /* No parameters */ - lambdaObjs[1] = Tcl_NewStringObj("set a 42", -1); /* Body */ + lambdaObjs[1] = Tcl_NewStringObj("set a 42", TCL_INDEX_NONE); /* Body */ lambdaObj = Tcl_NewListObj(2, lambdaObjs); Tcl_IncrRefCount(lambdaObj); /* Create the command "apply {{} {set a 42}" */ - evalObjs[0] = Tcl_NewStringObj("apply", -1); + evalObjs[0] = Tcl_NewStringObj("apply", TCL_INDEX_NONE); Tcl_IncrRefCount(evalObjs[0]); /* * NOTE: IMPORTANT TO EXHIBIT THE BUG. We duplicate the lambda because -- cgit v0.12 From ead37ca168eb29e8afc501d242116547534d619b Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 2 Sep 2022 12:35:15 +0000 Subject: Bugfix for TIP #627: If only objProc or deleteProc is updated with Tcl_SetCommandInfo(), for a command registered with Tcl_CreateObjCmd2() ... --- generic/tclBasic.c | 24 +++++++++++++++--------- 1 file changed, 15 insertions(+), 9 deletions(-) diff --git a/generic/tclBasic.c b/generic/tclBasic.c index 645a581..85b74b4 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -2690,26 +2690,30 @@ Tcl_CreateCommand( */ typedef struct { - void *clientData; /* Arbitrary value to pass to object function. */ Tcl_ObjCmdProc2 *proc; - Tcl_ObjCmdProc2 *nreProc; + void *clientData; /* Arbitrary value to pass to proc function. */ Tcl_CmdDeleteProc *deleteProc; + void *deleteData; /* Arbitrary value to pass to deleteProc function. */ + Tcl_ObjCmdProc2 *nreProc; } CmdWrapperInfo; static int cmdWrapperProc(void *clientData, - Tcl_Interp *interp, - int objc, + Tcl_Interp *interp, + int objc, Tcl_Obj * const *objv) { CmdWrapperInfo *info = (CmdWrapperInfo *)clientData; + if (objc < 0) { + objc = -1; + } return info->proc(info->clientData, interp, objc, objv); } static void cmdWrapperDeleteProc(void *clientData) { CmdWrapperInfo *info = (CmdWrapperInfo *)clientData; - clientData = info->clientData; + clientData = info->deleteData; Tcl_CmdDeleteProc *deleteProc = info->deleteProc; ckfree(info); if (deleteProc != NULL) { @@ -2736,8 +2740,9 @@ Tcl_CreateObjCommand2( { CmdWrapperInfo *info = (CmdWrapperInfo *)ckalloc(sizeof(CmdWrapperInfo)); info->proc = proc; - info->deleteProc = deleteProc; info->clientData = clientData; + info->deleteProc = deleteProc; + info->deleteData = clientData; return Tcl_CreateObjCommand(interp, cmdName, (proc ? cmdWrapperProc : NULL), @@ -3380,7 +3385,7 @@ Tcl_SetCommandInfoFromToken( if (cmdPtr->deleteProc == cmdWrapperDeleteProc) { CmdWrapperInfo *info = (CmdWrapperInfo *)cmdPtr->deleteData; info->deleteProc = infoPtr->deleteProc; - info->clientData = infoPtr->deleteData; + info->deleteData = infoPtr->deleteData; } else { cmdPtr->deleteProc = infoPtr->deleteProc; cmdPtr->deleteData = infoPtr->deleteData; @@ -3464,7 +3469,7 @@ Tcl_GetCommandInfoFromToken( if (cmdPtr->deleteProc == cmdWrapperDeleteProc) { CmdWrapperInfo *info = (CmdWrapperInfo *)cmdPtr->deleteData; infoPtr->deleteProc = info->deleteProc; - infoPtr->deleteData = info->clientData; + infoPtr->deleteData = info->deleteData; } else { infoPtr->deleteProc = cmdPtr->deleteProc; infoPtr->deleteData = cmdPtr->deleteData; @@ -9256,9 +9261,10 @@ Tcl_NRCreateCommand2( { CmdWrapperInfo *info = (CmdWrapperInfo *)ckalloc(sizeof(CmdWrapperInfo)); info->proc = proc; + info->clientData = clientData; info->nreProc = nreProc; info->deleteProc = deleteProc; - info->clientData = clientData; + info->deleteData = clientData; return Tcl_NRCreateCommand(interp, cmdName, (proc ? cmdWrapperProc : NULL), (nreProc ? cmdWrapperNreProc : NULL), -- cgit v0.12 From a1e647c6847503d5c146857dd0435fac4caa7490 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 2 Sep 2022 13:54:04 +0000 Subject: Fix [95b6a1747a]: Eval.3 docu fix --- doc/Eval.3 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/doc/Eval.3 b/doc/Eval.3 index be1598a..1318fdb 100644 --- a/doc/Eval.3 +++ b/doc/Eval.3 @@ -54,7 +54,7 @@ ORed combination of flag bits that specify additional options. .AP "const char" *fileName in Name of a file containing a Tcl script. .AP int objc in -The number of values in the array pointed to by \fIobjPtr\fR; +The number of values in the array pointed to by \fIobjv\fR; this is also the number of words in the command. .AP Tcl_Obj **objv in Points to an array of pointers to values; each value holds the -- cgit v0.12 From f22c567b842667d01d4734847495c6b477244d97 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 2 Sep 2022 14:11:39 +0000 Subject: Mark httpold-4.12 knownBug. See [2641672]: http1.0 failing test: httpold-4.12 --- tests/httpold.test | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/tests/httpold.test b/tests/httpold.test index 67ab119..e43a550 100644 --- a/tests/httpold.test +++ b/tests/httpold.test @@ -256,7 +256,7 @@ test httpold-4.11 {httpEvent} { http_reset $token http_status $token } {reset} -test httpold-4.12 {httpEvent} { +test httpold-4.12 {httpEvent See [2641672]} knownBug { update set x {} after 500 {lappend x ok} -- cgit v0.12 From 46cf6812fcfb415aae1696cf0b29cd2a6a77917a Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 2 Sep 2022 15:16:30 +0000 Subject: TIP #627: Some more protection against invalid objc values --- generic/tclBasic.c | 8 ++++++++ 1 file changed, 8 insertions(+) diff --git a/generic/tclBasic.c b/generic/tclBasic.c index 85b74b4..4bacba6 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -9192,6 +9192,11 @@ Tcl_NRCallObjProc2( size_t objc, Tcl_Obj *const objv[]) { + if (objc > INT_MAX) { + Tcl_WrongNumArgs(interp, 1, objv, "?args?"); + return TCL_ERROR; + } + NRE_callback *rootPtr = TOP_CB(interp); CmdWrapperInfo *info = (CmdWrapperInfo *)ckalloc(sizeof(CmdWrapperInfo)); info->clientData = clientData; @@ -9237,6 +9242,9 @@ static int cmdWrapperNreProc( Tcl_Obj *const objv[]) { CmdWrapperInfo *info = (CmdWrapperInfo *)clientData; + if (objc < 0) { + objc = -1; + } return info->nreProc(info->clientData, interp, objc, objv); } -- cgit v0.12 From 3fa8112c7afe69df643dcccb9570e698f2173da4 Mon Sep 17 00:00:00 2001 From: sebres Date: Fri, 2 Sep 2022 17:02:56 +0000 Subject: really closes [2641672fff] - resolved timing sensitivity of httpold-4.12 and speed-up all httpd depending tests (removed 50ms delay unneeded in other cases) --- tests/httpd | 6 +++++- tests/httpold.test | 19 +++++++++++++------ 2 files changed, 18 insertions(+), 7 deletions(-) diff --git a/tests/httpd b/tests/httpd index 3cf2170..9fd23e7 100644 --- a/tests/httpd +++ b/tests/httpd @@ -45,7 +45,7 @@ proc httpdAccept {newsock ipaddr port} { fconfigure $newsock -blocking 0 -translation {auto crlf} httpd_log $newsock Connect $ipaddr $port set data(ipaddr) $ipaddr - after 50 [list fileevent $newsock readable [list httpdRead $newsock]] + fileevent $newsock readable [list httpdRead $newsock] } # read data from a client request @@ -69,6 +69,10 @@ proc httpdRead { sock } { httpd_log $sock Error "bad first line:$line" httpdSockDone $sock } + if {[regexp {[\?&]delay=([^&]+)} val]} { + fileevent $sock readable {} + after $val [list fileevent $sock readable [list httpdRead $sock]] + } return } elseif {$data(state) == "mime"} { diff --git a/tests/httpold.test b/tests/httpold.test index e43a550..439ce92 100644 --- a/tests/httpold.test +++ b/tests/httpold.test @@ -256,14 +256,21 @@ test httpold-4.11 {httpEvent} { http_reset $token http_status $token } {reset} -test httpold-4.12 {httpEvent See [2641672]} knownBug { +test httpold-4.12 {httpEvent} -body { + set tout {} update set x {} - after 500 {lappend x ok} - set token [http_get $url -timeout 1 -command {lappend x fail}] - vwait x - list [http_status $token] $x -} {timeout ok} + set token [http_get $url -query delay=500 -timeout 1 -command {lappend x fail}] + set i 0; while {$x eq {} && [incr i] < 50} { + set tout [after 20 {set x progress}] + vwait x + if {$x ne "progress"} break + set x [http_status $token] + } + set x +} -cleanup { + if {$tout ne {}} {after cancel $tout} +} -result timeout test httpold-5.1 {http_formatQuery} { http_formatQuery name1 value1 name2 "value two" -- cgit v0.12 From 337b5ab155b13596235bd36549efe9673cc6c7c9 Mon Sep 17 00:00:00 2001 From: sebres Date: Fri, 2 Sep 2022 17:17:53 +0000 Subject: amend to [2641672fff], guarantees a delay to cause a timeout definitely + switch delay-argument from post to get (it expects delay in query string of url) --- tests/httpd | 2 +- tests/httpold.test | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/tests/httpd b/tests/httpd index 9fd23e7..682556b 100644 --- a/tests/httpd +++ b/tests/httpd @@ -69,7 +69,7 @@ proc httpdRead { sock } { httpd_log $sock Error "bad first line:$line" httpdSockDone $sock } - if {[regexp {[\?&]delay=([^&]+)} val]} { + if {[regexp {(?:^|[\?&])delay=([^&]+)} $data(query) {} val]} { fileevent $sock readable {} after $val [list fileevent $sock readable [list httpdRead $sock]] } diff --git a/tests/httpold.test b/tests/httpold.test index 439ce92..e760c92 100644 --- a/tests/httpold.test +++ b/tests/httpold.test @@ -260,7 +260,7 @@ test httpold-4.12 {httpEvent} -body { set tout {} update set x {} - set token [http_get $url -query delay=500 -timeout 1 -command {lappend x fail}] + set token [http_get $url?delay=500 -timeout 1 -command {lappend x fail}] set i 0; while {$x eq {} && [incr i] < 50} { set tout [after 20 {set x progress}] vwait x -- cgit v0.12 From dc84ff9d0cfccec952277549d3b5031bd84c8860 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Sat, 3 Sep 2022 13:57:45 +0000 Subject: typo's --- unix/tclUnixSock.c | 4 ++-- win/tclWinSock.c | 6 +++--- 2 files changed, 5 insertions(+), 5 deletions(-) diff --git a/unix/tclUnixSock.c b/unix/tclUnixSock.c index 1a54914..858afdb 100644 --- a/unix/tclUnixSock.c +++ b/unix/tclUnixSock.c @@ -418,7 +418,7 @@ TcpBlockModeProc( * * Side effects: * Processes socket events off the system queue. May process - * asynchroneous connects. + * asynchronous connects. * *---------------------------------------------------------------------- */ @@ -1328,7 +1328,7 @@ TcpConnect( } /* - * We need to forward the writable event that brought us here, bcasue + * We need to forward the writable event that brought us here, because * upon reading of getsockopt(SO_ERROR), at least some OSes clear the * writable state from the socket, and so a subsequent select() on * behalf of a script level [fileevent] would not fire. It doesn't diff --git a/win/tclWinSock.c b/win/tclWinSock.c index a05b8f6..a4547a8 100644 --- a/win/tclWinSock.c +++ b/win/tclWinSock.c @@ -566,7 +566,7 @@ TcpBlockModeProc( * * Side effects: * Processes socket events off the system queue. - * May process asynchroneous connect. + * May process asynchronous connect. * *---------------------------------------------------------------------- */ @@ -1706,7 +1706,7 @@ TcpConnect( continue; } /* - * For asynchroneous connect set the socket in nonblocking mode + * For asynchronous connect set the socket in nonblocking mode * and activate connect notification */ if (async_connect) { @@ -1794,7 +1794,7 @@ TcpConnect( /* * Clear the tsd socket list pointer if we did not wait for - * the FD_CONNECT asynchroneously + * the FD_CONNECT asynchronously */ tsdPtr->pendingTcpState = NULL; -- cgit v0.12 From df50b9ade238e19ef27748a4a037b384d70bdf0a Mon Sep 17 00:00:00 2001 From: sebres Date: Mon, 5 Sep 2022 10:30:34 +0000 Subject: closes [2641672fff], httpd - don't parse delay argument by error 400 (wrong URI/proto) --- tests/httpd | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/tests/httpd b/tests/httpd index 682556b..48e14ea 100644 --- a/tests/httpd +++ b/tests/httpd @@ -64,15 +64,15 @@ proc httpdRead { sock } { -> data(proto) data(url) data(query) data(httpversion)]} { set data(state) mime httpd_log $sock Query $line + if {[regexp {(?:^|[\?&])delay=([^&]+)} $data(query) {} val]} { + fileevent $sock readable {} + after $val [list fileevent $sock readable [list httpdRead $sock]] + } } else { httpdError $sock 400 httpd_log $sock Error "bad first line:$line" httpdSockDone $sock } - if {[regexp {(?:^|[\?&])delay=([^&]+)} $data(query) {} val]} { - fileevent $sock readable {} - after $val [list fileevent $sock readable [list httpdRead $sock]] - } return } elseif {$data(state) == "mime"} { -- cgit v0.12 From 1197ccadc0ba24b8f5dc9debc59ca25593067f64 Mon Sep 17 00:00:00 2001 From: apnadkarni Date: Mon, 5 Sep 2022 11:37:54 +0000 Subject: Ticket [55a02f20ec] - fallback to USERPROFILE when setting HOME env on Windows --- tests/env.test | 40 +++++++++++++++++++++++++++++++++++++++- win/tclWinInit.c | 9 ++++++++- 2 files changed, 47 insertions(+), 2 deletions(-) diff --git a/tests/env.test b/tests/env.test index 905cdab..ea58b26 100644 --- a/tests/env.test +++ b/tests/env.test @@ -105,6 +105,7 @@ variable keep { CommonProgramFiles CommonProgramFiles(x86) ProgramFiles ProgramFiles(x86) CommonProgramW6432 ProgramW6432 WINECONFIGDIR WINEDATADIR WINEDLLDIR0 WINEHOMEDIR PROCESSOR_ARCHITECTURE + USERPROFILE } variable printenvScript [makeFile [string map [list @keep@ [list $keep]] { @@ -409,7 +410,7 @@ test env-7.3 { return [info exists ::env(test7_3)] }} } -cleanup cleanup1 -result 1 - + test env-8.0 { memory usage - valgrind does not report reachable memory } -body { @@ -419,6 +420,43 @@ test env-8.0 { } -result {i'm with dummy} +test env-9.0 { + Initialization of HOME from HOMEDRIVE and HOMEPATH +} -constraints win -setup { + setup1 + unset -nocomplain ::env(HOME) + set ::env(HOMEDRIVE) X: + set ::env(HOMEPATH) \\home\\path +} -cleanup { + cleanup1 +} -body { + set pipe [open |[list [interpreter]] r+] + puts $pipe {puts $::env(HOME); flush stdout; exit} + flush $pipe + set result [gets $pipe] + close $pipe + set result +} -result {X:\home\path} + +test env-9.1 { + Initialization of HOME from USERPROFILE +} -constraints win -setup { + setup1 + unset -nocomplain ::env(HOME) + unset -nocomplain ::env(HOMEDRIVE) + unset -nocomplain ::env(HOMEPATH) +} -cleanup { + cleanup1 +} -body { + set pipe [open |[list [interpreter]] r+] + puts $pipe {puts $::env(HOME); flush stdout; exit} + flush $pipe + set result [gets $pipe] + close $pipe + set result +} -result $::env(USERPROFILE) + + # cleanup rename getenv {} diff --git a/win/tclWinInit.c b/win/tclWinInit.c index 4f59c1a..eae4404 100644 --- a/win/tclWinInit.c +++ b/win/tclWinInit.c @@ -593,7 +593,14 @@ TclpSetVariables( Tcl_SetVar2(interp, "env", "HOME", Tcl_DStringValue(&ds), TCL_GLOBAL_ONLY); } else { - Tcl_SetVar2(interp, "env", "HOME", "c:\\", TCL_GLOBAL_ONLY); + /* None of HOME, HOMEDRIVE, HOMEPATH exists. Try USERPROFILE */ + ptr = Tcl_GetVar2(interp, "env", "USERPROFILE", TCL_GLOBAL_ONLY); + if (ptr != NULL && ptr[0]) { + Tcl_SetVar2(interp, "env", "HOME", ptr, TCL_GLOBAL_ONLY); + } else { + /* Last resort */ + Tcl_SetVar2(interp, "env", "HOME", "c:\\", TCL_GLOBAL_ONLY); + } } } -- cgit v0.12 From 67331f69a606991d6a166d2c722f61541a5561eb Mon Sep 17 00:00:00 2001 From: sebres Date: Tue, 6 Sep 2022 09:04:18 +0000 Subject: amend to [55a02f20ec]: fixes test env-9.1 for not windows - USERPROFILE is not set under unix, and win constraint isn't effective yet since it'll be supplied to test as argument in global scope (check moved to test now) --- tests/env.test | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/tests/env.test b/tests/env.test index ea58b26..25367c3 100644 --- a/tests/env.test +++ b/tests/env.test @@ -453,8 +453,10 @@ test env-9.1 { flush $pipe set result [gets $pipe] close $pipe - set result -} -result $::env(USERPROFILE) + if {$result ne $::env(USERPROFILE)} { + list ERROR $result ne $::env(USERPROFILE) + } +} -result {} -- cgit v0.12 From ea5d97f286ae2af57a461f9935df7664ca625edf Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 7 Sep 2022 07:22:07 +0000 Subject: code cleanup (backported from 8.7) --- unix/tclUnixSock.c | 78 +++--- win/tclWinSock.c | 766 ++++++++++++++++++++++++++++++++--------------------- 2 files changed, 497 insertions(+), 347 deletions(-) diff --git a/unix/tclUnixSock.c b/unix/tclUnixSock.c index 858afdb..ffb70e1 100644 --- a/unix/tclUnixSock.c +++ b/unix/tclUnixSock.c @@ -64,7 +64,7 @@ struct TcpState { Tcl_TcpAcceptProc *acceptProc; /* Proc to call on accept. */ - ClientData acceptProcData; /* The data for the accept proc. */ + void *acceptProcData; /* The data for the accept proc. */ /* * Only needed for client sockets @@ -118,27 +118,27 @@ struct TcpState { * Static routines for this file: */ -static void TcpAsyncCallback(ClientData clientData, int mask); +static void TcpAsyncCallback(void *clientData, int mask); static int TcpConnect(Tcl_Interp *interp, TcpState *state); -static void TcpAccept(ClientData data, int mask); -static int TcpBlockModeProc(ClientData data, int mode); -static int TcpCloseProc(ClientData instanceData, +static void TcpAccept(void *data, int mask); +static int TcpBlockModeProc(void *data, int mode); +static int TcpCloseProc(void *instanceData, Tcl_Interp *interp); -static int TcpClose2Proc(ClientData instanceData, +static int TcpClose2Proc(void *instanceData, Tcl_Interp *interp, int flags); -static int TcpGetHandleProc(ClientData instanceData, - int direction, ClientData *handlePtr); -static int TcpGetOptionProc(ClientData instanceData, +static int TcpGetHandleProc(void *instanceData, + int direction, void **handlePtr); +static int TcpGetOptionProc(void *instanceData, Tcl_Interp *interp, const char *optionName, Tcl_DString *dsPtr); -static int TcpInputProc(ClientData instanceData, char *buf, +static int TcpInputProc(void *instanceData, char *buf, int toRead, int *errorCode); -static int TcpOutputProc(ClientData instanceData, +static int TcpOutputProc(void *instanceData, const char *buf, int toWrite, int *errorCode); -static void TcpThreadActionProc(ClientData instanceData, int action); -static void TcpWatchProc(ClientData instanceData, int mask); +static void TcpThreadActionProc(void *instanceData, int action); +static void TcpWatchProc(void *instanceData, int mask); static int WaitForConnect(TcpState *statePtr, int *errorCodePtr); -static void WrapNotify(ClientData clientData, int mask); +static void WrapNotify(void *clientData, int mask); /* * This structure describes the channel type structure for TCP socket @@ -218,7 +218,7 @@ InitializeHostName( struct hostent *hp; memset(&u, (int) 0, sizeof(struct utsname)); - if (uname(&u) > -1) { /* INTL: Native. */ + if (uname(&u) >= 0) { /* INTL: Native. */ hp = TclpGetHostByName(u.nodename); /* INTL: Native. */ if (hp == NULL) { /* @@ -269,14 +269,14 @@ InitializeHostName( char buffer[256]; # endif - if (gethostname(buffer, sizeof(buffer)) > -1) { /* INTL: Native. */ + if (gethostname(buffer, sizeof(buffer)) >= 0) { /* INTL: Native. */ native = buffer; } #endif /* NO_UNAME */ *encodingPtr = Tcl_GetEncoding(NULL, NULL); *lengthPtr = strlen(native); - *valuePtr = ckalloc(*lengthPtr + 1); + *valuePtr = (char *)ckalloc(*lengthPtr + 1); memcpy(*valuePtr, native, *lengthPtr + 1); } @@ -370,7 +370,7 @@ TclpFinalizeSockets(void) static int TcpBlockModeProc( - ClientData instanceData, /* Socket state. */ + void *instanceData, /* Socket state. */ int mode) /* The mode to set. Can be one of * TCL_MODE_BLOCKING or * TCL_MODE_NONBLOCKING. */ @@ -501,7 +501,7 @@ WaitForConnect( static int TcpInputProc( - ClientData instanceData, /* Socket state. */ + void *instanceData, /* Socket state. */ char *buf, /* Where to store data read. */ int bufSize, /* How much space is available in the * buffer? */ @@ -514,8 +514,8 @@ TcpInputProc( if (WaitForConnect(statePtr, errorCodePtr) != 0) { return -1; } - bytesRead = recv(statePtr->fds.fd, buf, (size_t) bufSize, 0); - if (bytesRead > -1) { + bytesRead = recv(statePtr->fds.fd, buf, bufSize, 0); + if (bytesRead >= 0) { return bytesRead; } if (errno == ECONNRESET) { @@ -552,7 +552,7 @@ TcpInputProc( static int TcpOutputProc( - ClientData instanceData, /* Socket state. */ + void *instanceData, /* Socket state. */ const char *buf, /* The data buffer. */ int toWrite, /* How many bytes to write? */ int *errorCodePtr) /* Where to store error code. */ @@ -566,7 +566,7 @@ TcpOutputProc( } written = send(statePtr->fds.fd, buf, (size_t) toWrite, 0); - if (written > -1) { + if (written >= 0) { return written; } *errorCodePtr = errno; @@ -593,7 +593,7 @@ TcpOutputProc( static int TcpCloseProc( - ClientData instanceData, /* The socket to close. */ + void *instanceData, /* The socket to close. */ Tcl_Interp *dummy) /* For error reporting - unused. */ { TcpState *statePtr = (TcpState *)instanceData; @@ -655,7 +655,7 @@ TcpCloseProc( static int TcpClose2Proc( - ClientData instanceData, /* The socket to close. */ + void *instanceData, /* The socket to close. */ Tcl_Interp *dummy, /* For error reporting. */ int flags) /* Flags that indicate which side to close. */ { @@ -807,7 +807,7 @@ TcpHostPortList( static int TcpGetOptionProc( - ClientData instanceData, /* Socket state. */ + void *instanceData, /* Socket state. */ Tcl_Interp *interp, /* For error reporting - can be NULL. */ const char *optionName, /* Name of the option to retrieve the value * for, or NULL to get all options and their @@ -852,8 +852,8 @@ TcpGetOptionProc( if ((len > 1) && (optionName[1] == 'c') && (strncmp(optionName, "-connecting", len) == 0)) { - Tcl_DStringAppend(dsPtr, - GOT_BITS(statePtr->flags, TCP_ASYNC_CONNECT) ? "1" : "0", -1); + Tcl_DStringAppend(dsPtr, + GOT_BITS(statePtr->flags, TCP_ASYNC_CONNECT) ? "1" : "0", -1); return TCL_OK; } @@ -973,7 +973,7 @@ TcpGetOptionProc( static void TcpThreadActionProc( - ClientData instanceData, + void *instanceData, int action) { TcpState *statePtr = (TcpState *)instanceData; @@ -1018,7 +1018,7 @@ TcpThreadActionProc( static void WrapNotify( - ClientData clientData, + void *clientData, int mask) { TcpState *statePtr = (TcpState *) clientData; @@ -1047,7 +1047,7 @@ WrapNotify( static void TcpWatchProc( - ClientData instanceData, /* The socket state. */ + void *instanceData, /* The socket state. */ int mask) /* Events of interest; an OR-ed combination of * TCL_READABLE, TCL_WRITABLE and * TCL_EXCEPTION. */ @@ -1120,9 +1120,9 @@ TcpWatchProc( static int TcpGetHandleProc( - ClientData instanceData, /* The socket state. */ + void *instanceData, /* The socket state. */ int direction, /* Not used. */ - ClientData *handlePtr) /* Where to store the handle. */ + void **handlePtr) /* Where to store the handle. */ { TcpState *statePtr = (TcpState *)instanceData; (void)direction; @@ -1145,7 +1145,7 @@ TcpGetHandleProc( static void TcpAsyncCallback( - ClientData clientData, /* The socket state. */ + void *clientData, /* The socket state. */ int mask) /* Events of interest; an OR-ed combination of * TCL_READABLE, TCL_WRITABLE and * TCL_EXCEPTION. */ @@ -1428,7 +1428,7 @@ Tcl_OpenTcpClient( return NULL; } - sprintf(channelName, SOCK_TEMPLATE, (long) statePtr); + sprintf(channelName, SOCK_TEMPLATE, (long)statePtr); statePtr->channel = Tcl_CreateChannel(&tcpChannelType, channelName, statePtr, TCL_READABLE | TCL_WRITABLE); @@ -1458,7 +1458,7 @@ Tcl_OpenTcpClient( Tcl_Channel Tcl_MakeTcpClientChannel( - ClientData sock) /* The socket to wrap up into a channel. */ + void *sock) /* The socket to wrap up into a channel. */ { return (Tcl_Channel) TclpMakeTcpClientChannelMode(sock, TCL_READABLE | TCL_WRITABLE); @@ -1532,7 +1532,7 @@ Tcl_OpenTcpServer( Tcl_TcpAcceptProc *acceptProc, /* Callback for accepting connections from new * clients. */ - ClientData acceptProcData) /* Data for the callback. */ + void *acceptProcData) /* Data for the callback. */ { int status = 0, sock = -1, reuseaddr = 1, chosenport = 0; struct addrinfo *addrlist = NULL, *addrPtr; /* socket address */ @@ -1717,7 +1717,7 @@ Tcl_OpenTcpServer( static void TcpAccept( - ClientData data, /* Callback token. */ + void *data, /* Callback token. */ int mask) /* Not used. */ { TcpFdList *fds = (TcpFdList *)data; /* Client data of server socket. */ @@ -1747,7 +1747,7 @@ TcpAccept( newSockState->flags = 0; newSockState->fds.fd = newsock; - sprintf(channelName, SOCK_TEMPLATE, (long) newSockState); + sprintf(channelName, SOCK_TEMPLATE, (long)newSockState); newSockState->channel = Tcl_CreateChannel(&tcpChannelType, channelName, newSockState, TCL_READABLE | TCL_WRITABLE); diff --git a/win/tclWinSock.c b/win/tclWinSock.c index a4547a8..09b5d52 100644 --- a/win/tclWinSock.c +++ b/win/tclWinSock.c @@ -78,6 +78,7 @@ #define SET_BITS(var, bits) ((var) |= (bits)) #define CLEAR_BITS(var, bits) ((var) &= ~(bits)) +#define GOT_BITS(var, bits) (((var) & (bits)) != 0) /* "sock" + a pointer in hex + \0 */ #define SOCK_CHAN_LENGTH (4 + sizeof(void *) * 2 + 1) @@ -90,7 +91,7 @@ */ static int initialized = 0; -static const WCHAR classname[] = L"TclSocket"; +static const WCHAR className[] = L"TclSocket"; TCL_DECLARE_MUTEX(socketMutex) /* @@ -155,7 +156,7 @@ struct TcpState { * protected by semaphore */ Tcl_TcpAcceptProc *acceptProc; /* Proc to call on accept. */ - ClientData acceptProcData; /* The data for the accept proc. */ + void *acceptProcData; /* The data for the accept proc. */ /* * Only needed for client sockets @@ -242,7 +243,7 @@ static int TcpConnect(Tcl_Interp *interp, TcpState *state); static void InitSockets(void); static TcpState * NewSocketInfo(SOCKET socket); -static void SocketExitHandler(ClientData clientData); +static void SocketExitHandler(void *clientData); static LRESULT CALLBACK SocketProc(HWND hwnd, UINT message, WPARAM wParam, LPARAM lParam); static int SocketsEnabled(void); @@ -253,7 +254,7 @@ static int WaitForSocketEvent(TcpState *statePtr, int events, static void AddSocketInfoFd(TcpState *statePtr, SOCKET socket); static int FindFDInList(TcpState *statePtr, SOCKET socket); static DWORD WINAPI SocketThread(LPVOID arg); -static void TcpThreadActionProc(ClientData instanceData, +static void TcpThreadActionProc(void *instanceData, int action); static Tcl_EventCheckProc SocketCheckProc; @@ -301,22 +302,39 @@ static const Tcl_ChannelType tcpChannelType = { static TclInitProcessGlobalValueProc InitializeHostName; static ProcessGlobalValue hostName = {0, 0, NULL, NULL, InitializeHostName, NULL, NULL}; + +/* + * Simple wrapper round the SendMessage syscall. + */ + +#define SendSelectMessage(tsdPtr, message, payload) \ + SendMessageW((tsdPtr)->hwnd, SOCKET_SELECT, \ + (WPARAM) (message), (LPARAM) (payload)) + /* * Address print debug functions */ #if 0 -void printaddrinfo(struct addrinfo *ai, char *prefix) +void +printaddrinfo( + struct addrinfo *ai, + char *prefix) { char host[NI_MAXHOST], port[NI_MAXSERV]; + getnameinfo(ai->ai_addr, ai->ai_addrlen, - host, sizeof(host), - port, sizeof(port), - NI_NUMERICHOST|NI_NUMERICSERV); + host, sizeof(host), port, sizeof(port), + NI_NUMERICHOST|NI_NUMERICSERV); } -void printaddrinfolist(struct addrinfo *addrlist, char *prefix) + +void +printaddrinfolist( + struct addrinfo *addrlist, + char *prefix) { struct addrinfo *ai; + for (ai = addrlist; ai != NULL; ai = ai->ai_next) { printaddrinfo(ai, prefix); } @@ -368,8 +386,8 @@ InitializeHostName( Tcl_DStringSetLength(&inDs, 256); if (gethostname(Tcl_DStringValue(&inDs), Tcl_DStringLength(&inDs)) == 0) { - Tcl_ExternalToUtfDString(NULL, Tcl_DStringValue(&inDs), -1, - &ds); + Tcl_ExternalToUtfDString(NULL, Tcl_DStringValue(&inDs), + -1, &ds); } Tcl_DStringFree(&inDs); } @@ -377,7 +395,7 @@ InitializeHostName( *encodingPtr = Tcl_GetEncoding(NULL, "utf-8"); *lengthPtr = Tcl_DStringLength(&ds); - *valuePtr = ckalloc((*lengthPtr) + 1); + *valuePtr = (char *)ckalloc(*lengthPtr + 1); memcpy(*valuePtr, Tcl_DStringValue(&ds), *lengthPtr + 1); Tcl_DStringFree(&ds); } @@ -469,7 +487,7 @@ TclpHasSockets( void TclpFinalizeSockets(void) { - ThreadSpecificData *tsdPtr = TclThreadDataKeyGet(&dataKey); + ThreadSpecificData *tsdPtr = (ThreadSpecificData *)TclThreadDataKeyGet(&dataKey); /* * Careful! This is a finalizer! @@ -524,17 +542,17 @@ TclpFinalizeSockets(void) static int TcpBlockModeProc( - ClientData instanceData, /* Socket state. */ + void *instanceData, /* Socket state. */ int mode) /* The mode to set. Can be one of * TCL_MODE_BLOCKING or * TCL_MODE_NONBLOCKING. */ { - TcpState *statePtr = instanceData; + TcpState *statePtr = (TcpState *)instanceData; if (mode == TCL_MODE_NONBLOCKING) { - statePtr->flags |= TCP_NONBLOCKING; + SET_BITS(statePtr->flags, TCP_NONBLOCKING); } else { - statePtr->flags &= ~(TCP_NONBLOCKING); + CLEAR_BITS(statePtr->flags, TCP_NONBLOCKING); } return 0; } @@ -544,29 +562,28 @@ TcpBlockModeProc( * * WaitForConnect -- * - * Check the state of an async connect process. If a connection - * attempt terminated, process it, which may finalize it or may - * start the next attempt. If a connect error occures, it is saved - * in statePtr->connectError to be reported by 'fconfigure -error'. + * Check the state of an async connect process. If a connection attempt + * terminated, process it, which may finalize it or may start the next + * attempt. If a connect error occures, it is saved in + * statePtr->connectError to be reported by 'fconfigure -error'. * * There are two modes of operation, defined by errorCodePtr: - * * non-NULL: Called by explicite read/write command. block if - * socket is blocking. + * * non-NULL: Called by explicite read/write command. Block if socket + * is blocking. * May return two error codes: * * EWOULDBLOCK: if connect is still in progress - * * ENOTCONN: if connect failed. This would be the error - * message of a rect or sendto syscall so this is - * emulated here. - * * Null: Called by a backround operation. Do not block and - * don't return any error code. + * * ENOTCONN: if connect failed. This would be the error message + * of a rect or sendto syscall so this is emulated here. + * * Null: Called by a backround operation. Do not block and don't + * return any error code. * * Results: - * 0 if the connection has completed, -1 if still in progress - * or there is an error. + * 0 if the connection has completed, -1 if still in progress or there is + * an error. * * Side effects: - * Processes socket events off the system queue. - * May process asynchronous connect. + * Processes socket events off the system queue. May process + * asynchronous connect. * *---------------------------------------------------------------------- */ @@ -574,20 +591,19 @@ TcpBlockModeProc( static int WaitForConnect( TcpState *statePtr, /* State of the socket. */ - int *errorCodePtr) /* Where to store errors? - * A passed null-pointer activates background mode. - */ + int *errorCodePtr) /* Where to store errors? A passed + * null-pointer activates background mode. */ { int result; int oldMode; ThreadSpecificData *tsdPtr; /* - * Check if an async connect failed already and error reporting is demanded, - * return the error ENOTCONN + * Check if an async connect failed already and error reporting is + * demanded, return the error ENOTCONN. */ - if (errorCodePtr != NULL && (statePtr->flags & TCP_ASYNC_FAILED)) { + if (errorCodePtr != NULL && GOT_BITS(statePtr->flags, TCP_ASYNC_FAILED)) { *errorCodePtr = ENOTCONN; return -1; } @@ -596,7 +612,7 @@ WaitForConnect( * Check if an async connect is running. If not return ok */ - if (!(statePtr->flags & TCP_ASYNC_CONNECT)) { + if (!GOT_BITS(statePtr->flags, TCP_ASYNC_CONNECT)) { return 0; } @@ -611,36 +627,51 @@ WaitForConnect( */ while (1) { + /* + * Get the statePtr lock. + */ - /* get statePtr lock */ - tsdPtr = TclThreadDataKeyGet(&dataKey); + tsdPtr = (ThreadSpecificData *)TclThreadDataKeyGet(&dataKey); WaitForSingleObject(tsdPtr->socketListLock, INFINITE); - /* Check for connect event */ - if (statePtr->readyEvents & FD_CONNECT) { + /* + * Check for connect event. + */ - /* Consume the connect event */ - statePtr->readyEvents &= ~(FD_CONNECT); + if (GOT_BITS(statePtr->readyEvents, FD_CONNECT)) { + /* + * Consume the connect event. + */ + + CLEAR_BITS(statePtr->readyEvents, FD_CONNECT); /* - * For blocking sockets and foreground processing - * disable async connect as we continue now synchoneously + * For blocking sockets and foreground processing, disable async + * connect as we continue now synchoneously. */ - if ( errorCodePtr != NULL && - ! (statePtr->flags & TCP_NONBLOCKING) ) { + + if (errorCodePtr != NULL && + !GOT_BITS(statePtr->flags, TCP_NONBLOCKING)) { CLEAR_BITS(statePtr->flags, TCP_ASYNC_CONNECT); } - /* Free list lock */ + /* + * Free list lock. + */ + SetEvent(tsdPtr->socketListLock); /* - * Continue connect. - * If switched to synchroneous connect, the connect is terminated. + * Continue connect. If switched to synchroneous connect, the + * connect is terminated. */ + result = TcpConnect(NULL, statePtr); - /* Restore event service mode */ + /* + * Restore event service mode. + */ + (void) Tcl_SetServiceMode(oldMode); /* @@ -649,10 +680,11 @@ WaitForConnect( if (result == TCL_OK) { /* - * Check for async connect restart - * (not possible for foreground blocking operation) + * Check for async connect restart (not possible for + * foreground blocking operation) */ - if ( statePtr->flags & TCP_ASYNC_PENDING ) { + + if (GOT_BITS(statePtr->flags, TCP_ASYNC_PENDING)) { if (errorCodePtr != NULL) { *errorCodePtr = EWOULDBLOCK; } @@ -662,8 +694,8 @@ WaitForConnect( } /* - * Connect finally failed. - * For foreground operation return ENOTCONN. + * Connect finally failed. For foreground operation return + * ENOTCONN. */ if (errorCodePtr != NULL) { @@ -672,7 +704,10 @@ WaitForConnect( return -1; } - /* Free list lock */ + /* + * Free list lock. + */ + SetEvent(tsdPtr->socketListLock); /* @@ -680,7 +715,7 @@ WaitForConnect( * event */ - if ( errorCodePtr == NULL ) { + if (errorCodePtr == NULL) { return -1; } @@ -689,7 +724,7 @@ WaitForConnect( * returns directly the error EWOULDBLOCK */ - if (statePtr->flags & TCP_NONBLOCKING) { + if (GOT_BITS(statePtr->flags, TCP_NONBLOCKING)) { *errorCodePtr = EWOULDBLOCK; return -1; } @@ -723,16 +758,16 @@ WaitForConnect( static int TcpInputProc( - ClientData instanceData, /* Socket state. */ + void *instanceData, /* Socket state. */ char *buf, /* Where to store data read. */ int bufSize, /* How much space is available in the * buffer? */ int *errorCodePtr) /* Where to store error code. */ { - TcpState *statePtr = instanceData; + TcpState *statePtr = (TcpState *)instanceData; int bytesRead; DWORD error; - ThreadSpecificData *tsdPtr = TclThreadDataKeyGet(&dataKey); + ThreadSpecificData *tsdPtr = (ThreadSpecificData *)TclThreadDataKeyGet(&dataKey); *errorCodePtr = 0; @@ -752,7 +787,7 @@ TcpInputProc( * socket stack after the first time EOF is detected. */ - if (statePtr->flags & SOCKET_EOF) { + if (GOT_BITS(statePtr->flags, SOCKET_EOF)) { return 0; } @@ -775,18 +810,22 @@ TcpInputProc( */ while (1) { - SendMessageW(tsdPtr->hwnd, SOCKET_SELECT, - (WPARAM) UNSELECT, (LPARAM) statePtr); - /* single fd operation: this proc is only called for a connected socket. */ + SendSelectMessage(tsdPtr, UNSELECT, statePtr); + + /* + * Single fd operation: this proc is only called for a connected + * socket. + */ + bytesRead = recv(statePtr->sockets->fd, buf, bufSize, 0); - statePtr->readyEvents &= ~(FD_READ); + CLEAR_BITS(statePtr->readyEvents, FD_READ); /* * Check for end-of-file condition or successful read. */ if (bytesRead == 0) { - statePtr->flags |= SOCKET_EOF; + SET_BITS(statePtr->flags, SOCKET_EOF); } if (bytesRead != SOCKET_ERROR) { break; @@ -797,8 +836,8 @@ TcpInputProc( * error and report an EOF. */ - if (statePtr->readyEvents & FD_CLOSE) { - statePtr->flags |= SOCKET_EOF; + if (GOT_BITS(statePtr->readyEvents, FD_CLOSE)) { + SET_BITS(statePtr->flags, SOCKET_EOF); bytesRead = 0; break; } @@ -811,7 +850,7 @@ TcpInputProc( */ if (error == WSAECONNRESET) { - statePtr->flags |= SOCKET_EOF; + SET_BITS(statePtr->flags, SOCKET_EOF); bytesRead = 0; break; } @@ -820,7 +859,8 @@ TcpInputProc( * Check for error condition or underflow in non-blocking case. */ - if ((statePtr->flags & TCP_NONBLOCKING) || (error != WSAEWOULDBLOCK)) { + if (GOT_BITS(statePtr->flags, TCP_NONBLOCKING) + || (error != WSAEWOULDBLOCK)) { TclWinConvertError(error); *errorCodePtr = Tcl_GetErrno(); bytesRead = -1; @@ -838,7 +878,7 @@ TcpInputProc( } } - SendMessageW(tsdPtr->hwnd, SOCKET_SELECT, (WPARAM)SELECT, (LPARAM)statePtr); + SendSelectMessage(tsdPtr, SELECT, statePtr); return bytesRead; } @@ -862,15 +902,15 @@ TcpInputProc( static int TcpOutputProc( - ClientData instanceData, /* Socket state. */ + void *instanceData, /* Socket state. */ const char *buf, /* The data buffer. */ int toWrite, /* How many bytes to write? */ int *errorCodePtr) /* Where to store error code. */ { - TcpState *statePtr = instanceData; + TcpState *statePtr = (TcpState *)instanceData; int written; DWORD error; - ThreadSpecificData *tsdPtr = TclThreadDataKeyGet(&dataKey); + ThreadSpecificData *tsdPtr = (ThreadSpecificData *)TclThreadDataKeyGet(&dataKey); *errorCodePtr = 0; @@ -896,10 +936,13 @@ TcpOutputProc( } while (1) { - SendMessageW(tsdPtr->hwnd, SOCKET_SELECT, - (WPARAM) UNSELECT, (LPARAM) statePtr); + SendSelectMessage(tsdPtr, UNSELECT, statePtr); + + /* + * Single fd operation: this proc is only called for a connected + * socket. + */ - /* single fd operation: this proc is only called for a connected socket. */ written = send(statePtr->sockets->fd, buf, toWrite, 0); if (written != SOCKET_ERROR) { /* @@ -908,8 +951,9 @@ TcpOutputProc( * until the condition changes. */ - if (statePtr->watchEvents & FD_WRITE) { + if (GOT_BITS(statePtr->watchEvents, FD_WRITE)) { Tcl_Time blockTime = { 0, 0 }; + Tcl_SetMaxBlockTime(&blockTime); } break; @@ -924,8 +968,8 @@ TcpOutputProc( error = WSAGetLastError(); if (error == WSAEWOULDBLOCK) { - statePtr->readyEvents &= ~(FD_WRITE); - if (statePtr->flags & TCP_NONBLOCKING) { + CLEAR_BITS(statePtr->readyEvents, FD_WRITE); + if (GOT_BITS(statePtr->flags, TCP_NONBLOCKING)) { *errorCodePtr = EWOULDBLOCK; written = -1; break; @@ -948,7 +992,7 @@ TcpOutputProc( } } - SendMessageW(tsdPtr->hwnd, SOCKET_SELECT, (WPARAM)SELECT, (LPARAM)statePtr); + SendSelectMessage(tsdPtr, SELECT, statePtr); return written; } @@ -973,10 +1017,10 @@ TcpOutputProc( static int TcpCloseProc( - ClientData instanceData, /* The socket to close. */ + void *instanceData, /* The socket to close. */ Tcl_Interp *interp) /* Unused. */ { - TcpState *statePtr = instanceData; + TcpState *statePtr = (TcpState *)instanceData; /* TIP #218 */ int errorCode = 0; ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); @@ -994,10 +1038,10 @@ TcpCloseProc( * background. */ - while ( statePtr->sockets != NULL ) { + while (statePtr->sockets != NULL) { TcpFdList *thisfd = statePtr->sockets; - statePtr->sockets = thisfd->next; + statePtr->sockets = thisfd->next; if (closesocket(thisfd->fd) == SOCKET_ERROR) { TclWinConvertError((DWORD) WSAGetLastError()); errorCode = Tcl_GetErrno(); @@ -1015,18 +1059,25 @@ TcpCloseProc( /* * Clear an eventual tsd info list pointer. + * * This may be called, if an async socket connect fails or is closed * between connect and thread action callback. */ + if (tsdPtr->pendingTcpState != NULL && tsdPtr->pendingTcpState == statePtr) { + /* + * Get infoPtr lock, because this concerns the notifier thread. + */ - /* get infoPtr lock, because this concerns the notifier thread */ WaitForSingleObject(tsdPtr->socketListLock, INFINITE); tsdPtr->pendingTcpState = NULL; - /* Free list lock */ + /* + * Free list lock. + */ + SetEvent(tsdPtr->socketListLock); } @@ -1060,11 +1111,11 @@ TcpCloseProc( static int TcpClose2Proc( - ClientData instanceData, /* The socket to close. */ + void *instanceData, /* The socket to close. */ Tcl_Interp *interp, /* For error reporting. */ int flags) /* Flags that indicate which side to close. */ { - TcpState *statePtr = instanceData; + TcpState *statePtr = (TcpState *)instanceData; int readError = 0; int writeError = 0; @@ -1076,8 +1127,11 @@ TcpClose2Proc( return TcpCloseProc(instanceData, interp); } - /* single fd operation: Tcl_OpenTcpServer() does not set TCL_READABLE or - * TCL_WRITABLE so this should never be called for a server socket. */ + /* + * Single fd operation: Tcl_OpenTcpServer() does not set TCL_READABLE or + * TCL_WRITABLE so this should never be called for a server socket. + */ + if ((flags & TCL_CLOSE_READ) && (shutdown(statePtr->sockets->fd, SD_RECEIVE) == SOCKET_ERROR)) { TclWinConvertError((DWORD) WSAGetLastError()); readError = Tcl_GetErrno(); @@ -1107,7 +1161,7 @@ TcpClose2Proc( static int TcpSetOptionProc( - ClientData instanceData, /* Socket state. */ + void *instanceData, /* Socket state. */ Tcl_Interp *interp, /* For error reporting - can be NULL. */ const char *optionName, /* Name of the option to set. */ const char *value) /* New value for option. */ @@ -1132,7 +1186,7 @@ TcpSetOptionProc( } #ifdef TCL_FEATURE_KEEPALIVE_NAGLE - #error "TCL_FEATURE_KEEPALIVE_NAGLE not reviewed for whether to treat statePtr->sockets as single fd or list" +#error "TCL_FEATURE_KEEPALIVE_NAGLE not reviewed for whether to treat statePtr->sockets as single fd or list" sock = statePtr->sockets->fd; if (!strcasecmp(optionName, "-keepalive")) { @@ -1210,7 +1264,7 @@ TcpSetOptionProc( static int TcpGetOptionProc( - ClientData instanceData, /* Socket state. */ + void *instanceData, /* Socket state. */ Tcl_Interp *interp, /* For error reporting - can be NULL. */ const char *optionName, /* Name of the option to retrieve the value * for, or NULL to get all options and their @@ -1218,7 +1272,7 @@ TcpGetOptionProc( Tcl_DString *dsPtr) /* Where to store the computed value; * initialized by caller. */ { - TcpState *statePtr = instanceData; + TcpState *statePtr = (TcpState *)instanceData; char host[NI_MAXHOST], port[NI_MAXSERV]; SOCKET sock; size_t len = 0; @@ -1241,7 +1295,9 @@ TcpGetOptionProc( /* * Go one step in async connect - * If any error is thrown save it as backround error to report eventually below + * + * If any error is thrown save it as backround error to report eventually + * below. */ WaitForConnect(statePtr, NULL); @@ -1252,31 +1308,26 @@ TcpGetOptionProc( if ((len > 1) && (optionName[1] == 'e') && (strncmp(optionName, "-error", len) == 0)) { - /* - * Do not return any errors if async connect is running - */ - if ( ! (statePtr->flags & TCP_ASYNC_PENDING) ) { - - - if ( statePtr->flags & TCP_ASYNC_FAILED ) { + * Do not return any errors if async connect is running. + */ + if (!GOT_BITS(statePtr->flags, TCP_ASYNC_PENDING)) { + if (GOT_BITS(statePtr->flags, TCP_ASYNC_FAILED)) { /* * In case of a failed async connect, eventually report the - * connect error only once. - * Do not report the system error, as this comes again and again. + * connect error only once. Do not report the system error, + * as this comes again and again. */ - if ( statePtr->connectError != 0 ) { + if (statePtr->connectError != 0) { Tcl_DStringAppend(dsPtr, Tcl_ErrnoMsg(statePtr->connectError), -1); statePtr->connectError = 0; } - } else { - /* - * Report an eventual last error of the socket system + * Report an eventual last error of the socket system. */ int optlen; @@ -1284,21 +1335,26 @@ TcpGetOptionProc( DWORD err; /* - * Populater the err Variable with a possix error + * Populate the err variable with a POSIX error */ + optlen = sizeof(int); ret = getsockopt(sock, SOL_SOCKET, SO_ERROR, (char *)&err, &optlen); + /* - * The error was not returned directly but should be - * taken from WSA + * The error was not returned directly but should be taken + * from WSA. */ + if (ret == SOCKET_ERROR) { err = WSAGetLastError(); } + /* - * Return error message + * Return error message. */ + if (err) { TclWinConvertError(err); Tcl_DStringAppend(dsPtr, Tcl_ErrnoMsg(Tcl_GetErrno()), -1); @@ -1310,14 +1366,14 @@ TcpGetOptionProc( if ((len > 1) && (optionName[1] == 'c') && (strncmp(optionName, "-connecting", len) == 0)) { - Tcl_DStringAppend(dsPtr, - (statePtr->flags & TCP_ASYNC_PENDING) + GOT_BITS(statePtr->flags, TCP_ASYNC_PENDING) ? "1" : "0", -1); return TCL_OK; } - if (interp != NULL && Tcl_GetVar(interp, SUPPRESS_RDNS_VAR, 0) != NULL) { + if (interp != NULL + && Tcl_GetVar(interp, SUPPRESS_RDNS_VAR, 0) != NULL) { reverseDNS = NI_NUMERICHOST; } @@ -1326,20 +1382,23 @@ TcpGetOptionProc( address peername; socklen_t size = sizeof(peername); - if ( (statePtr->flags & TCP_ASYNC_PENDING) ) { + if (GOT_BITS(statePtr->flags, TCP_ASYNC_PENDING)) { /* * In async connect output an empty string */ + if (len == 0) { Tcl_DStringAppendElement(dsPtr, "-peername"); Tcl_DStringAppendElement(dsPtr, ""); } else { return TCL_OK; } - } else if ( getpeername(sock, (LPSOCKADDR) &(peername.sa), &size) == 0) { + } else if (getpeername(sock, (LPSOCKADDR) &(peername.sa), + &size) == 0) { /* * Peername fetch succeeded - output list */ + if (len == 0) { Tcl_DStringAppendElement(dsPtr, "-peername"); Tcl_DStringStartSublist(dsPtr); @@ -1388,11 +1447,12 @@ TcpGetOptionProc( Tcl_DStringAppendElement(dsPtr, "-sockname"); Tcl_DStringStartSublist(dsPtr); } - if ( (statePtr->flags & TCP_ASYNC_PENDING ) ) { + if (GOT_BITS(statePtr->flags, TCP_ASYNC_PENDING)) { /* * In async connect output an empty string */ - found = 1; + + found = 1; } else { for (fds = statePtr->sockets; fds != NULL; fds = fds->next) { sock = fds->fd; @@ -1406,9 +1466,11 @@ TcpGetOptionProc( Tcl_DStringAppendElement(dsPtr, host); /* - * We don't want to resolve INADDR_ANY and sin6addr_any; they - * can sometimes cause problems (and never have a name). + * We don't want to resolve INADDR_ANY and sin6addr_any; + * they can sometimes cause problems (and never have a + * name). */ + flags |= NI_NUMERICSERV; if (sockname.sa.sa_family == AF_INET) { if (sockname.sa4.sin_addr.s_addr == INADDR_ANY) { @@ -1492,7 +1554,8 @@ TcpGetOptionProc( return Tcl_BadChannelOption(interp, optionName, "connecting peername sockname keepalive nagle"); #else - return Tcl_BadChannelOption(interp, optionName, "connecting peername sockname"); + return Tcl_BadChannelOption(interp, optionName, + "connecting peername sockname"); #endif /*TCL_FEATURE_KEEPALIVE_NAGLE*/ } @@ -1519,12 +1582,12 @@ TcpGetOptionProc( static void TcpWatchProc( - ClientData instanceData, /* The socket state. */ + void *instanceData, /* The socket state. */ int mask) /* Events of interest; an OR-ed combination of * TCL_READABLE, TCL_WRITABLE and * TCL_EXCEPTION. */ { - TcpState *statePtr = instanceData; + TcpState *statePtr = (TcpState *)instanceData; /* * Update the watch events mask. Only if the socket is not a server @@ -1533,11 +1596,11 @@ TcpWatchProc( if (!statePtr->acceptProc) { statePtr->watchEvents = 0; - if (mask & TCL_READABLE) { - statePtr->watchEvents |= (FD_READ|FD_CLOSE); + if (GOT_BITS(mask, TCL_READABLE)) { + SET_BITS(statePtr->watchEvents, FD_READ | FD_CLOSE); } - if (mask & TCL_WRITABLE) { - statePtr->watchEvents |= (FD_WRITE|FD_CLOSE); + if (GOT_BITS(mask, TCL_WRITABLE)) { + SET_BITS(statePtr->watchEvents, FD_WRITE | FD_CLOSE); } /* @@ -1573,11 +1636,11 @@ TcpWatchProc( static int TcpGetHandleProc( - ClientData instanceData, /* The socket state. */ + void *instanceData, /* The socket state. */ int direction, /* Not used. */ - ClientData *handlePtr) /* Where to store the handle. */ + void **handlePtr) /* Where to store the handle. */ { - TcpState *statePtr = instanceData; + TcpState *statePtr = (TcpState *)instanceData; *handlePtr = INT2PTR(statePtr->sockets->fd); return TCL_OK; @@ -1627,25 +1690,24 @@ TcpConnect( TcpState *statePtr) { DWORD error; - /* - * We are started with async connect and the connect notification - * was not jet received - */ - int async_connect = statePtr->flags & TCP_ASYNC_CONNECT; - /* We were called by the event procedure and continue our loop */ - int async_callback = statePtr->flags & TCP_ASYNC_PENDING; - ThreadSpecificData *tsdPtr = TclThreadDataKeyGet(&dataKey); + int async_connect = GOT_BITS(statePtr->flags, TCP_ASYNC_CONNECT); + /* We are started with async connect and the + * connect notification was not yet + * received. */ + int async_callback = GOT_BITS(statePtr->flags, TCP_ASYNC_PENDING); + /* We were called by the event procedure and + * continue our loop. */ + ThreadSpecificData *tsdPtr = (ThreadSpecificData *)TclThreadDataKeyGet(&dataKey); if (async_callback) { goto reenter; } for (statePtr->addr = statePtr->addrlist; statePtr->addr != NULL; - statePtr->addr = statePtr->addr->ai_next) { - - for (statePtr->myaddr = statePtr->myaddrlist; statePtr->myaddr != NULL; - statePtr->myaddr = statePtr->myaddr->ai_next) { - + statePtr->addr = statePtr->addr->ai_next) { + for (statePtr->myaddr = statePtr->myaddrlist; + statePtr->myaddr != NULL; + statePtr->myaddr = statePtr->myaddr->ai_next) { /* * No need to try combinations of local and remote addresses * of different families. @@ -1659,25 +1721,37 @@ TcpConnect( * Close the socket if it is still open from the last unsuccessful * iteration. */ + if (statePtr->sockets->fd != INVALID_SOCKET) { closesocket(statePtr->sockets->fd); } - /* get statePtr lock */ + /* + * Get statePtr lock. + */ + WaitForSingleObject(tsdPtr->socketListLock, INFINITE); /* * Reset last error from last try */ + statePtr->notifierConnectError = 0; Tcl_SetErrno(0); - statePtr->sockets->fd = socket(statePtr->myaddr->ai_family, SOCK_STREAM, 0); + statePtr->sockets->fd = socket(statePtr->myaddr->ai_family, + SOCK_STREAM, 0); + + /* + * Free list lock. + */ - /* Free list lock */ SetEvent(tsdPtr->socketListLock); - /* continue on socket creation error */ + /* + * Continue on socket creation error. + */ + if (statePtr->sockets->fd == INVALID_SOCKET) { TclWinConvertError((DWORD) WSAGetLastError()); continue; @@ -1688,31 +1762,39 @@ TcpConnect( * processes by default. Turn off the inherit bit. */ - SetHandleInformation((HANDLE) statePtr->sockets->fd, HANDLE_FLAG_INHERIT, 0); + SetHandleInformation((HANDLE) statePtr->sockets->fd, + HANDLE_FLAG_INHERIT, 0); /* * Set kernel space buffering */ - TclSockMinimumBuffers((void *) statePtr->sockets->fd, TCP_BUFFER_SIZE); + TclSockMinimumBuffers((void *) statePtr->sockets->fd, + TCP_BUFFER_SIZE); /* * Try to bind to a local port. */ if (bind(statePtr->sockets->fd, statePtr->myaddr->ai_addr, - statePtr->myaddr->ai_addrlen) == SOCKET_ERROR) { + statePtr->myaddr->ai_addrlen) == SOCKET_ERROR) { TclWinConvertError((DWORD) WSAGetLastError()); continue; } + /* * For asynchronous connect set the socket in nonblocking mode * and activate connect notification */ + if (async_connect) { TcpState *statePtr2; int in_socket_list = 0; - /* get statePtr lock */ + + /* + * Get statePtr lock. + */ + WaitForSingleObject(tsdPtr->socketListLock, INFINITE); /* @@ -1722,8 +1804,8 @@ TcpConnect( * It is set after this call by TcpThreadActionProc and is set * on a second round. * - * If not, we buffer my statePtr in the tsd memory so it is not - * lost by the event procedure + * If not, we buffer my statePtr in the tsd memory so it is + * not lost by the event procedure */ for (statePtr2 = tsdPtr->socketList; statePtr2 != NULL; @@ -1736,21 +1818,27 @@ TcpConnect( if (!in_socket_list) { tsdPtr->pendingTcpState = statePtr; } + /* * Set connect mask to connect events - * This is activated by a SOCKET_SELECT message to the notifier - * thread. + * + * This is activated by a SOCKET_SELECT message to the + * notifier thread. */ - statePtr->selectEvents |= FD_CONNECT; + + SET_BITS(statePtr->selectEvents, FD_CONNECT); /* - * Free list lock + * Free list lock. */ + SetEvent(tsdPtr->socketListLock); - /* activate accept notification */ - SendMessageW(tsdPtr->hwnd, SOCKET_SELECT, (WPARAM) SELECT, - (LPARAM) statePtr); + /* + * Activate accept notification. + */ + + SendSelectMessage(tsdPtr, SELECT, statePtr); } /* @@ -1766,12 +1854,11 @@ TcpConnect( if (async_connect && error == WSAEWOULDBLOCK) { /* * Asynchroneous connect - */ - - /* + * * Remember that we jump back behind this next round */ - statePtr->flags |= TCP_ASYNC_PENDING; + + SET_BITS(statePtr->flags, TCP_ASYNC_PENDING); return TCL_OK; reenter: @@ -1781,14 +1868,31 @@ TcpConnect( * * Clear the reenter flag */ - statePtr->flags &= ~(TCP_ASYNC_PENDING); - /* get statePtr lock */ + + CLEAR_BITS(statePtr->flags, TCP_ASYNC_PENDING); + + /* + * Get statePtr lock. + */ + WaitForSingleObject(tsdPtr->socketListLock, INFINITE); - /* Get signaled connect error */ + + /* + * Get signaled connect error. + */ + TclWinConvertError((DWORD) statePtr->notifierConnectError); - /* Clear eventual connect flag */ - statePtr->selectEvents &= ~(FD_CONNECT); - /* Free list lock */ + + /* + * Clear eventual connect flag. + */ + + CLEAR_BITS(statePtr->selectEvents, FD_CONNECT); + + /* + * Free list lock. + */ + SetEvent(tsdPtr->socketListLock); } @@ -1796,6 +1900,7 @@ TcpConnect( * Clear the tsd socket list pointer if we did not wait for * the FD_CONNECT asynchronously */ + tsdPtr->pendingTcpState = NULL; if (Tcl_GetErrno() == 0) { @@ -1804,7 +1909,7 @@ TcpConnect( } } -out: + out: /* * Socket connected or connection failed */ @@ -1815,13 +1920,13 @@ out: CLEAR_BITS(statePtr->flags, TCP_ASYNC_CONNECT); - if ( Tcl_GetErrno() == 0 ) { + if (Tcl_GetErrno() == 0) { /* * Succesfully connected - */ - /* + * * Set up the select mask for read/write events. */ + statePtr->selectEvents = FD_READ | FD_WRITE | FD_CLOSE; /* @@ -1829,35 +1934,56 @@ out: * automatically places the socket into non-blocking mode. */ - SendMessageW(tsdPtr->hwnd, SOCKET_SELECT, (WPARAM) SELECT, - (LPARAM) statePtr); + SendSelectMessage(tsdPtr, SELECT, statePtr); } else { /* * Connect failed - */ - - /* + * * For async connect schedule a writable event to report the fail. */ + if (async_callback) { /* * Set up the select mask for read/write events. */ + statePtr->selectEvents = FD_WRITE|FD_READ; - /* get statePtr lock */ + + /* + * Get statePtr lock. + */ + WaitForSingleObject(tsdPtr->socketListLock, INFINITE); - /* Signal ready readable and writable events */ - statePtr->readyEvents |= FD_WRITE | FD_READ; - /* Flag error to event routine */ - statePtr->flags |= TCP_ASYNC_FAILED; - /* Save connect error to be reported by 'fconfigure -error' */ + + /* + * Signal ready readable and writable events. + */ + + SET_BITS(statePtr->readyEvents, FD_WRITE | FD_READ); + + /* + * Flag error to event routine. + */ + + SET_BITS(statePtr->flags, TCP_ASYNC_FAILED); + + /* + * Save connect error to be reported by 'fconfigure -error'. + */ + statePtr->connectError = Tcl_GetErrno(); - /* Free list lock */ + + /* + * Free list lock. + */ + SetEvent(tsdPtr->socketListLock); } + /* * Error message on synchroneous connect */ + if (interp != NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "couldn't open socket: %s", Tcl_PosixError(interp))); @@ -1935,7 +2061,7 @@ Tcl_OpenTcpClient( statePtr->addrlist = addrlist; statePtr->myaddrlist = myaddrlist; if (async) { - statePtr->flags |= TCP_ASYNC_CONNECT; + SET_BITS(statePtr->flags, TCP_ASYNC_CONNECT); } /* @@ -1980,7 +2106,7 @@ Tcl_OpenTcpClient( Tcl_Channel Tcl_MakeTcpClientChannel( - ClientData sock) /* The socket to wrap up into a channel. */ + void *sock) /* The socket to wrap up into a channel. */ { TcpState *statePtr; char channelName[SOCK_CHAN_LENGTH]; @@ -1990,7 +2116,7 @@ Tcl_MakeTcpClientChannel( return NULL; } - tsdPtr = TclThreadDataKeyGet(&dataKey); + tsdPtr = (ThreadSpecificData *)TclThreadDataKeyGet(&dataKey); /* * Set kernel space buffering and non-blocking. @@ -2005,7 +2131,7 @@ Tcl_MakeTcpClientChannel( */ statePtr->selectEvents = FD_READ | FD_CLOSE | FD_WRITE; - SendMessageW(tsdPtr->hwnd, SOCKET_SELECT, (WPARAM)SELECT, (LPARAM)statePtr); + SendSelectMessage(tsdPtr, SELECT, statePtr); sprintf(channelName, SOCK_TEMPLATE, statePtr); statePtr->channel = Tcl_CreateChannel(&tcpChannelType, channelName, @@ -2039,7 +2165,7 @@ Tcl_OpenTcpServer( Tcl_TcpAcceptProc *acceptProc, /* Callback for accepting connections from new * clients. */ - ClientData acceptProcData) /* Data for the callback. */ + void *acceptProcData) /* Data for the callback. */ { SOCKET sock = INVALID_SOCKET; unsigned short chosenport = 0; @@ -2068,7 +2194,8 @@ Tcl_OpenTcpServer( * Construct the addresses for each end of the socket. */ - if (!TclCreateSocketAddress(interp, &addrlist, myHost, port, 1, &errorMsg)) { + if (!TclCreateSocketAddress(interp, &addrlist, myHost, port, 1, + &errorMsg)) { goto error; } @@ -2116,8 +2243,8 @@ Tcl_OpenTcpServer( * place to look for bugs. */ - if (bind(sock, addrPtr->ai_addr, addrPtr->ai_addrlen) - == SOCKET_ERROR) { + if (bind(sock, addrPtr->ai_addr, + addrPtr->ai_addrlen) == SOCKET_ERROR) { TclWinConvertError((DWORD) WSAGetLastError()); closesocket(sock); continue; @@ -2152,19 +2279,20 @@ Tcl_OpenTcpServer( /* * Add this socket to the global list of sockets. */ + statePtr = NewSocketInfo(sock); } else { - AddSocketInfoFd( statePtr, sock ); + AddSocketInfoFd(statePtr, sock); } } -error: + error: if (addrlist != NULL) { freeaddrinfo(addrlist); } if (statePtr != NULL) { - ThreadSpecificData *tsdPtr = TclThreadDataKeyGet(&dataKey); + ThreadSpecificData *tsdPtr = (ThreadSpecificData *)TclThreadDataKeyGet(&dataKey); statePtr->acceptProc = acceptProc; statePtr->acceptProcData = acceptProcData; @@ -2183,8 +2311,7 @@ error: */ ioctlsocket(sock, (long) FIONBIO, &flag); - SendMessageW(tsdPtr->hwnd, SOCKET_SELECT, (WPARAM) SELECT, - (LPARAM) statePtr); + SendSelectMessage(tsdPtr, SELECT, statePtr); if (Tcl_SetChannelOption(interp, statePtr->channel, "-eofchar", "") == TCL_ERROR) { Tcl_Close(NULL, statePtr->channel); @@ -2232,7 +2359,7 @@ TcpAccept( int len = sizeof(addr); char channelName[SOCK_CHAN_LENGTH]; char host[NI_MAXHOST], port[NI_MAXSERV]; - ThreadSpecificData *tsdPtr = TclThreadDataKeyGet(&dataKey); + ThreadSpecificData *tsdPtr = (ThreadSpecificData *)TclThreadDataKeyGet(&dataKey); /* * Win-NT has a misfeature that sockets are inherited in child processes @@ -2252,8 +2379,7 @@ TcpAccept( */ newInfoPtr->selectEvents = (FD_READ | FD_WRITE | FD_CLOSE); - SendMessageW(tsdPtr->hwnd, SOCKET_SELECT, (WPARAM) SELECT, - (LPARAM) newInfoPtr); + SendSelectMessage(tsdPtr, SELECT, newInfoPtr); sprintf(channelName, SOCK_TEMPLATE, newInfoPtr); newInfoPtr->channel = Tcl_CreateChannel(&tcpChannelType, channelName, @@ -2304,7 +2430,7 @@ static void InitSockets(void) { DWORD id; - ThreadSpecificData *tsdPtr = TclThreadDataKeyGet(&dataKey); + ThreadSpecificData *tsdPtr = (ThreadSpecificData *)TclThreadDataKeyGet(&dataKey); if (!initialized) { initialized = 1; @@ -2320,10 +2446,10 @@ InitSockets(void) windowClass.style = 0; windowClass.cbClsExtra = 0; windowClass.cbWndExtra = 0; - windowClass.hInstance = TclWinGetTclInstance(); + windowClass.hInstance = (HINSTANCE)TclWinGetTclInstance(); windowClass.hbrBackground = NULL; windowClass.lpszMenuName = NULL; - windowClass.lpszClassName = classname; + windowClass.lpszClassName = className; windowClass.lpfnWndProc = SocketProc; windowClass.hIcon = NULL; windowClass.hCursor = NULL; @@ -2441,7 +2567,7 @@ SocketsEnabled(void) static void SocketExitHandler( - ClientData clientData) /* Not used. */ + void *clientData) /* Not used. */ { Tcl_MutexLock(&socketMutex); @@ -2451,7 +2577,7 @@ SocketExitHandler( */ TclpFinalizeSockets(); - UnregisterClassW(classname, TclWinGetTclInstance()); + UnregisterClassW(className, (HINSTANCE)TclWinGetTclInstance()); initialized = 0; Tcl_MutexUnlock(&socketMutex); } @@ -2475,14 +2601,14 @@ SocketExitHandler( void SocketSetupProc( - ClientData data, /* Not used. */ + void *data, /* Not used. */ int flags) /* Event flags as passed to Tcl_DoOneEvent. */ { TcpState *statePtr; Tcl_Time blockTime = { 0, 0 }; ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); - if (!(flags & TCL_FILE_EVENTS)) { + if (!GOT_BITS(flags, TCL_FILE_EVENTS)) { return; } @@ -2492,9 +2618,8 @@ SocketSetupProc( WaitForSingleObject(tsdPtr->socketListLock, INFINITE); for (statePtr = tsdPtr->socketList; statePtr != NULL; statePtr = statePtr->nextPtr) { - if (statePtr->readyEvents & - (statePtr->watchEvents | FD_CONNECT | FD_ACCEPT) - ) { + if (GOT_BITS(statePtr->readyEvents, + statePtr->watchEvents | FD_CONNECT | FD_ACCEPT)) { Tcl_SetMaxBlockTime(&blockTime); break; } @@ -2521,14 +2646,14 @@ SocketSetupProc( static void SocketCheckProc( - ClientData data, /* Not used. */ + void *data, /* Not used. */ int flags) /* Event flags as passed to Tcl_DoOneEvent. */ { TcpState *statePtr; SocketEvent *evPtr; ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); - if (!(flags & TCL_FILE_EVENTS)) { + if (!GOT_BITS(flags, TCL_FILE_EVENTS)) { return; } @@ -2541,12 +2666,11 @@ SocketCheckProc( WaitForSingleObject(tsdPtr->socketListLock, INFINITE); for (statePtr = tsdPtr->socketList; statePtr != NULL; statePtr = statePtr->nextPtr) { - if ((statePtr->readyEvents & - (statePtr->watchEvents | FD_CONNECT | FD_ACCEPT)) - && !(statePtr->flags & SOCKET_PENDING) - ) { - statePtr->flags |= SOCKET_PENDING; - evPtr = ckalloc(sizeof(SocketEvent)); + if (GOT_BITS(statePtr->readyEvents, + statePtr->watchEvents | FD_CONNECT | FD_ACCEPT) + && !GOT_BITS(statePtr->flags, SOCKET_PENDING)) { + SET_BITS(statePtr->flags, SOCKET_PENDING); + evPtr = (SocketEvent *)ckalloc(sizeof(SocketEvent)); evPtr->header.proc = SocketEventProc; evPtr->socket = statePtr->sockets->fd; Tcl_QueueEvent((Tcl_Event *) evPtr, TCL_QUEUE_TAIL); @@ -2591,7 +2715,7 @@ SocketEventProc( address addr; int len; - if (!(flags & TCL_FILE_EVENTS)) { + if (!GOT_BITS(flags, TCL_FILE_EVENTS)) { return 0; } @@ -2620,29 +2744,26 @@ SocketEventProc( * Clear flag that (this) event is pending */ - statePtr->flags &= ~SOCKET_PENDING; + CLEAR_BITS(statePtr->flags, SOCKET_PENDING); /* * Continue async connect if pending and ready */ - if ( statePtr->readyEvents & FD_CONNECT ) { - if ( statePtr->flags & TCP_ASYNC_PENDING ) { - + if (GOT_BITS(statePtr->readyEvents, FD_CONNECT)) { + if (GOT_BITS(statePtr->flags, TCP_ASYNC_PENDING)) { /* * Do one step and save eventual connect error */ SetEvent(tsdPtr->socketListLock); WaitForConnect(statePtr,NULL); - } else { - /* * No async connect reenter pending. Just clear event. */ - statePtr->readyEvents &= ~(FD_CONNECT); + CLEAR_BITS(statePtr->readyEvents, FD_CONNECT); SetEvent(tsdPtr->socketListLock); } return 1; @@ -2651,20 +2772,23 @@ SocketEventProc( /* * Handle connection requests directly. */ - if (statePtr->readyEvents & FD_ACCEPT) { - for (fds = statePtr->sockets; fds != NULL; fds = fds->next) { + if (GOT_BITS(statePtr->readyEvents, FD_ACCEPT)) { + for (fds = statePtr->sockets; fds != NULL; fds = fds->next) { /* - * Accept the incoming connection request. - */ - len = sizeof(address); + * Accept the incoming connection request. + */ + len = sizeof(address); newSocket = accept(fds->fd, &(addr.sa), &len); - /* On Tcl server sockets with multiple OS fds we loop over the fds trying - * an accept() on each, so we expect INVALID_SOCKET. There are also other - * network stack conditions that can result in FD_ACCEPT but a subsequent - * failure on accept() by the time we get around to it. + /* + * On Tcl server sockets with multiple OS fds we loop over the fds + * trying an accept() on each, so we expect INVALID_SOCKET. There + * are also other network stack conditions that can result in + * FD_ACCEPT but a subsequent failure on accept() by the time we + * get around to it. + * * Access to sockets (acceptEventCount, readyEvents) in socketList * is still protected by the lock (prevents reintroduction of * SF Tcl Bug 3056775. @@ -2676,35 +2800,40 @@ SocketEventProc( } /* - * It is possible that more than one FD_ACCEPT has been sent, so an extra - * count must be kept. Decrement the count, and reset the readyEvent bit - * if the count is no longer > 0. + * It is possible that more than one FD_ACCEPT has been sent, so + * an extra count must be kept. Decrement the count, and reset the + * readyEvent bit if the count is no longer > 0. */ + statePtr->acceptEventCount--; if (statePtr->acceptEventCount <= 0) { - statePtr->readyEvents &= ~(FD_ACCEPT); + CLEAR_BITS(statePtr->readyEvents, FD_ACCEPT); } SetEvent(tsdPtr->socketListLock); - /* Caution: TcpAccept() has the side-effect of evaluating the server - * accept script (via AcceptCallbackProc() in tclIOCmd.c), which can - * close the server socket and invalidate statePtr and fds. - * If TcpAccept() accepts a socket we must return immediately and let - * SocketCheckProc queue additional FD_ACCEPT events. + /* + * Caution: TcpAccept() has the side-effect of evaluating the + * server accept script (via AcceptCallbackProc() in tclIOCmd.c), + * which can close the server socket and invalidate statePtr and + * fds. If TcpAccept() accepts a socket we must return immediately + * and let SocketCheckProc queue additional FD_ACCEPT events. */ + TcpAccept(fds, newSocket, addr); return 1; } - /* Loop terminated with no sockets accepted; clear the ready mask so + /* + * Loop terminated with no sockets accepted; clear the ready mask so * we can detect the next connection request. Note that connection * requests are level triggered, so if there is a request already * pending, a new event will be generated. */ + statePtr->acceptEventCount = 0; - statePtr->readyEvents &= ~(FD_ACCEPT); + CLEAR_BITS(statePtr->readyEvents, FD_ACCEPT); SetEvent(tsdPtr->socketListLock); return 1; @@ -2719,7 +2848,7 @@ SocketEventProc( events = statePtr->readyEvents & statePtr->watchEvents; - if (events & FD_CLOSE) { + if (GOT_BITS(events, FD_CLOSE)) { /* * If the socket was closed and the channel is still interested in * read events, then we need to ensure that we keep polling for this @@ -2733,17 +2862,14 @@ SocketEventProc( Tcl_Time blockTime = { 0, 0 }; Tcl_SetMaxBlockTime(&blockTime); - mask |= TCL_READABLE|TCL_WRITABLE; - } else if (events & FD_READ) { - + SET_BITS(mask, TCL_READABLE | TCL_WRITABLE); + } else if (GOT_BITS(events, FD_READ)) { /* * Throw the readable event if an async connect failed. */ - if ( statePtr->flags & TCP_ASYNC_FAILED ) { - - mask |= TCL_READABLE; - + if (GOT_BITS(statePtr->flags, TCP_ASYNC_FAILED)) { + SET_BITS(mask, TCL_READABLE); } else { fd_set readFds; struct timeval timeout; @@ -2756,8 +2882,7 @@ SocketEventProc( * async select handler and keep waiting. */ - SendMessageW(tsdPtr->hwnd, SOCKET_SELECT, - (WPARAM) UNSELECT, (LPARAM) statePtr); + SendSelectMessage(tsdPtr, UNSELECT, statePtr); FD_ZERO(&readFds); FD_SET(statePtr->sockets->fd, &readFds); @@ -2765,11 +2890,10 @@ SocketEventProc( timeout.tv_sec = 0; if (select(0, &readFds, NULL, NULL, &timeout) != 0) { - mask |= TCL_READABLE; + SET_BITS(mask, TCL_READABLE); } else { - statePtr->readyEvents &= ~(FD_READ); - SendMessageW(tsdPtr->hwnd, SOCKET_SELECT, - (WPARAM) SELECT, (LPARAM) statePtr); + CLEAR_BITS(statePtr->readyEvents, FD_READ); + SendSelectMessage(tsdPtr, SELECT, statePtr); } } } @@ -2778,8 +2902,8 @@ SocketEventProc( * writable event */ - if (events & FD_WRITE) { - mask |= TCL_WRITABLE; + if (GOT_BITS(events, FD_WRITE)) { + SET_BITS(mask, TCL_WRITABLE); } /* @@ -2816,21 +2940,30 @@ AddSocketInfoFd( { TcpFdList *fds = statePtr->sockets; - if ( fds == NULL ) { - /* Add the first FD */ - statePtr->sockets = ckalloc(sizeof(TcpFdList)); + if (fds == NULL) { + /* + * Add the first FD. + */ + + statePtr->sockets = (TcpFdList *)ckalloc(sizeof(TcpFdList)); fds = statePtr->sockets; } else { - /* Find end of list and append FD */ - while ( fds->next != NULL ) { + /* + * Find end of list and append FD. + */ + + while (fds->next != NULL) { fds = fds->next; } - fds->next = ckalloc(sizeof(TcpFdList)); + fds->next = (TcpFdList *)ckalloc(sizeof(TcpFdList)); fds = fds->next; } - /* Populate new FD */ + /* + * Populate new FD. + */ + fds->fd = socket; fds->statePtr = statePtr; fds->next = NULL; @@ -2856,7 +2989,7 @@ AddSocketInfoFd( static TcpState * NewSocketInfo(SOCKET socket) { - TcpState *statePtr = ckalloc(sizeof(TcpState)); + TcpState *statePtr = (TcpState *)ckalloc(sizeof(TcpState)); memset(statePtr, 0, sizeof(TcpState)); @@ -2899,7 +3032,8 @@ WaitForSocketEvent( { int result = 1; int oldMode; - ThreadSpecificData *tsdPtr = TclThreadDataKeyGet(&dataKey); + ThreadSpecificData *tsdPtr = (ThreadSpecificData *)TclThreadDataKeyGet(&dataKey); + /* * Be sure to disable event servicing so we are truly modal. */ @@ -2910,29 +3044,42 @@ WaitForSocketEvent( * Reset WSAAsyncSelect so we have a fresh set of events pending. */ - SendMessageW(tsdPtr->hwnd, SOCKET_SELECT, (WPARAM) UNSELECT, - (LPARAM) statePtr); - SendMessageW(tsdPtr->hwnd, SOCKET_SELECT, (WPARAM) SELECT, - (LPARAM) statePtr); + SendSelectMessage(tsdPtr, UNSELECT, statePtr); + SendSelectMessage(tsdPtr, SELECT, statePtr); while (1) { int event_found; - /* get statePtr lock */ + /* + * Get statePtr lock. + */ + WaitForSingleObject(tsdPtr->socketListLock, INFINITE); - /* Check if event occured */ - event_found = (statePtr->readyEvents & events); + /* + * Check if event occured. + */ + + event_found = GOT_BITS(statePtr->readyEvents, events); + + /* + * Free list lock. + */ - /* Free list lock */ SetEvent(tsdPtr->socketListLock); - /* exit loop if event occured */ + /* + * Exit loop if event occured. + */ + if (event_found) { break; } - /* Exit loop if event did not occur but this is a non-blocking channel */ + /* + * Exit loop if event did not occur but this is a non-blocking channel + */ + if (statePtr->flags & TCP_NONBLOCKING) { *errorCodePtr = EWOULDBLOCK; result = 0; @@ -2971,13 +3118,13 @@ SocketThread( LPVOID arg) { MSG msg; - ThreadSpecificData *tsdPtr = arg; + ThreadSpecificData *tsdPtr = (ThreadSpecificData *)arg; /* * Create a dummy window receiving socket events. */ - tsdPtr->hwnd = CreateWindowW(classname, classname, WS_TILED, 0, 0, 0, 0, + tsdPtr->hwnd = CreateWindowW(className, className, WS_TILED, 0, 0, 0, 0, NULL, NULL, windowClass.hInstance, arg); /* @@ -3089,55 +3236,59 @@ SocketProc( for (statePtr = tsdPtr->socketList; statePtr != NULL; statePtr = statePtr->nextPtr) { - if ( FindFDInList(statePtr,socket) ) { + if (FindFDInList(statePtr, socket)) { info_found = 1; break; } } + /* - * Check if there is a pending info structure not jet in the - * list + * Check if there is a pending info structure not jet in the list. */ - if ( !info_found + + if (!info_found && tsdPtr->pendingTcpState != NULL - && FindFDInList(tsdPtr->pendingTcpState,socket) ) { + && FindFDInList(tsdPtr->pendingTcpState, socket)) { statePtr = tsdPtr->pendingTcpState; info_found = 1; } if (info_found) { - /* * Update the socket state. * * A count of FD_ACCEPTS is stored, so if an FD_CLOSE event - * happens, then clear the FD_ACCEPT count. Otherwise, - * increment the count if the current event is an FD_ACCEPT. + * happens, then clear the FD_ACCEPT count. Otherwise, increment + * the count if the current event is an FD_ACCEPT. */ - if (event & FD_CLOSE) { + if (GOT_BITS(event, FD_CLOSE)) { statePtr->acceptEventCount = 0; - statePtr->readyEvents &= ~(FD_WRITE|FD_ACCEPT); - } else if (event & FD_ACCEPT) { + CLEAR_BITS(statePtr->readyEvents, FD_WRITE | FD_ACCEPT); + } else if (GOT_BITS(event, FD_ACCEPT)) { statePtr->acceptEventCount++; } - if (event & FD_CONNECT) { + if (GOT_BITS(event, FD_CONNECT)) { /* * Remember any error that occurred so we can report * connection failures. */ + if (error != ERROR_SUCCESS) { statePtr->notifierConnectError = error; } } + /* * Inform main thread about signaled events */ - statePtr->readyEvents |= event; + + SET_BITS(statePtr->readyEvents, event); /* * Wake up the Main Thread. */ + SetEvent(tsdPtr->readyEvent); Tcl_ThreadAlert(tsdPtr->threadId); } @@ -3276,11 +3427,11 @@ TclWinGetServByName( static void TcpThreadActionProc( - ClientData instanceData, + void *instanceData, int action) { ThreadSpecificData *tsdPtr; - TcpState *statePtr = instanceData; + TcpState *statePtr = (TcpState *)instanceData; int notifyCmd; if (action == TCL_CHANNEL_THREAD_INSERT) { @@ -3346,8 +3497,7 @@ TcpThreadActionProc( * thread. */ - SendMessageW(tsdPtr->hwnd, SOCKET_SELECT, - (WPARAM) notifyCmd, (LPARAM) statePtr); + SendSelectMessage(tsdPtr, notifyCmd, statePtr); } /* -- cgit v0.12