From da8fbb89c41229c79b8f373f955ce1fb59cb4233 Mon Sep 17 00:00:00 2001 From: dgp Date: Tue, 6 Mar 2018 17:38:44 +0000 Subject: various bits of ranting commentary --- generic/tclCompCmdsGR.c | 25 ++++++++++++++++++++++--- generic/tclCompCmdsSZ.c | 19 +++++++++++++++++++ 2 files changed, 41 insertions(+), 3 deletions(-) diff --git a/generic/tclCompCmdsGR.c b/generic/tclCompCmdsGR.c index 375653b..e46d524 100644 --- a/generic/tclCompCmdsGR.c +++ b/generic/tclCompCmdsGR.c @@ -1505,7 +1505,6 @@ TclCompileLreplaceCmd( * - integer: [0,len+1] * - end index: TCL_INDEX_END * - -ive offset: TCL_INDEX_END-[len-1,0] - * - +ive offset: TCL_INDEX_END+1 */ /* @@ -1515,6 +1514,11 @@ TclCompileLreplaceCmd( */ if ((idx1 <= TCL_INDEX_END) != (idx2 <= TCL_INDEX_END)) { + + /* + * NOTE: when idx1 == 0 and idx2 == TCL_INDEX_END, + * we bail out here! Yet, down below + */ return TCL_ERROR; } @@ -1531,9 +1535,11 @@ TclCompileLreplaceCmd( if (parsePtr->numWords == 4) { if (idx1 == 0) { if (idx2 == TCL_INDEX_END) { + + /* Here we are down below! Now look somewhere else! */ goto dropAll; } - idx1 = idx2 + 1; + idx1 = idx2 + 1; /* TODO: Overflow? */ idx2 = TCL_INDEX_END; goto dropEnd; } else if (idx2 == TCL_INDEX_END) { @@ -1561,9 +1567,10 @@ TclCompileLreplaceCmd( TclEmitInstInt4( INST_REVERSE, 2, envPtr); if (idx1 == 0) { if (idx2 == TCL_INDEX_END) { + /* Another Can't Happen. */ goto replaceAll; } - idx1 = idx2 + 1; + idx1 = idx2 + 1; /* TODO: Overflow? */ idx2 = TCL_INDEX_END; goto replaceHead; } else if (idx2 == TCL_INDEX_END) { @@ -1588,6 +1595,11 @@ TclCompileLreplaceCmd( */ dropAll: /* This just ensures the arg is a list. */ + /* + * And now we're here down below the down below where flow can never go. + * CONCLUSION: This code has no purpose. + */ +Tcl_Panic("Can not get here."); TclEmitOpcode( INST_LIST_LENGTH, envPtr); TclEmitOpcode( INST_POP, envPtr); PushStringLiteral(envPtr, ""); @@ -1615,6 +1627,9 @@ TclCompileLreplaceCmd( * Emit an error if we've been given an empty list. */ +/* If we're generating bytecode to report an error, we've gone wrong. + * Just fallback to direct invocation. + */ TclEmitOpcode( INST_DUP, envPtr); TclEmitOpcode( INST_LIST_LENGTH, envPtr); offset2 = CurrentOffset(envPtr); @@ -1646,6 +1661,7 @@ TclCompileLreplaceCmd( */ replaceAll: +Tcl_Panic("Can not get here."); TclEmitOpcode( INST_LIST_LENGTH, envPtr); TclEmitOpcode( INST_POP, envPtr); goto done; @@ -1685,6 +1701,9 @@ TclCompileLreplaceCmd( * Emit an error if we've been given an empty list. */ +/* If we're generating bytecode to report an error, we've gone wrong. + * Just fallback to direct invocation. + */ TclEmitOpcode( INST_DUP, envPtr); TclEmitOpcode( INST_LIST_LENGTH, envPtr); offset2 = CurrentOffset(envPtr); diff --git a/generic/tclCompCmdsSZ.c b/generic/tclCompCmdsSZ.c index fb0981d..6f0cc8f 100644 --- a/generic/tclCompCmdsSZ.c +++ b/generic/tclCompCmdsSZ.c @@ -1005,6 +1005,14 @@ TclCompileStringReplaceCmd( * We handle these replacements specially: first character (where * idx1=idx2=0) and last character (where idx1=idx2=TCL_INDEX_END). Anything * else and the semantics get rather screwy. + * + * TODO: These seem to be very narrow cases. They are not even + * covered by the test suite, and any programming that ends up + * here could have been coded by the programmer using [string range] + * and [string cat]. [*] Not clear at all to me that the bytecode + * generated here is worthwhile. + * + * [*] Except for the empty string exceptions. UGGGGHHHH. */ if (idx1 == 0 && idx2 == 0) { @@ -1022,6 +1030,14 @@ TclCompileStringReplaceCmd( } /* Replace first */ CompileWord(envPtr, replacementTokenPtr, interp, 4); + + /* + * NOTE: The following tower of bullshit is present because + * [string replace] was boneheadedly defined not to replace + * empty strings, so we actually have to detect the empty + * string case and treat it differently. + */ + OP4( OVER, 1); PUSH( ""); OP( STR_EQ); @@ -1051,6 +1067,9 @@ TclCompileStringReplaceCmd( } /* Replace last */ CompileWord(envPtr, replacementTokenPtr, interp, 4); + + /* More bullshit; see NOTE above. */ + OP4( OVER, 1); PUSH( ""); OP( STR_EQ); -- cgit v0.12 From 0254080ca07929caa2f2b25206928d5559048aff Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 6 Mar 2018 22:53:00 +0000 Subject: Fix the "package files" command. Due to the NRE enabling of "package" it always started to return an empty list. --- generic/tclPkg.c | 25 +++++++++++++++---------- 1 file changed, 15 insertions(+), 10 deletions(-) diff --git a/generic/tclPkg.c b/generic/tclPkg.c index 6c5b827..e8c2801 100644 --- a/generic/tclPkg.c +++ b/generic/tclPkg.c @@ -728,12 +728,23 @@ SelectPackage(ClientData data[], Tcl_Interp *interp, int result) { */ char *versionToProvide = bestPtr->version; + PkgFiles *pkgFiles; + PkgName *pkgName; + Tcl_Preserve(versionToProvide); pkgPtr->clientData = versionToProvide; if (bestPtr->pkgIndex) { TclPkgFileSeen(interp, bestPtr->pkgIndex); } reqPtr->versionToProvide = versionToProvide; + + pkgFiles = TclInitPkgFiles(interp); + /* Push "ifneeded" package name in "tclPkgFiles" assocdata. */ + pkgName = ckalloc(sizeof(PkgName) + strlen(name)); + pkgName->nextPtr = pkgFiles->names; + strcpy(pkgName->name, name); + pkgFiles->names = pkgName; + Tcl_NRAddCallback(interp, SelectPackageFinal, reqPtr, INT2PTR(reqc), (void *)reqv, data[3]); Tcl_NREvalObj(interp, Tcl_NewStringObj(bestPtr->script, -1), TCL_EVAL_GLOBAL); } @@ -747,20 +758,14 @@ SelectPackageFinal(ClientData data[], Tcl_Interp *interp, int result) { Tcl_Obj **const reqv = data[2]; const char *name = reqPtr->name; char *versionToProvide = reqPtr->versionToProvide; - + void *toBeRemoved; PkgFiles *pkgFiles; - PkgName *pkgName; pkgFiles = TclInitPkgFiles(interp); - /* Push "ifneeded" package name in "tclPkgFiles" assocdata. */ - pkgName = ckalloc(sizeof(PkgName) + strlen(name)); - pkgName->nextPtr = pkgFiles->names; - strcpy(pkgName->name, name); - pkgFiles->names = pkgName; - /* Pop the "ifneeded" package name from "tclPkgFiles" assocdata*/ - pkgFiles->names = pkgName->nextPtr; - ckfree(pkgName); + toBeRemoved = pkgFiles->names; + pkgFiles->names = pkgFiles->names->nextPtr; + ckfree(toBeRemoved); reqPtr->pkgPtr = FindPackage(interp, name); if (result == TCL_OK) { -- cgit v0.12 From 7fe003f8d24f263ca82d1ddf0a54f6ab16f01306 Mon Sep 17 00:00:00 2001 From: dgp Date: Wed, 7 Mar 2018 14:16:08 +0000 Subject: Remove pointless duplication. --- generic/tclListObj.c | 12 +++--------- 1 file changed, 3 insertions(+), 9 deletions(-) diff --git a/generic/tclListObj.c b/generic/tclListObj.c index 0d37821..13704b9 100644 --- a/generic/tclListObj.c +++ b/generic/tclListObj.c @@ -1145,15 +1145,9 @@ TclLindexList( return TclLindexFlat(interp, listPtr, 1, &argPtr); } - if (indexListCopy->typePtr == &tclListType) { - List *listRepPtr = ListRepPtr(indexListCopy); - - listPtr = TclLindexFlat(interp, listPtr, listRepPtr->elemCount, - &listRepPtr->elements); - } else { - int indexCount = -1; /* Size of the array of list indices. */ - Tcl_Obj **indices = NULL; - /* Array of list indices. */ + { + int indexCount = -1; /* Size of the array of list indices. */ + Tcl_Obj **indices = NULL; /* Array of list indices. */ Tcl_ListObjGetElements(NULL, indexListCopy, &indexCount, &indices); listPtr = TclLindexFlat(interp, listPtr, indexCount, indices); -- cgit v0.12 From f337281f750a928dcc07884286cc1f4cceeab809 Mon Sep 17 00:00:00 2001 From: sebres Date: Wed, 7 Mar 2018 15:10:44 +0000 Subject: amend to [58716e0e92]: now the duplication is really pointless, so eliminated --- generic/tclListObj.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/generic/tclListObj.c b/generic/tclListObj.c index 13704b9..786e1ce 100644 --- a/generic/tclListObj.c +++ b/generic/tclListObj.c @@ -1149,7 +1149,7 @@ TclLindexList( int indexCount = -1; /* Size of the array of list indices. */ Tcl_Obj **indices = NULL; /* Array of list indices. */ - Tcl_ListObjGetElements(NULL, indexListCopy, &indexCount, &indices); + TclListObjGetElements(NULL, indexListCopy, &indexCount, &indices); listPtr = TclLindexFlat(interp, listPtr, indexCount, indices); } Tcl_DecrRefCount(indexListCopy); -- cgit v0.12 From 405b9175e62f3133e3e0811262ab863b70c7f1e7 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 7 Mar 2018 19:35:00 +0000 Subject: Fix handling of "pkgIndex" file in "package files" command. This was broken as well, as result of NRE-enabling the "package" command. --- generic/tclPkg.c | 25 +++++++++++-------------- 1 file changed, 11 insertions(+), 14 deletions(-) diff --git a/generic/tclPkg.c b/generic/tclPkg.c index e8c2801..1e54aa7 100644 --- a/generic/tclPkg.c +++ b/generic/tclPkg.c @@ -733,18 +733,17 @@ SelectPackage(ClientData data[], Tcl_Interp *interp, int result) { Tcl_Preserve(versionToProvide); pkgPtr->clientData = versionToProvide; + + pkgFiles = TclInitPkgFiles(interp); + /* Push "ifneeded" package name in "tclPkgFiles" assocdata. */ + pkgName = ckalloc(sizeof(PkgName) + strlen(name)); + pkgName->nextPtr = pkgFiles->names; + strcpy(pkgName->name, name); + pkgFiles->names = pkgName; if (bestPtr->pkgIndex) { TclPkgFileSeen(interp, bestPtr->pkgIndex); } reqPtr->versionToProvide = versionToProvide; - - pkgFiles = TclInitPkgFiles(interp); - /* Push "ifneeded" package name in "tclPkgFiles" assocdata. */ - pkgName = ckalloc(sizeof(PkgName) + strlen(name)); - pkgName->nextPtr = pkgFiles->names; - strcpy(pkgName->name, name); - pkgFiles->names = pkgName; - Tcl_NRAddCallback(interp, SelectPackageFinal, reqPtr, INT2PTR(reqc), (void *)reqv, data[3]); Tcl_NREvalObj(interp, Tcl_NewStringObj(bestPtr->script, -1), TCL_EVAL_GLOBAL); } @@ -758,14 +757,12 @@ SelectPackageFinal(ClientData data[], Tcl_Interp *interp, int result) { Tcl_Obj **const reqv = data[2]; const char *name = reqPtr->name; char *versionToProvide = reqPtr->versionToProvide; - void *toBeRemoved; - PkgFiles *pkgFiles; - pkgFiles = TclInitPkgFiles(interp); /* Pop the "ifneeded" package name from "tclPkgFiles" assocdata*/ - toBeRemoved = pkgFiles->names; - pkgFiles->names = pkgFiles->names->nextPtr; - ckfree(toBeRemoved); + PkgFiles *pkgFiles = Tcl_GetAssocData(interp, "tclPkgFiles", NULL); + PkgName *pkgName = pkgFiles->names; + pkgFiles->names = pkgName->nextPtr; + ckfree(pkgName); reqPtr->pkgPtr = FindPackage(interp, name); if (result == TCL_OK) { -- cgit v0.12 From 3492c92f3dcb820bd5f7aa833e340b6e1eb8f1c5 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 7 Mar 2018 20:24:00 +0000 Subject: Improve -DTCL_NO_DEPRECATED compiles. It now can handle loading stub-enabled extensions with incompatible magic number (backported from trunk) --- generic/tclBasic.c | 11 ++++++++--- generic/tclLoad.c | 13 +++++++++++++ 2 files changed, 21 insertions(+), 3 deletions(-) diff --git a/generic/tclBasic.c b/generic/tclBasic.c index 3d16b70..c493c3d 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -4462,7 +4462,9 @@ TclNRRunCallbacks( /* All callbacks down to rootPtr not inclusive * are to be run. */ { +#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9 Interp *iPtr = (Interp *) interp; +#endif /* !defined(TCL_NO_DEPRECATED) */ NRE_callback *callbackPtr; Tcl_NRPostProc *procPtr; @@ -4476,9 +4478,11 @@ TclNRRunCallbacks( * are for NR function calls, and those are Tcl_Obj based. */ +#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9 if (*(iPtr->result) != 0) { (void) Tcl_GetObjResult(interp); } +#endif /* !defined(TCL_NO_DEPRECATED) */ /* This is the trampoline. */ @@ -6873,7 +6877,8 @@ Tcl_AddObjErrorInfo( iPtr->flags |= ERR_LEGACY_COPY; if (iPtr->errorInfo == NULL) { - if (iPtr->result[0] != 0) { +#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9 + if (*(iPtr->result) != 0) { /* * The interp's string result is set, apparently by some extension * making a deprecated direct write to it. That extension may @@ -6883,9 +6888,9 @@ Tcl_AddObjErrorInfo( */ iPtr->errorInfo = Tcl_NewStringObj(iPtr->result, -1); - } else { + } else +#endif /* !defined(TCL_NO_DEPRECATED) */ iPtr->errorInfo = iPtr->objResultPtr; - } Tcl_IncrRefCount(iPtr->errorInfo); if (!iPtr->errorCode) { Tcl_SetErrorCode(interp, "NONE", NULL); diff --git a/generic/tclLoad.c b/generic/tclLoad.c index e0bb5ef..77e6425 100644 --- a/generic/tclLoad.c +++ b/generic/tclLoad.c @@ -470,6 +470,19 @@ Tcl_LoadObjCmd( */ if (code != TCL_OK) { +#if defined(TCL_NO_DEPRECATED) || TCL_MAJOR_VERSION > 8 + Interp *iPtr = (Interp *) target; + if (iPtr->result && *(iPtr->result) && !iPtr->freeProc) { + /* + * A call to Tcl_InitStubs() determined the caller extension and + * this interp are incompatible in their stubs mechanisms, and + * recorded the error in the oldest legacy place we have to do so. + */ + Tcl_SetObjResult(target, Tcl_NewStringObj(iPtr->result, -1)); + iPtr->result = &tclEmptyString; + iPtr->freeProc = NULL; + } +#endif /* defined(TCL_NO_DEPRECATED) */ Tcl_TransferResult(target, code, interp); goto done; } -- cgit v0.12