From a455c140eaab90a3f1f588ce4e8a841e2b260fa6 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 10 Mar 2022 10:26:01 +0000 Subject: Unused variable warning --- generic/tclTestObj.c | 2 ++ 1 file changed, 2 insertions(+) diff --git a/generic/tclTestObj.c b/generic/tclTestObj.c index 9081bcf..a235002 100644 --- a/generic/tclTestObj.c +++ b/generic/tclTestObj.c @@ -659,7 +659,9 @@ TestintobjCmd( Tcl_Obj *const objv[]) /* Argument objects. */ { size_t varIndex; +#if (INT_MAX != LONG_MAX) /* int is not the same size as long */ int i; +#endif Tcl_WideInt wideValue; const char *subCmd; Tcl_Obj **varPtr; -- cgit v0.12 From a9c0e83fb00eef6b3be5db888dfa2cfad2c0eb52 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 10 Mar 2022 10:37:44 +0000 Subject: Eliminate nmake build warning --- win/makefile.vc | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/win/makefile.vc b/win/makefile.vc index 6b2a682..1ef64f2 100644 --- a/win/makefile.vc +++ b/win/makefile.vc @@ -819,7 +819,8 @@ $(TMP_DIR)\tclEvent.obj: $(GENERICDIR)\tclEvent.c $(TMP_DIR)\tclUuid.h -Fo$@ $(GENERICDIR)\tclEvent.c $(TMP_DIR)\tclTest.obj: $(GENERICDIR)\tclTest.c $(TMP_DIR)\tclUuid.h - $(cc32) $(appcflags) -I$(TMP_DIR) -Fo$@ $? + $(cc32) $(appcflags) -I$(TMP_DIR) \ + -Fo$@ $(GENERICDIR)\tclTest.c $(TMP_DIR)\tclTestObj.obj: $(GENERICDIR)\tclTestObj.c $(cc32) $(appcflags) -Fo$@ $? -- cgit v0.12 From 500e2ceb70e7a57505c5d12828ed6a1145736ae9 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 10 Mar 2022 11:43:16 +0000 Subject: Add ::tcl::test::build-info command to tcl::test package, so we can find out which compiler/options the test package is compiled with (TIP #599) --- generic/tclTest.c | 90 ++++++++++++++++++++++++++++++++++++++++++++++++++++++- 1 file changed, 89 insertions(+), 1 deletion(-) diff --git a/generic/tclTest.c b/generic/tclTest.c index 1564bd5..ee29cb1 100644 --- a/generic/tclTest.c +++ b/generic/tclTest.c @@ -41,6 +41,8 @@ */ #include "tclIO.h" +#include "tclUuid.h" + /* * Declare external functions used in Windows tests. */ @@ -438,10 +440,84 @@ static const Tcl_Filesystem simpleFilesystem = { *---------------------------------------------------------------------- */ +#ifndef STRINGIFY +# define STRINGIFY(x) STRINGIFY1(x) +# define STRINGIFY1(x) #x +#endif + +static const char version[] = TCL_PATCH_LEVEL "+" STRINGIFY(TCL_VERSION_UUID) +#if defined(__clang__) && defined(__clang_major__) + ".clang-" STRINGIFY(__clang_major__) +#if __clang_minor__ < 10 + "0" +#endif + STRINGIFY(__clang_minor__) +#endif +#ifdef TCL_COMPILE_DEBUG + ".compiledebug" +#endif +#ifdef TCL_COMPILE_STATS + ".compilestats" +#endif +#if defined(__cplusplus) && !defined(__OBJC__) + ".cplusplus" +#endif +#ifndef NDEBUG + ".debug" +#endif +#if !defined(__clang__) && !defined(__INTEL_COMPILER) && defined(__GNUC__) + ".gcc-" STRINGIFY(__GNUC__) +#if __GNUC_MINOR__ < 10 + "0" +#endif + STRINGIFY(__GNUC_MINOR__) +#endif +#ifdef __INTEL_COMPILER + ".icc-" STRINGIFY(__INTEL_COMPILER) +#endif +#if (defined(_WIN32) && !defined(_WIN64)) || (ULONG_MAX == 0xffffffffUL) + ".ilp32" +#endif +#ifdef TCL_MEM_DEBUG + ".memdebug" +#endif +#if defined(_MSC_VER) + ".msvc-" STRINGIFY(_MSC_VER) +#endif +#ifdef USE_NMAKE + ".nmake" +#endif +#if !TCL_THREADS + ".no-thread" +#endif +#ifndef TCL_CFG_OPTIMIZED + ".no-optimize" +#endif +#ifdef __OBJC__ + ".objective-c" +#if defined(__cplusplus) + "plusplus" +#endif +#endif +#ifdef TCL_CFG_PROFILED + ".profile" +#endif +#ifdef PURIFY + ".purify" +#endif +#ifdef STATIC_BUILD + ".static" +#endif +#if TCL_UTF_MAX < 4 + ".utf-16" +#endif +; + int Tcltest_Init( Tcl_Interp *interp) /* Interpreter for application. */ { + Tcl_CmdInfo info; Tcl_Obj **objv, *objPtr; int objc, index; static const char *const specialOptions[] = { @@ -460,8 +536,11 @@ Tcltest_Init( if (Tcl_OOInitStubs(interp) == NULL) { return TCL_ERROR; } - /* TIP #268: Full patchlevel instead of just major.minor */ + if (Tcl_GetCommandInfo(interp, "::tcl::build-info", &info)) { + Tcl_CreateObjCommand(interp, "::tcl::test::build-info", + info.objProc, (void *)version, NULL); + } if (Tcl_PkgProvideEx(interp, "tcl::test", TCL_PATCH_LEVEL, NULL) == TCL_ERROR) { return TCL_ERROR; } @@ -706,9 +785,18 @@ int Tcltest_SafeInit( Tcl_Interp *interp) /* Interpreter for application. */ { + Tcl_CmdInfo info; + if (Tcl_InitStubs(interp, "8.5-", 0) == NULL) { return TCL_ERROR; } + if (Tcl_GetCommandInfo(interp, "::tcl::build-info", &info)) { + Tcl_CreateObjCommand(interp, "::tcl::test::build-info", + info.objProc, (void *)version, NULL); + } + if (Tcl_PkgProvideEx(interp, "tcl::test", TCL_PATCH_LEVEL, NULL) == TCL_ERROR) { + return TCL_ERROR; + } return Procbodytest_SafeInit(interp); } -- cgit v0.12 From 643fbd40d93f1432a5465323319edaa756f309f8 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 10 Mar 2022 14:03:08 +0000 Subject: Enhance internal "struct CoroutineData" such that it can handle more than 2^31 levels/arguments --- generic/tclBasic.c | 27 +++++++++++++-------------- generic/tclInt.h | 4 ++-- generic/tclZipfs.c | 18 ++++++------------ 3 files changed, 21 insertions(+), 28 deletions(-) diff --git a/generic/tclBasic.c b/generic/tclBasic.c index 2d86e9c..dbb20a5 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -220,8 +220,8 @@ MODULE_SCOPE const TclStubs tclStubs; #define CORO_ACTIVATE_YIELD PTR2INT(NULL) #define CORO_ACTIVATE_YIELDM PTR2INT(NULL)+1 -#define COROUTINE_ARGUMENTS_SINGLE_OPTIONAL (-1) -#define COROUTINE_ARGUMENTS_ARBITRARY (-2) +#define COROUTINE_ARGUMENTS_SINGLE_OPTIONAL ((size_t)-1) +#define COROUTINE_ARGUMENTS_ARBITRARY ((size_t)-2) /* * The following structure define the commands in the Tcl core. @@ -8956,9 +8956,8 @@ TclNRCoroutineActivateCallback( TCL_UNUSED(int) /*result*/) { CoroutineData *corPtr = (CoroutineData *)data[0]; - int type = PTR2INT(data[1]); - int numLevels, unused; - int *stackLevel = &unused; + int unused, type = PTR2INT(data[1]); + size_t numLevels; if (!corPtr->stackLevel) { /* @@ -8975,7 +8974,7 @@ TclNRCoroutineActivateCallback( * the interp's environment to make it suitable to run this coroutine. */ - corPtr->stackLevel = stackLevel; + corPtr->stackLevel = &unused; numLevels = corPtr->auxNumLevels; corPtr->auxNumLevels = iPtr->numLevels; @@ -8989,7 +8988,7 @@ TclNRCoroutineActivateCallback( * Coroutine is active: yield */ - if (corPtr->stackLevel != stackLevel) { + if (corPtr->stackLevel != &unused) { NRE_callback *runPtr; iPtr->execEnvPtr = corPtr->callerEEPtr; @@ -9217,8 +9216,8 @@ TclNRCoroProbeObjCmd( { CoroutineData *corPtr; ExecEnv *savedEEPtr = iPtr->execEnvPtr; - int numLevels, unused; - int *stackLevel = &unused; + size_t numLevels; + int unused; /* * Usage more or less like tailcall: @@ -9268,7 +9267,7 @@ TclNRCoroProbeObjCmd( * the interp's environment to make it suitable to run this coroutine. */ - corPtr->stackLevel = stackLevel; + corPtr->stackLevel = &unused; numLevels = corPtr->auxNumLevels; corPtr->auxNumLevels = iPtr->numLevels; @@ -9313,7 +9312,7 @@ InjectHandler( { CoroutineData *corPtr = (CoroutineData *)data[0]; Tcl_Obj *listPtr = (Tcl_Obj *)data[1]; - int nargs = PTR2INT(data[2]); + size_t nargs = PTR2INT(data[2]); void *isProbe = data[3]; int objc; Tcl_Obj **objv; @@ -9334,7 +9333,7 @@ InjectHandler( * I don't think this is reachable... */ - Tcl_ListObjAppendElement(NULL, listPtr, Tcl_NewIntObj(nargs)); + Tcl_ListObjAppendElement(NULL, listPtr, Tcl_NewWideIntObj((Tcl_WideInt)(nargs + 1U) - 1)); } Tcl_ListObjAppendElement(NULL, listPtr, Tcl_GetObjResult(interp)); } @@ -9359,7 +9358,7 @@ InjectHandlerPostCall( { CoroutineData *corPtr = (CoroutineData *)data[0]; Tcl_Obj *listPtr = (Tcl_Obj *)data[1]; - int nargs = PTR2INT(data[2]); + size_t nargs = PTR2INT(data[2]); void *isProbe = data[3]; int numLevels; @@ -9479,7 +9478,7 @@ TclNRInterpCoroutine( } break; default: - if (corPtr->nargs != objc-1) { + if (corPtr->nargs + 1 != (size_t)objc) { Tcl_SetObjResult(interp, Tcl_NewStringObj("wrong coro nargs; how did we get here? " "not implemented!", -1)); diff --git a/generic/tclInt.h b/generic/tclInt.h index 8678a57..bdf7990 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -1473,11 +1473,11 @@ typedef struct CoroutineData { CorContext running; Tcl_HashTable *lineLABCPtr; /* See Interp.lineLABCPtr */ void *stackLevel; - int auxNumLevels; /* While the coroutine is running the + size_t auxNumLevels; /* While the coroutine is running the * numLevels of the create/resume command is * stored here; for suspended coroutines it * holds the nesting numLevels at yield. */ - int nargs; /* Number of args required for resuming this + size_t nargs; /* Number of args required for resuming this * coroutine; COROUTINE_ARGUMENTS_SINGLE_OPTIONAL means "0 or 1" * (default), COROUTINE_ARGUMENTS_ARBITRARY means "any" */ Tcl_Obj *yieldPtr; /* The command to yield to. Stored here in diff --git a/generic/tclZipfs.c b/generic/tclZipfs.c index b63cce7..906eff4 100644 --- a/generic/tclZipfs.c +++ b/generic/tclZipfs.c @@ -428,12 +428,6 @@ static Tcl_ChannelType ZipChannelType = { }; /* - * Miscellaneous constants. - */ - -#define ERROR_LENGTH ((size_t) -1) - -/* *------------------------------------------------------------------------- * * ZipReadInt, ZipReadShort, ZipWriteInt, ZipWriteShort -- @@ -1387,7 +1381,7 @@ ZipFSOpenArchive( */ zf->length = Tcl_Seek(zf->chan, 0, SEEK_END); - if (zf->length == ERROR_LENGTH) { + if (zf->length == TCL_INDEX_NONE) { ZIPFS_POSIX_ERROR(interp, "seek error"); goto error; } @@ -1486,7 +1480,7 @@ ZipMapArchive( */ zf->length = lseek(fd, 0, SEEK_END); - if (zf->length == ERROR_LENGTH || zf->length < ZIP_CENTRAL_END_LEN) { + if (zf->length == TCL_INDEX_NONE || zf->length < ZIP_CENTRAL_END_LEN) { ZIPFS_POSIX_ERROR(interp, "invalid file size"); return TCL_ERROR; } @@ -2582,7 +2576,7 @@ ZipAddFile( nbyte = nbytecompr = 0; while (1) { len = Tcl_Read(in, buf, bufsize); - if (len == ERROR_LENGTH) { + if (len == TCL_INDEX_NONE) { Tcl_DStringFree(&zpathDs); if (nbyte == 0 && errno == EISDIR) { Tcl_Close(interp, in); @@ -2712,7 +2706,7 @@ ZipAddFile( do { len = Tcl_Read(in, buf, bufsize); - if (len == ERROR_LENGTH) { + if (len == TCL_INDEX_NONE) { deflateEnd(&stream); goto readErrorWithChannelOpen; } @@ -2776,7 +2770,7 @@ ZipAddFile( nbytecompr = (passwd ? 12 : 0); while (1) { len = Tcl_Read(in, buf, bufsize); - if (len == ERROR_LENGTH) { + if (len == TCL_INDEX_NONE) { goto readErrorWithChannelOpen; } else if (len == 0) { break; @@ -3299,7 +3293,7 @@ CopyImageFile( */ i = Tcl_Seek(in, 0, SEEK_END); - if (i == ERROR_LENGTH) { + if (i == TCL_INDEX_NONE) { errMsg = "seek error"; goto copyError; } -- cgit v0.12 From 0b39585b19e94e663d35f0618c748abfb37de5cd Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 10 Mar 2022 15:02:24 +0000 Subject: Enhance internal "struct Interp" such that it can handle more than 2^31 levels --- generic/tclBasic.c | 2 +- generic/tclExecute.c | 18 +++++++++--------- generic/tclInt.h | 4 ++-- generic/tclInterp.c | 2 +- generic/tclTest.c | 8 ++++---- 5 files changed, 17 insertions(+), 17 deletions(-) diff --git a/generic/tclBasic.c b/generic/tclBasic.c index dbb20a5..b7b58a7 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -3930,7 +3930,7 @@ TclInterpReady( * probably because of an infinite loop somewhere. */ - if (((iPtr->numLevels) <= iPtr->maxNestingDepth)) { + if ((iPtr->numLevels <= iPtr->maxNestingDepth)) { return TCL_OK; } diff --git a/generic/tclExecute.c b/generic/tclExecute.c index 197b1e9..6b47f02 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -379,7 +379,7 @@ VarHashCreateVar( #ifdef TCL_COMPILE_DEBUG # define TRACE(a) \ while (traceInstructions) { \ - fprintf(stdout, "%2d: %2d (%" TCL_Z_MODIFIER "u) %s ", iPtr->numLevels, \ + fprintf(stdout, "%2" TCL_Z_MODIFIER "d: %2d (%" TCL_Z_MODIFIER "u) %s ", iPtr->numLevels, \ (int) CURR_DEPTH, \ (size_t) (pc - codePtr->codeStart), \ GetOpcodeName(pc)); \ @@ -395,7 +395,7 @@ VarHashCreateVar( TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp)))); # define TRACE_WITH_OBJ(a, objPtr) \ while (traceInstructions) { \ - fprintf(stdout, "%2d: %2d (%" TCL_Z_MODIFIER "u) %s ", iPtr->numLevels, \ + fprintf(stdout, "%2" TCL_Z_MODIFIER "d: %2d (%" TCL_Z_MODIFIER "u) %s ", iPtr->numLevels, \ (int) CURR_DEPTH, \ (size_t) (pc - codePtr->codeStart), \ GetOpcodeName(pc)); \ @@ -2269,7 +2269,7 @@ TEBCresume( CHECK_STACK(); if (traceInstructions) { - fprintf(stdout, "%2d: %2d ", iPtr->numLevels, (int) CURR_DEPTH); + fprintf(stdout, "%2" TCL_Z_MODIFIER "d: %2d ", iPtr->numLevels, (int) CURR_DEPTH); TclPrintInstruction(codePtr, pc); fflush(stdout); } @@ -2389,7 +2389,7 @@ TEBCresume( if (traceInstructions) { TRACE_APPEND(("YIELD...\n")); } else { - fprintf(stdout, "%d: (%" TCL_Z_MODIFIER "u) yielding value \"%.30s\"\n", + fprintf(stdout, "%" TCL_Z_MODIFIER "d: (%" TCL_Z_MODIFIER "u) yielding value \"%.30s\"\n", iPtr->numLevels, (size_t)(pc - codePtr->codeStart), Tcl_GetString(OBJ_AT_TOS)); } @@ -2432,7 +2432,7 @@ TEBCresume( TRACE(("[%.30s] => YIELD...\n", O2S(valuePtr))); } else { /* FIXME: What is the right thing to trace? */ - fprintf(stdout, "%d: (%" TCL_Z_MODIFIER "u) yielding to [%.30s]\n", + fprintf(stdout, "%" TCL_Z_MODIFIER "d: (%" TCL_Z_MODIFIER "u) yielding to [%.30s]\n", iPtr->numLevels, (size_t)(pc - codePtr->codeStart), TclGetString(valuePtr)); } @@ -2791,7 +2791,7 @@ TEBCresume( strncpy(cmdNameBuf, TclGetString(objv[0]), 20); TRACE(("%u => call ", objc)); } else { - fprintf(stdout, "%d: (%" TCL_Z_MODIFIER "u) invoking ", iPtr->numLevels, + fprintf(stdout, "%" TCL_Z_MODIFIER "d: (%" TCL_Z_MODIFIER "u) invoking ", iPtr->numLevels, (size_t)(pc - codePtr->codeStart)); } for (i = 0; i < objc; i++) { @@ -2839,7 +2839,7 @@ TEBCresume( TRACE(("%u => call (implementation %s) ", objc, O2S(objPtr))); } else { fprintf(stdout, - "%d: (%" TCL_Z_MODIFIER "u) invoking (using implementation %s) ", + "%" TCL_Z_MODIFIER "d: (%" TCL_Z_MODIFIER "u) invoking (using implementation %s) ", iPtr->numLevels, (size_t)(pc - codePtr->codeStart), O2S(objPtr)); } @@ -4424,7 +4424,7 @@ TEBCresume( if (traceInstructions) { strncpy(cmdNameBuf, TclGetString(objv[0]), 20); } else { - fprintf(stdout, "%d: (%" TCL_Z_MODIFIER "u) invoking ", + fprintf(stdout, "%" TCL_Z_MODIFIER "d: (%" TCL_Z_MODIFIER "u) invoking ", iPtr->numLevels, (size_t)(pc - codePtr->codeStart)); } @@ -4526,7 +4526,7 @@ TEBCresume( if (traceInstructions) { strncpy(cmdNameBuf, TclGetString(objv[0]), 20); } else { - fprintf(stdout, "%d: (%" TCL_Z_MODIFIER "u) invoking ", + fprintf(stdout, "%" TCL_Z_MODIFIER "d: (%" TCL_Z_MODIFIER "u) invoking ", iPtr->numLevels, (size_t)(pc - codePtr->codeStart)); } for (i = 0; i < opnd; i++) { diff --git a/generic/tclInt.h b/generic/tclInt.h index bdf7990..b7f35ca 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -1848,12 +1848,12 @@ typedef struct Interp { * tclVar.c for usage. */ - int numLevels; /* Keeps track of how many nested calls to + size_t numLevels; /* Keeps track of how many nested calls to * Tcl_Eval are in progress for this * interpreter. It's used to delay deletion of * the table until all Tcl_Eval invocations * are completed. */ - int maxNestingDepth; /* If numLevels exceeds this value then Tcl + size_t maxNestingDepth; /* If numLevels exceeds this value then Tcl * assumes that infinite recursion has * occurred and it generates an error. */ CallFrame *framePtr; /* Points to top-most in stack of all nested diff --git a/generic/tclInterp.c b/generic/tclInterp.c index adf113d..2e57ff5 100644 --- a/generic/tclInterp.c +++ b/generic/tclInterp.c @@ -3016,7 +3016,7 @@ ChildRecursionLimit( } Tcl_SetRecursionLimit(childInterp, limit); iPtr = (Interp *) childInterp; - if (interp == childInterp && iPtr->numLevels > limit) { + if (interp == childInterp && iPtr->numLevels > (size_t)limit) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "falling back due to new recursion limit", -1)); Tcl_SetErrorCode(interp, "TCL", "RECURSION", NULL); diff --git a/generic/tclTest.c b/generic/tclTest.c index cead18c..94a3fea 100644 --- a/generic/tclTest.c +++ b/generic/tclTest.c @@ -7398,7 +7398,7 @@ TestNRELevels( static ptrdiff_t *refDepth = NULL; ptrdiff_t depth; Tcl_Obj *levels[6]; - int i = 0; + size_t i = 0; NRE_callback *cbPtr = iPtr->execEnvPtr->callbackPtr; if (refDepth == NULL) { @@ -7408,9 +7408,9 @@ TestNRELevels( depth = (refDepth - &depth); levels[0] = Tcl_NewWideIntObj(depth); - levels[1] = Tcl_NewWideIntObj(iPtr->numLevels); - levels[2] = Tcl_NewWideIntObj(iPtr->cmdFramePtr->level); - levels[3] = Tcl_NewWideIntObj(iPtr->varFramePtr->level); + levels[1] = Tcl_NewWideIntObj((Tcl_WideInt)((Tcl_WideUInt)(iPtr->numLevels + 1U)) - 1); + levels[2] = Tcl_NewWideIntObj((Tcl_WideInt)((Tcl_WideUInt)(iPtr->cmdFramePtr->level + 1U)) - 1); + levels[3] = Tcl_NewWideIntObj((Tcl_WideInt)((Tcl_WideUInt)(iPtr->varFramePtr->level + 1U)) - 1); levels[4] = Tcl_NewWideIntObj(iPtr->execEnvPtr->execStackPtr->tosPtr - iPtr->execEnvPtr->execStackPtr->stackWords); -- cgit v0.12