summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authordgp <dgp@users.sourceforge.net>2018-03-10 15:55:38 (GMT)
committerdgp <dgp@users.sourceforge.net>2018-03-10 15:55:38 (GMT)
commitdc5861414a559d3b12a64c6db2f121aba5e7d577 (patch)
tree57d7a2c3f340dca3c9d870a7f0dd78e30bb21e27
parentbd9f2eb15d41619e95eab98976d8028c46c1065d (diff)
parent6b5d0e5d8da204f9ab8165fafe0b497927a7fa24 (diff)
downloadtcl-dc5861414a559d3b12a64c6db2f121aba5e7d577.zip
tcl-dc5861414a559d3b12a64c6db2f121aba5e7d577.tar.gz
tcl-dc5861414a559d3b12a64c6db2f121aba5e7d577.tar.bz2
merge 8.7
-rw-r--r--generic/tclAssembly.c23
-rw-r--r--generic/tclBasic.c11
-rw-r--r--generic/tclCmdIL.c88
-rw-r--r--generic/tclCompCmdsGR.c388
-rw-r--r--generic/tclCompCmdsSZ.c74
-rw-r--r--generic/tclCompile.h9
-rw-r--r--generic/tclExecute.c131
-rw-r--r--generic/tclInt.h15
-rw-r--r--generic/tclLoad.c13
-rw-r--r--generic/tclPkg.c22
-rw-r--r--generic/tclUtil.c139
-rw-r--r--tests/assemble.test6
-rw-r--r--tests/cmdIL.test33
-rw-r--r--tests/lindex.test9
-rw-r--r--tests/lrange.test18
-rw-r--r--tests/lreplace.test14
-rw-r--r--tests/lsearch.test34
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,
&currentObj) != 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