diff options
author | dgp <dgp@users.sourceforge.net> | 2018-03-10 15:55:38 (GMT) |
---|---|---|
committer | dgp <dgp@users.sourceforge.net> | 2018-03-10 15:55:38 (GMT) |
commit | dc5861414a559d3b12a64c6db2f121aba5e7d577 (patch) | |
tree | 57d7a2c3f340dca3c9d870a7f0dd78e30bb21e27 | |
parent | bd9f2eb15d41619e95eab98976d8028c46c1065d (diff) | |
parent | 6b5d0e5d8da204f9ab8165fafe0b497927a7fa24 (diff) | |
download | tcl-dc5861414a559d3b12a64c6db2f121aba5e7d577.zip tcl-dc5861414a559d3b12a64c6db2f121aba5e7d577.tar.gz tcl-dc5861414a559d3b12a64c6db2f121aba5e7d577.tar.bz2 |
merge 8.7
-rw-r--r-- | generic/tclAssembly.c | 23 | ||||
-rw-r--r-- | generic/tclBasic.c | 11 | ||||
-rw-r--r-- | generic/tclCmdIL.c | 88 | ||||
-rw-r--r-- | generic/tclCompCmdsGR.c | 388 | ||||
-rw-r--r-- | generic/tclCompCmdsSZ.c | 74 | ||||
-rw-r--r-- | generic/tclCompile.h | 9 | ||||
-rw-r--r-- | generic/tclExecute.c | 131 | ||||
-rw-r--r-- | generic/tclInt.h | 15 | ||||
-rw-r--r-- | generic/tclLoad.c | 13 | ||||
-rw-r--r-- | generic/tclPkg.c | 22 | ||||
-rw-r--r-- | generic/tclUtil.c | 139 | ||||
-rw-r--r-- | tests/assemble.test | 6 | ||||
-rw-r--r-- | tests/cmdIL.test | 33 | ||||
-rw-r--r-- | tests/lindex.test | 9 | ||||
-rw-r--r-- | tests/lrange.test | 18 | ||||
-rw-r--r-- | tests/lreplace.test | 14 | ||||
-rw-r--r-- | tests/lsearch.test | 34 |
17 files changed, 651 insertions, 376 deletions
diff --git a/generic/tclAssembly.c b/generic/tclAssembly.c index fd1cf96..4bc6918 100644 --- a/generic/tclAssembly.c +++ b/generic/tclAssembly.c @@ -2247,23 +2247,24 @@ GetListIndexOperand( Tcl_Token* tokenPtr = *tokenPtrPtr; /* INOUT: Pointer to the next token in the * source code */ - Tcl_Obj* intObj; /* Integer from the source code */ - int status; /* Tcl status return */ - - /* - * Extract the next token as a string. - */ + Tcl_Obj *value; + int status; - if (GetNextOperand(assemEnvPtr, tokenPtrPtr, &intObj) != TCL_OK) { + /* General operand validity check */ + if (GetNextOperand(assemEnvPtr, tokenPtrPtr, &value) != TCL_OK) { return TCL_ERROR; } - + + /* Convert to an integer, advance to the next token and return. */ /* - * Convert to an integer, advance to the next token and return. + * NOTE: Indexing a list with an index before it yields the + * same result as indexing after it, and might be more easily portable + * when list size limits grow. */ + status = TclIndexEncode(interp, value, + TCL_INDEX_BEFORE,TCL_INDEX_BEFORE, result); - status = TclGetIntForIndex(interp, intObj, -2, result); - Tcl_DecrRefCount(intObj); + Tcl_DecrRefCount(value); *tokenPtrPtr = TokenAfter(tokenPtr); return status; } diff --git a/generic/tclBasic.c b/generic/tclBasic.c index 5d711a8..f9cf50d 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -4467,7 +4467,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; @@ -4481,9 +4483,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. */ @@ -6878,7 +6882,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 @@ -6888,9 +6893,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/tclCmdIL.c b/generic/tclCmdIL.c index fdf76f9..10444ac 100644 --- a/generic/tclCmdIL.c +++ b/generic/tclCmdIL.c @@ -64,8 +64,9 @@ typedef struct SortInfo { * SORTMODE_COMMAND. Pre-initialized to hold * base of command. */ int *indexv; /* If the -index option was specified, this - * holds the indexes contained in the list - * supplied as an argument to that option. + * holds an encoding of the indexes contained + * in the list supplied as an argument to + * that option. * NULL if no indexes supplied, and points to * singleIndex field when only one * supplied. */ @@ -93,14 +94,6 @@ typedef struct SortInfo { #define SORTMODE_ASCII_NC 8 /* - * Magic values for the index field of the SortInfo structure. Note that the - * index "end-1" will be translated to SORTIDX_END-1, etc. - */ - -#define SORTIDX_NONE -1 /* Not indexed; use whole value. */ -#define SORTIDX_END -2 /* Indexed from end. */ - -/* * Forward declarations for procedures defined in this file: */ @@ -2777,7 +2770,7 @@ Tcl_LreplaceObjCmd( * (to allow for replacing the last elem). */ - if ((first > listLen) && (listLen > 0)) { + if ((first >= listLen) && (listLen > 0)) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "list doesn't contain element %s", TclGetString(objv[2]))); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LREPLACE", "BADIDX", @@ -2928,7 +2921,7 @@ Tcl_LsearchObjCmd( Tcl_Obj *const objv[]) /* Argument values. */ { const char *bytes, *patternBytes; - int i, match, index, result, listc, length, elemLen, bisect; + int i, match, index, result=TCL_OK, listc, length, elemLen, bisect; int allocatedIndexVector = 0; int dataType, isIncreasing, lower, upper, start, groupSize, groupOffset; Tcl_WideInt patWide, objWide; @@ -3151,13 +3144,26 @@ Tcl_LsearchObjCmd( */ for (j=0 ; j<sortInfo.indexc ; j++) { - if (TclGetIntForIndexM(interp, indices[j], SORTIDX_END, - &sortInfo.indexv[j]) != TCL_OK) { + int encoded = 0; + if (TclIndexEncode(interp, indices[j], TCL_INDEX_BEFORE, + TCL_INDEX_AFTER, &encoded) != TCL_OK) { + result = TCL_ERROR; + } + if ((encoded == TCL_INDEX_BEFORE) + || (encoded == TCL_INDEX_AFTER)) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "index \"%s\" cannot select an element " + "from any list", Tcl_GetString(indices[j]))); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "INDEX" + "OUTOFRANGE", NULL); + result = TCL_ERROR; + } + if (result == TCL_ERROR) { Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( "\n (-index option item number %d)", j)); - result = TCL_ERROR; goto done; } + sortInfo.indexv[j] = encoded; } break; } @@ -3245,10 +3251,7 @@ Tcl_LsearchObjCmd( * offset of the element within each group by which to sort. */ - groupOffset = sortInfo.indexv[0]; - if (groupOffset <= SORTIDX_END) { - groupOffset = (groupOffset - SORTIDX_END) + groupSize - 1; - } + groupOffset = TclIndexDecode(sortInfo.indexv[0], groupSize - 1); if (groupOffset < 0 || groupOffset >= groupSize) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "when used with \"-stride\", the leading \"-index\"" @@ -3584,8 +3587,8 @@ Tcl_LsearchObjCmd( itemPtr = Tcl_NewIntObj(i+groupOffset); for (j=0 ; j<sortInfo.indexc ; j++) { - Tcl_ListObjAppendElement(interp, itemPtr, - Tcl_NewIntObj(sortInfo.indexv[j])); + Tcl_ListObjAppendElement(interp, itemPtr, Tcl_NewIntObj( + TclIndexDecode(sortInfo.indexv[j], listc))); } Tcl_ListObjAppendElement(interp, listPtr, itemPtr); } else { @@ -3606,8 +3609,8 @@ Tcl_LsearchObjCmd( itemPtr = Tcl_NewIntObj(index+groupOffset); for (j=0 ; j<sortInfo.indexc ; j++) { - Tcl_ListObjAppendElement(interp, itemPtr, - Tcl_NewIntObj(sortInfo.indexv[j])); + Tcl_ListObjAppendElement(interp, itemPtr, Tcl_NewIntObj( + TclIndexDecode(sortInfo.indexv[j], listc))); } Tcl_SetObjResult(interp, itemPtr); } else { @@ -3834,7 +3837,7 @@ Tcl_LsortObjCmd( sortInfo.isIncreasing = 1; break; case LSORT_INDEX: { - int indexc, dummy; + int indexc; Tcl_Obj **indexv; if (i == objc-2) { @@ -3860,8 +3863,20 @@ Tcl_LsortObjCmd( */ for (j=0 ; j<indexc ; j++) { - if (TclGetIntForIndexM(interp, indexv[j], SORTIDX_END, - &dummy) != TCL_OK) { + int encoded = 0; + int result = TclIndexEncode(interp, indexv[j], + TCL_INDEX_BEFORE, TCL_INDEX_AFTER, &encoded); + + if ((result == TCL_OK) && ((encoded == TCL_INDEX_BEFORE) + || (encoded == TCL_INDEX_AFTER))) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "index \"%s\" cannot select an element " + "from any list", Tcl_GetString(indexv[j]))); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "INDEX" + "OUTOFRANGE", NULL); + result = TCL_ERROR; + } + if (result == TCL_ERROR) { Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( "\n (-index option item number %d)", j)); sortInfo.resultCode = TCL_ERROR; @@ -3941,8 +3956,8 @@ Tcl_LsortObjCmd( * might be decreased by 1 later. */ } for (j=0 ; j<sortInfo.indexc ; j++) { - TclGetIntForIndexM(interp, indexv[j], SORTIDX_END, - &sortInfo.indexv[j]); + /* Prescreened values, no errors or out of range possible */ + TclIndexEncode(NULL, indexv[j], 0, 0, &sortInfo.indexv[j]); } } @@ -4013,10 +4028,7 @@ Tcl_LsortObjCmd( * offset of the element within each group by which to sort. */ - groupOffset = sortInfo.indexv[0]; - if (groupOffset <= SORTIDX_END) { - groupOffset = (groupOffset - SORTIDX_END) + groupSize - 1; - } + groupOffset = TclIndexDecode(sortInfo.indexv[0], groupSize - 1); if (groupOffset < 0 || groupOffset >= groupSize) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "when used with \"-stride\", the leading \"-index\"" @@ -4035,6 +4047,9 @@ Tcl_LsortObjCmd( /* * Do not shrink the actual memory block used; that doesn't * work with TclStackAlloc-allocated memory. [Bug 2918962] + * + * TODO: Consider a pointer increment to replace this + * array shift. */ for (i = 0; i < sortInfo.indexc; i++) { @@ -4603,15 +4618,8 @@ SelectObjFromSublist( infoPtr->resultCode = TCL_ERROR; return NULL; } - index = infoPtr->indexv[i]; - /* - * Adjust for end-based indexing. - */ - - if (index < SORTIDX_NONE) { - index += listLen + 1; - } + index = TclIndexDecode(infoPtr->indexv[i], listLen - 1); if (Tcl_ListObjIndex(infoPtr->interp, objPtr, index, ¤tObj) != TCL_OK) { diff --git a/generic/tclCompCmdsGR.c b/generic/tclCompCmdsGR.c index 0720a6b..3781b9a 100644 --- a/generic/tclCompCmdsGR.c +++ b/generic/tclCompCmdsGR.c @@ -34,15 +34,15 @@ static int IndexTailVarIfKnown(Tcl_Interp *interp, * * TclGetIndexFromToken -- * - * Parse a token and get the encoded version of the index (as understood - * by TEBC), assuming it is at all knowable at compile time. Only handles - * indices that are integers or 'end' or 'end-integer'. + * Parse a token to determine if an index value is known at + * compile time. * * Returns: * TCL_OK if parsing succeeded, and TCL_ERROR if it failed. * * Side effects: - * Sets *index to the index value if successful. + * When TCL_OK is returned, the encoded index value is written + * to *index. * *---------------------------------------------------------------------- */ @@ -50,33 +50,17 @@ static int IndexTailVarIfKnown(Tcl_Interp *interp, int TclGetIndexFromToken( Tcl_Token *tokenPtr, - int *index) + int before, + int after, + int *indexPtr) { Tcl_Obj *tmpObj = Tcl_NewObj(); - int result, idx; + int result = TCL_ERROR; - if (!TclWordKnownAtCompileTime(tokenPtr, tmpObj)) { - Tcl_DecrRefCount(tmpObj); - return TCL_ERROR; - } - - result = TclGetIntFromObj(NULL, tmpObj, &idx); - if (result == TCL_OK) { - if (idx < 0) { - result = TCL_ERROR; - } - } else { - result = TclGetIntForIndexM(NULL, tmpObj, TCL_INDEX_END, &idx); - if (result == TCL_OK && idx > TCL_INDEX_END) { - result = TCL_ERROR; - } + if (TclWordKnownAtCompileTime(tokenPtr, tmpObj)) { + result = TclIndexEncode(NULL, tmpObj, before, after, indexPtr); } Tcl_DecrRefCount(tmpObj); - - if (result == TCL_OK) { - *index = idx; - } - return result; } @@ -143,7 +127,7 @@ TclCompileGlobalCmd( return TCL_ERROR; } - /* TODO: Consider what value can pass throug the + /* TODO: Consider what value can pass through the * IndexTailVarIfKnown() screen. Full CompileWord() * likely does not apply here. Push known value instead. */ CompileWord(envPtr, varTokenPtr, interp, i); @@ -1103,14 +1087,14 @@ TclCompileLindexCmd( } idxTokenPtr = TokenAfter(valTokenPtr); - if (TclGetIndexFromToken(idxTokenPtr, &idx) == TCL_OK) { + if (TclGetIndexFromToken(idxTokenPtr, TCL_INDEX_BEFORE, TCL_INDEX_BEFORE, + &idx) == TCL_OK) { /* - * All checks have been completed, and we have exactly one of these - * constructs: - * lindex <arbitraryValue> <posInt> - * lindex <arbitraryValue> end-<posInt> - * This is best compiled as a push of the arbitrary value followed by - * an "immediate lindex" which is the most efficient variety. + * The idxTokenPtr parsed as a valid index value and was + * encoded as expected by INST_LIST_INDEX_IMM. + * + * NOTE: that we rely on indexing before a list producing the + * same result as indexing after a list. */ CompileWord(envPtr, valTokenPtr, interp, 1); @@ -1331,21 +1315,25 @@ TclCompileLrangeCmd( } listTokenPtr = TokenAfter(parsePtr->tokenPtr); - /* - * Parse the indices. Will only compile if both are constants and not an - * _integer_ less than zero (since we reserve negative indices here for - * end-relative indexing) or an end-based index greater than 'end' itself. - */ - tokenPtr = TokenAfter(listTokenPtr); - if (TclGetIndexFromToken(tokenPtr, &idx1) != TCL_OK) { + if (TclGetIndexFromToken(tokenPtr, TCL_INDEX_START, TCL_INDEX_AFTER, + &idx1) != TCL_OK) { return TCL_ERROR; } + /* + * Token was an index value, and we treat all "first" indices + * before the list same as the start of the list. + */ tokenPtr = TokenAfter(tokenPtr); - if (TclGetIndexFromToken(tokenPtr, &idx2) != TCL_OK) { + if (TclGetIndexFromToken(tokenPtr, TCL_INDEX_BEFORE, TCL_INDEX_END, + &idx2) != TCL_OK) { return TCL_ERROR; } + /* + * Token was an index value, and we treat all "last" indices + * after the list same as the end of the list. + */ /* * Issue instructions. It's not safe to skip doing the LIST_RANGE, as @@ -1395,7 +1383,16 @@ TclCompileLinsertCmd( */ tokenPtr = TokenAfter(listTokenPtr); - if (TclGetIndexFromToken(tokenPtr, &idx) != TCL_OK) { + + /* + * NOTE: This command treats all inserts at indices before the list + * the same as inserts at the start of the list, and all inserts + * after the list the same as inserts at the end of the list. We + * make that transformation here so we can use the optimized bytecode + * as much as possible. + */ + if (TclGetIndexFromToken(tokenPtr, TCL_INDEX_START, TCL_INDEX_END, + &idx) != TCL_OK) { return TCL_ERROR; } @@ -1419,10 +1416,10 @@ TclCompileLinsertCmd( } TclEmitInstInt4( INST_LIST, i-3, envPtr); - if (idx == 0 /*start*/) { + if (idx == TCL_INDEX_START) { TclEmitInstInt4( INST_REVERSE, 2, envPtr); TclEmitOpcode( INST_LIST_CONCAT, envPtr); - } else if (idx == TCL_INDEX_END /*end*/) { + } else if (idx == TCL_INDEX_END) { TclEmitOpcode( INST_LIST_CONCAT, envPtr); } else { /* @@ -1475,250 +1472,167 @@ TclCompileLreplaceCmd( { Tcl_Token *tokenPtr, *listTokenPtr; DefineLineInformation; /* TIP #280 */ - Tcl_Obj *tmpObj; int idx1, idx2, i, offset, offset2; + int emptyPrefix=1, suffixStart = 0; if (parsePtr->numWords < 4) { return TCL_ERROR; } listTokenPtr = TokenAfter(parsePtr->tokenPtr); - /* - * Parse the indices. Will only compile if both are constants and not an - * _integer_ less than zero (since we reserve negative indices here for - * end-relative indexing) or an end-based index greater than 'end' itself. - */ - tokenPtr = TokenAfter(listTokenPtr); - if (TclGetIndexFromToken(tokenPtr, &idx1) != TCL_OK) { + if (TclGetIndexFromToken(tokenPtr, TCL_INDEX_START, TCL_INDEX_AFTER, + &idx1) != TCL_OK) { return TCL_ERROR; } tokenPtr = TokenAfter(tokenPtr); - if (TclGetIndexFromToken(tokenPtr, &idx2) != TCL_OK) { + if (TclGetIndexFromToken(tokenPtr, TCL_INDEX_BEFORE, TCL_INDEX_END, + &idx2) != TCL_OK) { return TCL_ERROR; } /* - * idx1, idx2 are now in canonical form: - * - * - integer: [0,len+1] - * - end index: TCL_INDEX_END - * - -ive offset: TCL_INDEX_END-[len-1,0] - * - +ive offset: TCL_INDEX_END+1 + * idx1, idx2 are the conventional encoded forms of the tokens parsed + * as all forms of index values. Values of idx1 that come before the + * list are treated the same as if they were the start of the list. + * Values of idx2 that come after the list are treated the same as if + * they were the end of the list. */ - /* - * Compilation fails when one index is end-based but the other isn't. - * Fixing this will require more bytecodes, but this is a workaround for - * now. [Bug 47ac84309b] - */ - - if ((idx1 <= TCL_INDEX_END) != (idx2 <= TCL_INDEX_END)) { + if (idx1 == TCL_INDEX_AFTER) { + /* + * [lreplace] treats idx1 value end+1 differently from end+2, etc. + * The operand encoding cannot distinguish them, so we must bail + * out to direct evaluation. + */ return TCL_ERROR; } - if (idx2 != TCL_INDEX_END && idx2 >= 0 && idx2 < idx1) { - idx2 = idx1 - 1; - } - /* - * Work out what this [lreplace] is actually doing. + * General structure of the [lreplace] result is + * prefix replacement suffix + * In a few cases we can predict various parts will be empty and + * take advantage. + * + * The proper suffix begins with the greater of indices idx1 or + * idx2 + 1. If we cannot tell at compile time which is greater, + * we must defer to direct evaluation. */ - tmpObj = NULL; - CompileWord(envPtr, listTokenPtr, interp, 1); - if (parsePtr->numWords == 4) { - if (idx1 == 0) { - if (idx2 == TCL_INDEX_END) { - goto dropAll; - } - idx1 = idx2 + 1; - idx2 = TCL_INDEX_END; - goto dropEnd; - } else if (idx2 == TCL_INDEX_END) { - idx2 = idx1 - 1; - idx1 = 0; - goto dropEnd; - } else { - if (idx2 < idx1) { - idx2 = idx1 - 1; - } - if (idx1 > 0) { - tmpObj = Tcl_NewIntObj(idx1); - Tcl_IncrRefCount(tmpObj); - } - goto dropRange; - } - } - - tokenPtr = TokenAfter(tokenPtr); - for (i=4 ; i<parsePtr->numWords ; i++) { - CompileWord(envPtr, tokenPtr, interp, i); - tokenPtr = TokenAfter(tokenPtr); - } - TclEmitInstInt4( INST_LIST, i - 4, envPtr); - TclEmitInstInt4( INST_REVERSE, 2, envPtr); - if (idx1 == 0) { - if (idx2 == TCL_INDEX_END) { - goto replaceAll; - } - idx1 = idx2 + 1; - idx2 = TCL_INDEX_END; - goto replaceHead; + if (idx2 == TCL_INDEX_BEFORE) { + suffixStart = idx1; } else if (idx2 == TCL_INDEX_END) { - idx2 = idx1 - 1; - idx1 = 0; - goto replaceTail; + suffixStart = TCL_INDEX_AFTER; + } else if (((idx2 < TCL_INDEX_END) && (idx1 <= TCL_INDEX_END)) + || ((idx2 >= TCL_INDEX_START) && (idx1 >= TCL_INDEX_START))) { + suffixStart = (idx1 > idx2 + 1) ? idx1 : idx2 + 1; } else { - if (idx2 < idx1) { - idx2 = idx1 - 1; - } - if (idx1 > 0) { - tmpObj = Tcl_NewIntObj(idx1); - Tcl_IncrRefCount(tmpObj); - } - goto replaceRange; + return TCL_ERROR; } + /* All paths start with computing/pushing the original value. */ + CompileWord(envPtr, listTokenPtr, interp, 1); + /* - * Issue instructions to perform the operations relating to configurations - * that just drop. The only argument pushed on the stack is the list to - * operate on. + * Push all the replacement values next so any errors raised in + * creating them get raised first. */ + if (parsePtr->numWords > 4) { + /* Push the replacement arguments */ + tokenPtr = TokenAfter(tokenPtr); + for (i=4 ; i<parsePtr->numWords ; i++) { + CompileWord(envPtr, tokenPtr, interp, i); + tokenPtr = TokenAfter(tokenPtr); + } - dropAll: /* This just ensures the arg is a list. */ - TclEmitOpcode( INST_LIST_LENGTH, envPtr); - TclEmitOpcode( INST_POP, envPtr); - PushStringLiteral(envPtr, ""); - goto done; - - dropEnd: - TclEmitInstInt4( INST_LIST_RANGE_IMM, idx1, envPtr); - TclEmitInt4( idx2, envPtr); - goto done; - - dropRange: - if (tmpObj != NULL) { - /* - * Emit bytecode to check the list length. - */ + /* Make a list of them... */ + TclEmitInstInt4( INST_LIST, i - 4, envPtr); - TclEmitOpcode( INST_DUP, envPtr); + emptyPrefix = 0; + } + + /* + * [lreplace] raises an error when idx1 points after the list, but + * only when the list is not empty. This is maximum stupidity. + * + * TODO: TIP this nonsense away! + */ + if (idx1 >= TCL_INDEX_START) { + if (emptyPrefix) { + TclEmitOpcode( INST_DUP, envPtr); + } else { + TclEmitInstInt4( INST_OVER, 1, envPtr); + } TclEmitOpcode( INST_LIST_LENGTH, envPtr); - TclEmitPush(TclAddLiteralObj(envPtr, tmpObj, NULL), envPtr); - TclEmitOpcode( INST_GE, envPtr); + TclEmitOpcode( INST_DUP, envPtr); offset = CurrentOffset(envPtr); - TclEmitInstInt1( INST_JUMP_TRUE1, 0, envPtr); - - /* - * Emit an error if we've been given an empty list. - */ + TclEmitInstInt1( INST_JUMP_FALSE1, 0, envPtr); - TclEmitOpcode( INST_DUP, envPtr); - TclEmitOpcode( INST_LIST_LENGTH, envPtr); + /* List is not empty */ + TclEmitPush(TclAddLiteralObj(envPtr, Tcl_NewIntObj(idx1), + NULL), envPtr); + TclEmitOpcode( INST_GT, envPtr); offset2 = CurrentOffset(envPtr); - TclEmitInstInt1( INST_JUMP_FALSE1, 0, envPtr); + TclEmitInstInt1( INST_JUMP_TRUE1, 0, envPtr); + + /* Idx1 >= list length ===> raise an error */ TclEmitPush(TclAddLiteralObj(envPtr, Tcl_ObjPrintf( "list doesn't contain element %d", idx1), NULL), envPtr); CompileReturnInternal(envPtr, INST_RETURN_IMM, TCL_ERROR, 0, Tcl_ObjPrintf("-errorcode {TCL OPERATION LREPLACE BADIDX}")); TclStoreInt1AtPtr(CurrentOffset(envPtr) - offset, envPtr->codeStart + offset + 1); + TclEmitOpcode( INST_POP, envPtr); TclStoreInt1AtPtr(CurrentOffset(envPtr) - offset2, envPtr->codeStart + offset2 + 1); - TclAdjustStackDepth(-1, envPtr); } - TclEmitOpcode( INST_DUP, envPtr); - TclEmitInstInt4( INST_LIST_RANGE_IMM, 0, envPtr); - TclEmitInt4( idx1 - 1, envPtr); - TclEmitInstInt4( INST_REVERSE, 2, envPtr); - TclEmitInstInt4( INST_LIST_RANGE_IMM, idx2 + 1, envPtr); - TclEmitInt4( TCL_INDEX_END, envPtr); - TclEmitOpcode( INST_LIST_CONCAT, envPtr); - goto done; - - /* - * Issue instructions to perform the operations relating to configurations - * that do real replacement. All arguments are pushed and assembled into a - * pair: the list of values to replace with, and the list to do the - * surgery on. - */ - - replaceAll: - TclEmitOpcode( INST_LIST_LENGTH, envPtr); - TclEmitOpcode( INST_POP, envPtr); - goto done; - - replaceHead: - TclEmitInstInt4( INST_LIST_RANGE_IMM, idx1, envPtr); - TclEmitInt4( idx2, envPtr); - TclEmitOpcode( INST_LIST_CONCAT, envPtr); - goto done; - - replaceTail: - TclEmitInstInt4( INST_LIST_RANGE_IMM, idx1, envPtr); - TclEmitInt4( idx2, envPtr); - TclEmitInstInt4( INST_REVERSE, 2, envPtr); - TclEmitOpcode( INST_LIST_CONCAT, envPtr); - goto done; - - replaceRange: - if (tmpObj != NULL) { - /* - * Emit bytecode to check the list length. - */ - - TclEmitOpcode( INST_DUP, envPtr); - TclEmitOpcode( INST_LIST_LENGTH, envPtr); - - /* - * Check the list length vs idx1. - */ - - TclEmitPush(TclAddLiteralObj(envPtr, tmpObj, NULL), envPtr); - TclEmitOpcode( INST_GE, envPtr); - offset = CurrentOffset(envPtr); - TclEmitInstInt1( INST_JUMP_TRUE1, 0, envPtr); + if ((idx1 == suffixStart) && (parsePtr->numWords == 4)) { /* - * Emit an error if we've been given an empty list. + * This is a "no-op". Example: [lreplace {a b c} 2 0] + * We still do a list operation to get list-verification + * and canonicalization side effects. */ + TclEmitInstInt4( INST_LIST_RANGE_IMM, 0, envPtr); + TclEmitInt4( TCL_INDEX_END, envPtr); + return TCL_OK; + } - TclEmitOpcode( INST_DUP, envPtr); - TclEmitOpcode( INST_LIST_LENGTH, envPtr); - offset2 = CurrentOffset(envPtr); - TclEmitInstInt1( INST_JUMP_FALSE1, 0, envPtr); - TclEmitPush(TclAddLiteralObj(envPtr, Tcl_ObjPrintf( - "list doesn't contain element %d", idx1), NULL), envPtr); - CompileReturnInternal(envPtr, INST_RETURN_IMM, TCL_ERROR, 0, - Tcl_ObjPrintf("-errorcode {TCL OPERATION LREPLACE BADIDX}")); - TclStoreInt1AtPtr(CurrentOffset(envPtr) - offset, - envPtr->codeStart + offset + 1); - TclStoreInt1AtPtr(CurrentOffset(envPtr) - offset2, - envPtr->codeStart + offset2 + 1); - TclAdjustStackDepth(-1, envPtr); + if (idx1 != TCL_INDEX_START) { + /* Prefix may not be empty; generate bytecode to push it */ + if (emptyPrefix) { + TclEmitOpcode( INST_DUP, envPtr); + } else { + TclEmitInstInt4( INST_OVER, 1, envPtr); + } + TclEmitInstInt4( INST_LIST_RANGE_IMM, 0, envPtr); + TclEmitInt4( idx1 - 1, envPtr); + if (!emptyPrefix) { + TclEmitInstInt4( INST_REVERSE, 2, envPtr); + TclEmitOpcode( INST_LIST_CONCAT, envPtr); + } + emptyPrefix = 0; } - TclEmitOpcode( INST_DUP, envPtr); - TclEmitInstInt4( INST_LIST_RANGE_IMM, 0, envPtr); - TclEmitInt4( idx1 - 1, envPtr); - TclEmitInstInt4( INST_REVERSE, 2, envPtr); - TclEmitInstInt4( INST_LIST_RANGE_IMM, idx2 + 1, envPtr); - TclEmitInt4( TCL_INDEX_END, envPtr); - TclEmitInstInt4( INST_REVERSE, 3, envPtr); - TclEmitOpcode( INST_LIST_CONCAT, envPtr); - TclEmitInstInt4( INST_REVERSE, 2, envPtr); - TclEmitOpcode( INST_LIST_CONCAT, envPtr); - goto done; - /* - * Clean up the allocated memory. - */ + if (!emptyPrefix) { + TclEmitInstInt4( INST_REVERSE, 2, envPtr); + } - done: - if (tmpObj != NULL) { - Tcl_DecrRefCount(tmpObj); + if (suffixStart == TCL_INDEX_AFTER) { + TclEmitOpcode( INST_POP, envPtr); + if (emptyPrefix) { + PushStringLiteral(envPtr, ""); + } + } else { + /* Suffix may not be empty; generate bytecode to push it */ + TclEmitInstInt4( INST_LIST_RANGE_IMM, suffixStart, envPtr); + TclEmitInt4( TCL_INDEX_END, envPtr); + if (!emptyPrefix) { + TclEmitOpcode( INST_LIST_CONCAT, envPtr); + } } + return TCL_OK; } @@ -2944,7 +2858,7 @@ TclCompileVariableCmd( return TCL_ERROR; } - /* TODO: Consider what value can pass throug the + /* TODO: Consider what value can pass through the * IndexTailVarIfKnown() screen. Full CompileWord() * likely does not apply here. Push known value instead. */ CompileWord(envPtr, varTokenPtr, interp, i); diff --git a/generic/tclCompCmdsSZ.c b/generic/tclCompCmdsSZ.c index 294ee25..79c5c78 100644 --- a/generic/tclCompCmdsSZ.c +++ b/generic/tclCompCmdsSZ.c @@ -930,22 +930,48 @@ TclCompileStringRangeCmd( fromTokenPtr = TokenAfter(stringTokenPtr); toTokenPtr = TokenAfter(fromTokenPtr); + /* Every path must push the string argument */ + CompileWord(envPtr, stringTokenPtr, interp, 1); + /* * Parse the two indices. */ - if (TclGetIndexFromToken(fromTokenPtr, &idx1) != TCL_OK) { + if (TclGetIndexFromToken(fromTokenPtr, TCL_INDEX_START, TCL_INDEX_AFTER, + &idx1) != TCL_OK) { goto nonConstantIndices; } - if (TclGetIndexFromToken(toTokenPtr, &idx2) != TCL_OK) { + /* + * Token parsed as an index expression. We treat all indices before + * the string the same as the start of the string. + */ + + if (idx1 == TCL_INDEX_AFTER) { + /* [string range $s end+1 $last] must be empty string */ + OP( POP); + PUSH( ""); + return TCL_OK; + } + + if (TclGetIndexFromToken(toTokenPtr, TCL_INDEX_BEFORE, TCL_INDEX_END, + &idx2) != TCL_OK) { goto nonConstantIndices; } + /* + * Token parsed as an index expression. We treat all indices after + * the string the same as the end of the string. + */ + if (idx2 == TCL_INDEX_BEFORE) { + /* [string range $s $first -1] must be empty string */ + OP( POP); + PUSH( ""); + return TCL_OK; + } /* * Push the operand onto the stack and then the substring operation. */ - CompileWord(envPtr, stringTokenPtr, interp, 1); OP44( STR_RANGE_IMM, idx1, idx2); return TCL_OK; @@ -954,7 +980,6 @@ TclCompileStringRangeCmd( */ nonConstantIndices: - CompileWord(envPtr, stringTokenPtr, interp, 1); CompileWord(envPtr, fromTokenPtr, interp, 2); CompileWord(envPtr, toTokenPtr, interp, 3); OP( STR_RANGE); @@ -984,27 +1009,39 @@ TclCompileStringReplaceCmd( replacementTokenPtr = TokenAfter(tokenPtr); } - /* - * Parse the indices. Will only compile special cases if both are - * constants and not an _integer_ less than zero (since we reserve - * negative indices here for end-relative indexing) or an end-based index - * greater than 'end' itself. - */ - tokenPtr = TokenAfter(valueTokenPtr); - if (TclGetIndexFromToken(tokenPtr, &idx1) != TCL_OK) { + if (TclGetIndexFromToken(tokenPtr, TCL_INDEX_START, TCL_INDEX_AFTER, + &idx1) != TCL_OK) { goto genericReplace; } + /* + * Token parsed as an index value. Indices before the string are + * treated as index of start of string. + */ tokenPtr = TokenAfter(tokenPtr); - if (TclGetIndexFromToken(tokenPtr, &idx2) != TCL_OK) { + if (TclGetIndexFromToken(tokenPtr, TCL_INDEX_BEFORE, TCL_INDEX_END, + &idx2) != TCL_OK) { goto genericReplace; } + /* + * Token parsed as an index value. Indices after the string are + * treated as index of end of string. + */ +/* TODO...... */ /* * 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 +1059,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 +1096,9 @@ TclCompileStringReplaceCmd( } /* Replace last */ CompileWord(envPtr, replacementTokenPtr, interp, 4); + + /* More bullshit; see NOTE above. */ + OP4( OVER, 1); PUSH( ""); OP( STR_EQ); diff --git a/generic/tclCompile.h b/generic/tclCompile.h index cb2576e..a1fc151 100644 --- a/generic/tclCompile.h +++ b/generic/tclCompile.h @@ -1137,7 +1137,8 @@ MODULE_SCOPE int TclFixupForwardJump(CompileEnv *envPtr, int distThreshold); MODULE_SCOPE void TclFreeCompileEnv(CompileEnv *envPtr); MODULE_SCOPE void TclFreeJumpFixupArray(JumpFixupArray *fixupArrayPtr); -MODULE_SCOPE int TclGetIndexFromToken(Tcl_Token *tokenPtr, int *index); +MODULE_SCOPE int TclGetIndexFromToken(Tcl_Token *tokenPtr, + int before, int after, int *indexPtr); MODULE_SCOPE ByteCode * TclInitByteCode(CompileEnv *envPtr); MODULE_SCOPE ByteCode * TclInitByteCodeObj(Tcl_Obj *objPtr, const Tcl_ObjType *typePtr, CompileEnv *envPtr); @@ -1681,12 +1682,6 @@ MODULE_SCOPE int TclPushProcCallFrame(ClientData clientData, #define TCL_NO_ELEMENT 2 /* Do not push the array element. */ /* - * Special value used by TclGetIndexFromToken to encoding the "end" index. - */ - -#define TCL_INDEX_END (-2) - -/* * DTrace probe macros (NOPs if DTrace support is not enabled). */ diff --git a/generic/tclExecute.c b/generic/tclExecute.c index b69c895..87765e7 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -4818,16 +4818,9 @@ TEBCresume( goto gotError; } - /* - * Select the list item based on the index. Negative operand means - * end-based indexing. - */ + /* Decode end-offset index values. */ - if (opnd < -1) { - index = opnd+1 + objc; - } else { - index = opnd; - } + index = TclIndexDecode(opnd, objc - 1); pcAdjustment = 5; lindexFastPath: @@ -4975,47 +4968,58 @@ TEBCresume( } #endif - /* - * Adjust the indices for end-based handling. + /* Decode index value operands. */ + + /* + assert ( toIdx != TCL_INDEX_AFTER); + * + * Extra safety for legacy bytecodes: */ + if (toIdx == TCL_INDEX_AFTER) { + toIdx = TCL_INDEX_END; + } - if (fromIdx < -1) { - fromIdx += 1+objc; - if (fromIdx < -1) { - fromIdx = -1; - } - } else if (fromIdx > objc) { - fromIdx = objc; + if ((toIdx == TCL_INDEX_BEFORE) || (fromIdx == TCL_INDEX_AFTER)) { + goto emptyList; } - if (toIdx < -1) { - toIdx += 1 + objc; - if (toIdx < -1) { - toIdx = -1; - } - } else if (toIdx > objc) { - toIdx = objc; + toIdx = TclIndexDecode(toIdx, objc - 1); + if (toIdx < 0) { + goto emptyList; + } else if (toIdx >= objc) { + toIdx = objc - 1; } + assert ( toIdx >= 0 && toIdx < objc); /* - * Check if we are referring to a valid, non-empty list range, and if - * so, build the list of elements in that range. + assert ( fromIdx != TCL_INDEX_BEFORE ); + * + * Extra safety for legacy bytecodes: */ + if (fromIdx == TCL_INDEX_BEFORE) { + fromIdx = TCL_INDEX_START; + } - if (fromIdx<=toIdx && fromIdx<objc && toIdx>=0) { - if (fromIdx < 0) { - fromIdx = 0; - } - if (toIdx >= objc) { - toIdx = objc-1; - } - if (fromIdx == 0 && toIdx != objc-1 && !Tcl_IsShared(valuePtr)) { - Tcl_ListObjReplace(interp, valuePtr, - toIdx + 1, LIST_MAX, 0, NULL); + fromIdx = TclIndexDecode(fromIdx, objc - 1); + if (fromIdx < 0) { + fromIdx = 0; + } + + if (fromIdx <= toIdx) { + /* Construct the subsquence list */ + /* unshared optimization */ + if (Tcl_IsShared(valuePtr)) { + objResultPtr = Tcl_NewListObj(toIdx-fromIdx+1, objv+fromIdx); + } else { + if (toIdx != objc - 1) { + Tcl_ListObjReplace(NULL, valuePtr, toIdx + 1, LIST_MAX, + 0, NULL); + } + Tcl_ListObjReplace(NULL, valuePtr, 0, fromIdx, 0, NULL); TRACE_APPEND(("%.30s\n", O2S(valuePtr))); NEXT_INST_F(9, 0, 0); } - objResultPtr = Tcl_NewListObj(toIdx-fromIdx+1, objv+fromIdx); } else { + emptyList: TclNewObj(objResultPtr); } @@ -5361,31 +5365,58 @@ TEBCresume( length = Tcl_GetCharLength(valuePtr); TRACE(("\"%.20s\" %d %d => ", O2S(valuePtr), fromIdx, toIdx)); + /* Every range of an empty value is an empty value */ + if (length == 0) { + TRACE_APPEND(("\n")); + NEXT_INST_F(9, 0, 0); + } + + /* Decode index operands. */ + /* - * Adjust indices for end-based indexing. + assert ( toIdx != TCL_INDEX_BEFORE ); + assert ( toIdx != TCL_INDEX_AFTER); + * + * Extra safety for legacy bytecodes: */ - - if (fromIdx < -1) { - fromIdx += 1 + length; - if (fromIdx < 0) { - fromIdx = 0; - } - } else if (fromIdx >= length) { - fromIdx = length; + if (toIdx == TCL_INDEX_BEFORE) { + goto emptyRange; + } + if (toIdx == TCL_INDEX_AFTER) { + toIdx = TCL_INDEX_END; } - if (toIdx < -1) { - toIdx += 1 + length; + + toIdx = TclIndexDecode(toIdx, length - 1); + if (toIdx < 0) { + goto emptyRange; } else if (toIdx >= length) { toIdx = length - 1; } + assert ( toIdx >= 0 && toIdx < length ); + /* - * Check if we can do a sane substring. + assert ( fromIdx != TCL_INDEX_BEFORE ); + assert ( fromIdx != TCL_INDEX_AFTER); + * + * Extra safety for legacy bytecodes: */ + if (fromIdx == TCL_INDEX_BEFORE) { + fromIdx = TCL_INDEX_START; + } + if (fromIdx == TCL_INDEX_AFTER) { + goto emptyRange; + } + + fromIdx = TclIndexDecode(fromIdx, length - 1); + if (fromIdx < 0) { + fromIdx = 0; + } if (fromIdx <= toIdx) { objResultPtr = Tcl_GetRange(valuePtr, fromIdx, toIdx); } else { + emptyRange: TclNewObj(objResultPtr); } TRACE_APPEND(("%.30s\n", O2S(objResultPtr))); diff --git a/generic/tclInt.h b/generic/tclInt.h index 4a2f95e..0dd129b 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -4069,6 +4069,21 @@ MODULE_SCOPE TCL_HASH_TYPE TclHashObjKey(Tcl_HashTable *tablePtr, void *keyPtr); MODULE_SCOPE int TclFullFinalizationRequested(void); /* + * Utility routines for encoding index values as integers. Used by both + * some of the command compilers and by [lsort] and [lsearch]. + */ + +MODULE_SCOPE int TclIndexEncode(Tcl_Interp *interp, Tcl_Obj *objPtr, + int before, int after, int *indexPtr); +MODULE_SCOPE int TclIndexDecode(int encoded, int endValue); + +/* Constants used in index value encoding routines. */ +#define TCL_INDEX_END (-2) +#define TCL_INDEX_BEFORE (-1) +#define TCL_INDEX_START (0) +#define TCL_INDEX_AFTER (INT_MAX) + +/* *---------------------------------------------------------------- * Macros used by the Tcl core to create and release Tcl objects. * TclNewObj(objPtr) creates a new object denoting an empty string. 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; } diff --git a/generic/tclPkg.c b/generic/tclPkg.c index 6c5b827..1e54aa7 100644 --- a/generic/tclPkg.c +++ b/generic/tclPkg.c @@ -728,8 +728,18 @@ SelectPackage(ClientData data[], Tcl_Interp *interp, int result) { */ char *versionToProvide = bestPtr->version; + PkgFiles *pkgFiles; + PkgName *pkgName; + 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); } @@ -748,17 +758,9 @@ SelectPackageFinal(ClientData data[], Tcl_Interp *interp, int result) { const char *name = reqPtr->name; char *versionToProvide = reqPtr->versionToProvide; - 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 *pkgFiles = Tcl_GetAssocData(interp, "tclPkgFiles", NULL); + PkgName *pkgName = pkgFiles->names; pkgFiles->names = pkgName->nextPtr; ckfree(pkgName); diff --git a/generic/tclUtil.c b/generic/tclUtil.c index 546e9f3..3833e30 100644 --- a/generic/tclUtil.c +++ b/generic/tclUtil.c @@ -3645,7 +3645,6 @@ TclGetIntForIndex( return TCL_ERROR; } - /* *---------------------------------------------------------------------- * @@ -3689,6 +3688,7 @@ GetEndOffsetFromObj( return TCL_ERROR; } if (bytes[3] == '-') { + /* TODO: Handle overflow cases sensibly */ offset = -offset; } } @@ -3703,6 +3703,143 @@ GetEndOffsetFromObj( /* *---------------------------------------------------------------------- * + * TclIndexEncode -- + * + * Parse objPtr to determine if it is an index value. Two cases + * are possible. The value objPtr might be parsed as an absolute + * index value in the C signed int range. Note that this includes + * index values that are integers as presented and it includes index + * arithmetic expressions. The absolute index values that can be + * directly meaningful as an index into either a list or a string are + * those integer values >= TCL_INDEX_START (0) + * and < TCL_INDEX_AFTER (INT_MAX). + * The largest string supported in Tcl 8 has bytelength INT_MAX. + * This means the largest supported character length is also INT_MAX, + * and the index of the last character in a string of length INT_MAX + * is INT_MAX-1. + * + * Any absolute index value parsed outside that range is encoded + * using the before and after values passed in by the + * caller as the encoding to use for indices that are either + * less than or greater than the usable index range. TCL_INDEX_AFTER + * is available as a good choice for most callers to use for + * after. Likewise, the value TCL_INDEX_BEFORE is good for + * most callers to use for before. Other values are possible + * when the caller knows it is helpful in producing its own behavior + * for indices before and after the indexed item. + * + * A token can also be parsed as an end-relative index expression. + * All end-relative expressions that indicate an index larger + * than end (end+2, end--5) point beyond the end of the indexed + * collection, and can be encoded as after. The end-relative + * expressions that indicate an index less than or equal to end + * are encoded relative to the value TCL_INDEX_END (-2). The + * index "end" is encoded as -2, down to the index "end-0x7ffffffe" + * which is encoded as INT_MIN. Since the largest index into a + * string possible in Tcl 8 is 0x7ffffffe, the interpretation of + * "end-0x7ffffffe" for that largest string would be 0. Thus, + * if the tokens "end-0x7fffffff" or "end+-0x80000000" are parsed, + * they can be encoded with the before value. + * + * These details will require re-examination whenever string and + * list length limits are increased, but that will likely also + * mean a revised routine capable of returning Tcl_WideInt values. + * + * Returns: + * TCL_OK if parsing succeeded, and TCL_ERROR if it failed. + * + * Side effects: + * When TCL_OK is returned, the encoded index value is written + * to *indexPtr. + * + *---------------------------------------------------------------------- + */ + +int +TclIndexEncode( + Tcl_Interp *interp, /* For error reporting, may be NULL */ + Tcl_Obj *objPtr, /* Index value to parse */ + int before, /* Value to return for index before beginning */ + int after, /* Value to return for index after end */ + int *indexPtr) /* Where to write the encoded answer, not NULL */ +{ + int idx; + + if (TCL_OK == TclGetIntFromObj(NULL, objPtr, &idx)) { + /* We parsed a value in the range INT_MIN...INT_MAX */ + integerEncode: + if (idx < TCL_INDEX_START) { + /* All negative absolute indices are "before the beginning" */ + idx = before; + } else if (idx == INT_MAX) { + /* This index value is always "after the end" */ + idx = after; + } + /* usual case, the absolute index value encodes itself */ + } else if (TCL_OK == GetEndOffsetFromObj(objPtr, 0, &idx)) { + /* + * We parsed an end+offset index value. + * idx holds the offset value in the range INT_MIN...INT_MAX. + */ + if (idx > 0) { + /* + * All end+postive or end-negative expressions + * always indicate "after the end". + */ + idx = after; + } else if (idx < INT_MIN - TCL_INDEX_END) { + /* These indices always indicate "before the beginning */ + idx = before; + } else { + /* Encoded end-positive (or end+negative) are offset */ + idx += TCL_INDEX_END; + } + + /* TODO: Consider flag to suppress repeated end-offset parse. */ + } else if (TCL_OK == TclGetIntForIndexM(interp, objPtr, 0, &idx)) { + /* + * Only reach this case when the index value is a + * constant index arithmetic expression, and idx + * holds the result. Treat it the same as if it were + * parsed as an absolute integer value. + */ + goto integerEncode; + } else { + return TCL_ERROR; + } + *indexPtr = idx; + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * TclIndexDecode -- + * + * Decodes a value previously encoded by TclIndexEncode. The argument + * endValue indicates what value of "end" should be used in the + * decoding. + * + * Results: + * The decoded index value. + * + *---------------------------------------------------------------------- + */ + +int +TclIndexDecode( + int encoded, /* Value to decode */ + int endValue) /* Meaning of "end" to use, > TCL_INDEX_END */ +{ + if (encoded <= TCL_INDEX_END) { + return (encoded - TCL_INDEX_END) + endValue; + } + return encoded; +} + +/* + *---------------------------------------------------------------------- + * * TclCheckBadOctal -- * * This function checks for a bad octal value and appends a meaningful diff --git a/tests/assemble.test b/tests/assemble.test index 6e5308d..d7c47a9 100644 --- a/tests/assemble.test +++ b/tests/assemble.test @@ -1584,6 +1584,12 @@ test assemble-15.7 {listIndexImm} { } -result c } +test assemble-15.8 {listIndexImm} { + assemble {push {a b c}; listIndexImm end+2} +} {} +test assemble-15.9 {listIndexImm} { + assemble {push {a b c}; listIndexImm -1-1} +} {} # assemble-16 - invokeStk diff --git a/tests/cmdIL.test b/tests/cmdIL.test index df59e6e..b9444b6 100644 --- a/tests/cmdIL.test +++ b/tests/cmdIL.test @@ -160,6 +160,12 @@ test cmdIL-1.39 {Tcl_LsortObjCmd procedure, Bug 8e1e31eac0fd6b6c} fullutf { test cmdIL-1.40 {Tcl_LsortObjCmd procedure, Bug 8e1e31eac0fd6b6c} fullutf { lsort -ascii -nocase [list \0 \x7f \x80 \U01ffff \uffff] } [list \0 \x7f \x80 \uffff \U01ffff] +test cmdIL-1.41 {lsort -stride and -index} -body { + lsort -stride 2 -index -2 {a 2 b 1} +} -returnCodes error -result {index "-2" cannot select an element from any list} +test cmdIL-1.42 {lsort -stride and-index} -body { + lsort -stride 2 -index -1-1 {a 2 b 1} +} -returnCodes error -result {index "-1-1" cannot select an element from any list} # Can't think of any good tests for the MergeSort and MergeLists procedures, # except a bunch of random lists to sort. @@ -216,6 +222,33 @@ test cmdIL-3.4.1 {SortCompare procedure, -index option} -body { test cmdIL-3.5 {SortCompare procedure, -index option} -body { lsort -integer -index 2 {{20 10 13} {15}} } -returnCodes error -result {element 2 missing from sublist "15"} +test cmdIL-3.5.1 {SortCompare procedure, -index option (out of range, calculated index)} -body { + lsort -index 1+3 {{1 . c} {2 . b} {3 . a}} +} -returnCodes error -result {element 4 missing from sublist "1 . c"} +test cmdIL-3.5.2 {SortCompare procedure, -index option (out of range, calculated index)} -body { + lsort -index -1-1 {{1 . c} {2 . b} {3 . a}} +} -returnCodes error -result {index "-1-1" cannot select an element from any list} +test cmdIL-3.5.3 {SortCompare procedure, -index option (out of range, calculated index)} -body { + lsort -index -2 {{1 . c} {2 . b} {3 . a}} +} -returnCodes error -result {index "-2" cannot select an element from any list} +test cmdIL-3.5.4 {SortCompare procedure, -index option (out of range, calculated index)} -body { + lsort -index end-4 {{1 . c} {2 . b} {3 . a}} +} -returnCodes error -result {element -2 missing from sublist "1 . c"} +test cmdIL-3.5.5 {SortCompare procedure, -index option} { + lsort -index {} {a b} +} {a b} +test cmdIL-3.5.6 {SortCompare procedure, -index option} { + lsort -index {} [list a \{] +} {a \{} +test cmdIL-3.5.7 {SortCompare procedure, -index option (out of range, calculated index)} -body { + lsort -index end--1 {{1 . c} {2 . b} {3 . a}} +} -returnCodes error -result {index "end--1" cannot select an element from any list} +test cmdIL-3.5.8 {SortCompare procedure, -index option (out of range, calculated index)} -body { + lsort -index end+1 {{1 . c} {2 . b} {3 . a}} +} -returnCodes error -result {index "end+1" cannot select an element from any list} +test cmdIL-3.5.9 {SortCompare procedure, -index option (out of range, calculated index)} -body { + lsort -index end+2 {{1 . c} {2 . b} {3 . a}} +} -returnCodes error -result {index "end+2" cannot select an element from any list} test cmdIL-3.6 {SortCompare procedure, -index option} { lsort -integer -index 2 {{1 15 30} {2 5 25} {3 25 20}} } {{3 25 20} {2 5 25} {1 15 30}} diff --git a/tests/lindex.test b/tests/lindex.test index 29eb898..bb3f005 100644 --- a/tests/lindex.test +++ b/tests/lindex.test @@ -79,6 +79,15 @@ test lindex-3.7 {indexes don't shimmer wide ints} { set x [expr {(wide(1)<<31) - 2}] list $x [lindex {1 2 3} $x] [incr x] [incr x] } {2147483646 {} 2147483647 2147483648} +test lindex-3.8 {compiled with static indices out of range, negative} { + list [lindex {a b c} -1] [lindex {a b c} -2] [lindex {a b c} -3] +} [lrepeat 3 {}] +test lindex-3.9 {compiled with calculated indices out of range, negative constant} { + list [lindex {a b c} -1-1] [lindex {a b c} -2+0] [lindex {a b c} -2+1] +} [lrepeat 3 {}] +test lindex-3.10 {compiled with calculated indices out of range, after end} { + list [lindex {a b c} end+1] [lindex {a b c} end+2] [lindex {a b c} end+3] +} [lrepeat 3 {}] # Indices relative to end diff --git a/tests/lrange.test b/tests/lrange.test index 02b9c65..a5367a4 100644 --- a/tests/lrange.test +++ b/tests/lrange.test @@ -90,6 +90,24 @@ test lrange-3.1 {Bug 3588366: end-offsets before start} { lrange $l 0 end-5 }} {1 2 3 4 5} } {} + +test lrange-3.2 {compiled with static indices out of range, negative} { + list [lrange {a b c} -1 -2] [lrange {a b c} -2 -1] [lrange {a b c} -3 -2] [lrange {a b c} -2 -3] +} [lrepeat 4 {}] +test lrange-3.3 {compiled with calculated indices out of range, negative constant} { + list [lrange {a b c} 0-1 -1-1] [lrange {a b c} -2+0 0-1] [lrange {a b c} -2-1 -2+1] [lrange {a b c} -2+1 -2-1] +} [lrepeat 4 {}] +test lrange-3.4 {compiled with calculated indices out of range, after end} { + list [lrange {a b c} end+1 end+2] [lrange {a b c} end+2 end+1] [lrange {a b c} end+2 end+3] [lrange {a b c} end+3 end+2] +} [lrepeat 4 {}] + +test lrange-3.5 {compiled with calculated indices, start out of range (negative)} { + list [lrange {a b c} -1 1] [lrange {a b c} -1+0 end-1] [lrange {a b c} -2 1] [lrange {a b c} -2+0 0+1] +} [lrepeat 4 {a b}] +test lrange-3.6 {compiled with calculated indices, end out of range (after end)} { + list [lrange {a b c} 1 end+1] [lrange {a b c} 1+0 2+1] [lrange {a b c} 1 end+1] [lrange {a b c} end-1 3+1] +} [lrepeat 4 {b c}] + # cleanup ::tcltest::cleanupTests diff --git a/tests/lreplace.test b/tests/lreplace.test index d7f8226..4a6b853 100644 --- a/tests/lreplace.test +++ b/tests/lreplace.test @@ -98,12 +98,18 @@ test lreplace-1.26 {lreplace command} { [set foo [lreplace $foo end end]] \ [set foo [lreplace $foo end end]] } {a {} {}} -test lreplace-1.27 {lreplace command} { +test lreplace-1.27 {lreplace command} -body { lreplace x 1 1 -} x -test lreplace-1.28 {lreplace command} { +} -returnCodes 1 -result {list doesn't contain element 1} +test lreplace-1.28 {lreplace command} -body { lreplace x 1 1 y -} {x y} +} -returnCodes 1 -result {list doesn't contain element 1} +test lreplace-1.29 {lreplace command} -body { + lreplace x 1 1 [error foo] +} -returnCodes 1 -result {foo} +test lreplace-1.30 {lreplace command} -body { + lreplace {not {}alist} 0 0 [error foo] +} -returnCodes 1 -result {foo} test lreplace-2.1 {lreplace errors} { list [catch lreplace msg] $msg diff --git a/tests/lsearch.test b/tests/lsearch.test index a7efcdd..e401581 100644 --- a/tests/lsearch.test +++ b/tests/lsearch.test @@ -418,6 +418,34 @@ test lsearch-17.6 {lsearch -index option, basic functionality} { test lsearch-17.7 {lsearch -index option, basic functionality} { lsearch -all -index 1 -regexp {{ab cb} {ab bb} {ab ab}} {[cb]b} } {0 1} +test lsearch-17.8 {lsearch -index option, empty argument} { + lsearch -index {} a a +} 0 +test lsearch-17.9 {lsearch -index option, empty argument} { + lsearch -index {} a a +} [lsearch a a] +test lsearch-17.10 {lsearch -index option, empty argument} { + lsearch -index {} [list \{] \{ +} 0 +test lsearch-17.11 {lsearch -index option, empty argument} { + lsearch -index {} [list \{] \{ +} [lsearch [list \{] \{] +test lsearch-17.12 {lsearch -index option, encoding aliasing} -body { + lsearch -index -2 a a +} -returnCodes error -result {index "-2" cannot select an element from any list} +test lsearch-17.13 {lsearch -index option, encoding aliasing} -body { + lsearch -index -1-1 a a +} -returnCodes error -result {index "-1-1" cannot select an element from any list} +test lsearch-17.14 {lsearch -index option, encoding aliasing} -body { + lsearch -index end--1 a a +} -returnCodes error -result {index "end--1" cannot select an element from any list} +test lsearch-17.15 {lsearch -index option, encoding aliasing} -body { + lsearch -index end+1 a a +} -returnCodes error -result {index "end+1" cannot select an element from any list} +test lsearch-17.16 {lsearch -index option, encoding aliasing} -body { + lsearch -index end+2 a a +} -returnCodes error -result {index "end+2" cannot select an element from any list} + test lsearch-18.1 {lsearch -index option, list as index basic functionality} { lsearch -index {0 0} {{{x x} {x b} {a d}} {{a c} {a b} {a a}}} a @@ -453,6 +481,12 @@ test lsearch-19.5 {lsearch -subindices option} { test lsearch-19.6 {lsearch -subindices option} { lsearch -subindices -all -index {1 0} -exact {{{a c} {a b} {d a}} {{a c} {a b} {d a}}} a } {{0 1 0} {1 1 0}} +test lsearch-19.7 {lsearch -subindices option} { + lsearch -subindices -index end {{1 a}} a +} {0 1} +test lsearch-19.8 {lsearch -subindices option} { + lsearch -subindices -all -index end {{1 a}} a +} {{0 1}} test lsearch-20.1 {lsearch -index option, index larger than sublists} -body { lsearch -index 2 {{a c} {a b} {a a}} a |