summaryrefslogtreecommitdiffstats
path: root/generic/tclCmdIL.c
diff options
context:
space:
mode:
Diffstat (limited to 'generic/tclCmdIL.c')
-rw-r--r--generic/tclCmdIL.c476
1 files changed, 295 insertions, 181 deletions
diff --git a/generic/tclCmdIL.c b/generic/tclCmdIL.c
index e3c5f10..ac2288e 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:
*/
@@ -145,6 +138,8 @@ static int InfoScriptCmd(ClientData dummy, Tcl_Interp *interp,
int objc, Tcl_Obj *const objv[]);
static int InfoSharedlibCmd(ClientData dummy, Tcl_Interp *interp,
int objc, Tcl_Obj *const objv[]);
+static int InfoCmdTypeCmd(ClientData dummy, Tcl_Interp *interp,
+ int objc, Tcl_Obj *const objv[]);
static int InfoTclVersionCmd(ClientData dummy, Tcl_Interp *interp,
int objc, Tcl_Obj *const objv[]);
static SortElement * MergeLists(SortElement *leftPtr, SortElement *rightPtr,
@@ -163,6 +158,7 @@ static const EnsembleImplMap defaultInfoMap[] = {
{"args", InfoArgsCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0},
{"body", InfoBodyCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0},
{"cmdcount", InfoCmdCountCmd, TclCompileBasic0ArgCmd, NULL, NULL, 0},
+ {"cmdtype", InfoCmdTypeCmd, TclCompileBasic1ArgCmd, NULL, NULL, 1},
{"commands", InfoCommandsCmd, TclCompileInfoCommandsCmd, NULL, NULL, 0},
{"complete", InfoCompleteCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0},
{"coroutine", TclInfoCoroutineCmd, TclCompileInfoCoroutineCmd, NULL, NULL, 0},
@@ -177,7 +173,7 @@ static const EnsembleImplMap defaultInfoMap[] = {
{"library", InfoLibraryCmd, TclCompileBasic0ArgCmd, NULL, NULL, 0},
{"loaded", InfoLoadedCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 0},
{"locals", TclInfoLocalsCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 0},
- {"nameofexecutable", InfoNameOfExecutableCmd, TclCompileBasic0ArgCmd, NULL, NULL, 0},
+ {"nameofexecutable", InfoNameOfExecutableCmd, TclCompileBasic0ArgCmd, NULL, NULL, 1},
{"patchlevel", InfoPatchLevelCmd, TclCompileBasic0ArgCmd, NULL, NULL, 0},
{"procs", InfoProcsCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 0},
{"script", InfoScriptCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 0},
@@ -543,9 +539,9 @@ InfoBodyCmd(
Tcl_Obj *const objv[]) /* Argument objects. */
{
register Interp *iPtr = (Interp *) interp;
- const char *name;
+ const char *name, *bytes;
Proc *procPtr;
- Tcl_Obj *bodyPtr, *resultPtr;
+ int numBytes;
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "procname");
@@ -570,18 +566,8 @@ InfoBodyCmd(
* the object do not invalidate the internal rep.
*/
- bodyPtr = procPtr->bodyPtr;
- if (bodyPtr->bytes == NULL) {
- /*
- * The string rep might not be valid if the procedure has never been
- * run before. [Bug #545644]
- */
-
- TclGetString(bodyPtr);
- }
- resultPtr = Tcl_NewStringObj(bodyPtr->bytes, bodyPtr->length);
-
- Tcl_SetObjResult(interp, resultPtr);
+ bytes = Tcl_GetStringFromObj(procPtr->bodyPtr, &numBytes);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(bytes, numBytes));
return TCL_OK;
}
@@ -1677,7 +1663,7 @@ InfoLibraryCmd(
return TCL_ERROR;
}
- libDirName = Tcl_GetVar(interp, "tcl_library", TCL_GLOBAL_ONLY);
+ libDirName = Tcl_GetVar2(interp, "tcl_library", NULL, TCL_GLOBAL_ONLY);
if (libDirName != NULL) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(libDirName, -1));
return TCL_OK;
@@ -1717,19 +1703,24 @@ InfoLoadedCmd(
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
- const char *interpName;
+ const char *interpName, *packageName;
- if ((objc != 1) && (objc != 2)) {
- Tcl_WrongNumArgs(interp, 1, objv, "?interp?");
+ if (objc > 3) {
+ Tcl_WrongNumArgs(interp, 1, objv, "?interp? ?packageName?");
return TCL_ERROR;
}
- if (objc == 1) { /* Get loaded pkgs in all interpreters. */
+ if (objc < 2) { /* Get loaded pkgs in all interpreters. */
interpName = NULL;
} else { /* Get pkgs just in specified interp. */
interpName = TclGetString(objv[1]);
}
- return TclGetLoadedPackages(interp, interpName);
+ if (objc < 3) { /* Get loaded files in all packages. */
+ packageName = NULL;
+ } else { /* Get pkgs just in specified interp. */
+ packageName = TclGetString(objv[2]);
+ }
+ return TclGetLoadedPackagesEx(interp, interpName, packageName);
}
/*
@@ -1803,7 +1794,7 @@ InfoPatchLevelCmd(
return TCL_ERROR;
}
- patchlevel = Tcl_GetVar(interp, "tcl_patchLevel",
+ patchlevel = Tcl_GetVar2(interp, "tcl_patchLevel", NULL,
(TCL_GLOBAL_ONLY | TCL_LEAVE_ERR_MSG));
if (patchlevel != NULL) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(patchlevel, -1));
@@ -2134,6 +2125,60 @@ InfoTclVersionCmd(
/*
*----------------------------------------------------------------------
*
+ * InfoCmdTypeCmd --
+ *
+ * Called to implement the "info cmdtype" command that returns the type
+ * of a given command. Handles the following syntax:
+ *
+ * info cmdtype cmdName
+ *
+ * Results:
+ * Returns TCL_OK if successful and TCL_ERROR if there is an error.
+ *
+ * Side effects:
+ * Returns a type name. If there is an error, the result is an error
+ * message.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+InfoCmdTypeCmd(
+ ClientData dummy, /* Not used. */
+ Tcl_Interp *interp, /* Current interpreter. */
+ int objc, /* Number of arguments. */
+ Tcl_Obj *const objv[]) /* Argument objects. */
+{
+ Tcl_Command command;
+
+ if (objc != 2) {
+ Tcl_WrongNumArgs(interp, 1, objv, "commandName");
+ return TCL_ERROR;
+ }
+ command = Tcl_FindCommand(interp, Tcl_GetString(objv[1]), NULL,
+ TCL_LEAVE_ERR_MSG);
+ if (command == NULL) {
+ return TCL_ERROR;
+ }
+
+ /*
+ * There's one special case: safe slave interpreters can't see aliases as
+ * aliases as they're part of the security mechanisms.
+ */
+
+ if (Tcl_IsSafe(interp)
+ && (((Command *) command)->objProc == TclAliasObjCmd)) {
+ Tcl_AppendResult(interp, "native", NULL);
+ } else {
+ Tcl_SetObjResult(interp,
+ Tcl_NewStringObj(TclGetCommandTypeName(command), -1));
+ }
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
* Tcl_JoinObjCmd --
*
* This procedure is invoked to process the "join" Tcl command. See the
@@ -2155,8 +2200,8 @@ Tcl_JoinObjCmd(
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* The argument objects. */
{
- int listLen, i;
- Tcl_Obj *resObjPtr, *joinObjPtr, **elemPtrs;
+ int length, listLen;
+ Tcl_Obj *resObjPtr = NULL, *joinObjPtr, **elemPtrs;
if ((objc < 2) || (objc > 3)) {
Tcl_WrongNumArgs(interp, 1, objv, "list ?joinString?");
@@ -2173,27 +2218,47 @@ Tcl_JoinObjCmd(
return TCL_ERROR;
}
+ if (listLen == 0) {
+ /* No elements to join; default empty result is correct. */
+ return TCL_OK;
+ }
+ if (listLen == 1) {
+ /* One element; return it */
+ Tcl_SetObjResult(interp, elemPtrs[0]);
+ return TCL_OK;
+ }
+
joinObjPtr = (objc == 2) ? Tcl_NewStringObj(" ", 1) : objv[2];
Tcl_IncrRefCount(joinObjPtr);
- resObjPtr = Tcl_NewObj();
- for (i = 0; i < listLen; i++) {
- if (i > 0) {
+ (void) Tcl_GetStringFromObj(joinObjPtr, &length);
+ if (length == 0) {
+ resObjPtr = TclStringCat(interp, listLen, elemPtrs, 0);
+ } else {
+ int i;
- /*
- * NOTE: This code is relying on Tcl_AppendObjToObj() **NOT**
- * to shimmer joinObjPtr. If it did, then the case where
- * objv[1] and objv[2] are the same value would not be safe.
- * Accessing elemPtrs would crash.
- */
+ resObjPtr = Tcl_NewObj();
+ for (i = 0; i < listLen; i++) {
+ if (i > 0) {
+
+ /*
+ * NOTE: This code is relying on Tcl_AppendObjToObj() **NOT**
+ * to shimmer joinObjPtr. If it did, then the case where
+ * objv[1] and objv[2] are the same value would not be safe.
+ * Accessing elemPtrs would crash.
+ */
- Tcl_AppendObjToObj(resObjPtr, joinObjPtr);
+ Tcl_AppendObjToObj(resObjPtr, joinObjPtr);
+ }
+ Tcl_AppendObjToObj(resObjPtr, elemPtrs[i]);
}
- Tcl_AppendObjToObj(resObjPtr, elemPtrs[i]);
}
Tcl_DecrRefCount(joinObjPtr);
- Tcl_SetObjResult(interp, resObjPtr);
- return TCL_OK;
+ if (resObjPtr) {
+ Tcl_SetObjResult(interp, resObjPtr);
+ return TCL_OK;
+ }
+ return TCL_ERROR;
}
/*
@@ -2518,7 +2583,6 @@ Tcl_LrangeObjCmd(
register Tcl_Obj *const objv[])
/* Argument objects. */
{
- Tcl_Obj **elemPtrs;
int listLen, first, last, result;
if (objc != 4) {
@@ -2536,55 +2600,14 @@ Tcl_LrangeObjCmd(
if (result != TCL_OK) {
return result;
}
- if (first < 0) {
- first = 0;
- }
result = TclGetIntForIndexM(interp, objv[3], /*endValue*/ listLen - 1,
&last);
if (result != TCL_OK) {
return result;
}
- if (last >= listLen) {
- last = listLen - 1;
- }
-
- if (first > last) {
- /*
- * Returning an empty list is easy.
- */
-
- return TCL_OK;
- }
-
- result = TclListObjGetElements(interp, objv[1], &listLen, &elemPtrs);
- if (result != TCL_OK) {
- return result;
- }
-
- if (Tcl_IsShared(objv[1]) ||
- ((ListRepPtr(objv[1])->refCount > 1))) {
- Tcl_SetObjResult(interp, Tcl_NewListObj(last - first + 1,
- &elemPtrs[first]));
- } else {
- /*
- * In-place is possible.
- */
-
- if (last < (listLen - 1)) {
- Tcl_ListObjReplace(interp, objv[1], last + 1, listLen - 1 - last,
- 0, NULL);
- }
-
- /*
- * This one is not conditioned on (first > 0) in order to preserve the
- * string-canonizing effect of [lrange 0 end].
- */
-
- Tcl_ListObjReplace(interp, objv[1], 0, first, 0, NULL);
- Tcl_SetObjResult(interp, objv[1]);
- }
+ Tcl_SetObjResult(interp, TclListObjRange(objv[1], first, last));
return TCL_OK;
}
@@ -2754,21 +2777,10 @@ Tcl_LreplaceObjCmd(
if (first < 0) {
first = 0;
}
-
- /*
- * Complain if the user asked for a start element that is greater than the
- * list length. This won't ever trigger for the "end-*" case as that will
- * be properly constrained by TclGetIntForIndex because we use listLen-1
- * (to allow for replacing the last elem).
- */
-
- 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",
- NULL);
- return TCL_ERROR;
+ if (first > listLen) {
+ first = listLen;
}
+
if (last >= listLen) {
last = listLen - 1;
}
@@ -2913,20 +2925,21 @@ Tcl_LsearchObjCmd(
Tcl_Obj *const objv[]) /* Argument values. */
{
const char *bytes, *patternBytes;
- int i, match, index, result, listc, length, elemLen, bisect;
- int dataType, isIncreasing, lower, upper, offset;
+ 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;
int allMatches, inlineReturn, negatedMatch, returnSubindices, noCase;
double patDouble, objDouble;
SortInfo sortInfo;
Tcl_Obj *patObj, **listv, *listPtr, *startPtr, *itemPtr;
- SortStrCmpFn_t strCmpFn = strcmp;
+ SortStrCmpFn_t strCmpFn = TclUtfCmp;
Tcl_RegExp regexp = NULL;
static const char *const options[] = {
"-all", "-ascii", "-bisect", "-decreasing", "-dictionary",
"-exact", "-glob", "-increasing", "-index",
"-inline", "-integer", "-nocase", "-not",
- "-real", "-regexp", "-sorted", "-start",
+ "-real", "-regexp", "-sorted", "-start", "-stride",
"-subindices", NULL
};
enum options {
@@ -2934,7 +2947,7 @@ Tcl_LsearchObjCmd(
LSEARCH_DICTIONARY, LSEARCH_EXACT, LSEARCH_GLOB, LSEARCH_INCREASING,
LSEARCH_INDEX, LSEARCH_INLINE, LSEARCH_INTEGER, LSEARCH_NOCASE,
LSEARCH_NOT, LSEARCH_REAL, LSEARCH_REGEXP, LSEARCH_SORTED,
- LSEARCH_START, LSEARCH_SUBINDICES
+ LSEARCH_START, LSEARCH_STRIDE, LSEARCH_SUBINDICES
};
enum datatypes {
ASCII, DICTIONARY, INTEGER, REAL
@@ -2954,7 +2967,9 @@ Tcl_LsearchObjCmd(
bisect = 0;
listPtr = NULL;
startPtr = NULL;
- offset = 0;
+ groupSize = 1;
+ groupOffset = 0;
+ start = 0;
noCase = 0;
sortInfo.compareCmdPtr = NULL;
sortInfo.isIncreasing = 1;
@@ -2972,9 +2987,6 @@ Tcl_LsearchObjCmd(
for (i = 1; i < objc-2; i++) {
if (Tcl_GetIndexFromObj(interp, objv[i], options, "option", 0, &index)
!= TCL_OK) {
- if (startPtr != NULL) {
- Tcl_DecrRefCount(startPtr);
- }
result = TCL_ERROR;
goto done;
}
@@ -3039,6 +3051,7 @@ Tcl_LsearchObjCmd(
if (startPtr != NULL) {
Tcl_DecrRefCount(startPtr);
+ startPtr = NULL;
}
if (i > objc-4) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
@@ -3059,25 +3072,47 @@ Tcl_LsearchObjCmd(
startPtr = Tcl_DuplicateObj(objv[i]);
} else {
startPtr = objv[i];
- Tcl_IncrRefCount(startPtr);
}
+ Tcl_IncrRefCount(startPtr);
+ break;
+ case LSEARCH_STRIDE: /* -stride */
+ if (i > objc-4) {
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "\"-stride\" option must be "
+ "followed by stride length", -1));
+ Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "MISSING", NULL);
+ result = TCL_ERROR;
+ goto done;
+ }
+ if (Tcl_GetIntFromObj(interp, objv[i+1], &groupSize) != TCL_OK) {
+ result = TCL_ERROR;
+ goto done;
+ }
+ if (groupSize < 1) {
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "stride length must be at least 1", -1));
+ Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LSORT",
+ "BADSTRIDE", NULL);
+ result = TCL_ERROR;
+ goto done;
+ }
+ i++;
break;
case LSEARCH_INDEX: { /* -index */
Tcl_Obj **indices;
int j;
- if (sortInfo.indexc > 1) {
+ if (allocatedIndexVector) {
TclStackFree(interp, sortInfo.indexv);
+ allocatedIndexVector = 0;
}
if (i > objc-4) {
- if (startPtr != NULL) {
- Tcl_DecrRefCount(startPtr);
- }
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"\"-index\" option must be followed by list index",
-1));
Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "MISSING", NULL);
- return TCL_ERROR;
+ result = TCL_ERROR;
+ goto done;
}
/*
@@ -3089,10 +3124,8 @@ Tcl_LsearchObjCmd(
i++;
if (TclListObjGetElements(interp, objv[i],
&sortInfo.indexc, &indices) != TCL_OK) {
- if (startPtr != NULL) {
- Tcl_DecrRefCount(startPtr);
- }
- return TCL_ERROR;
+ result = TCL_ERROR;
+ goto done;
}
switch (sortInfo.indexc) {
case 0:
@@ -3104,6 +3137,8 @@ Tcl_LsearchObjCmd(
default:
sortInfo.indexv =
TclStackAlloc(interp, sizeof(int) * sortInfo.indexc);
+ allocatedIndexVector = 1; /* Cannot use indexc field, as it
+ * might be decreased by 1 later. */
}
/*
@@ -3113,13 +3148,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;
}
@@ -3131,14 +3179,12 @@ Tcl_LsearchObjCmd(
*/
if (returnSubindices && sortInfo.indexc==0) {
- if (startPtr != NULL) {
- Tcl_DecrRefCount(startPtr);
- }
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"-subindices cannot be used without -index option", -1));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LSEARCH",
"BAD_OPTION_MIX", NULL);
- return TCL_ERROR;
+ result = TCL_ERROR;
+ goto done;
}
if (bisect && (allMatches || negatedMatch)) {
@@ -3146,7 +3192,8 @@ Tcl_LsearchObjCmd(
"-bisect is not compatible with -all or -not", -1));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LSEARCH",
"BAD_OPTION_MIX", NULL);
- return TCL_ERROR;
+ result = TCL_ERROR;
+ goto done;
}
if (mode == REGEXP) {
@@ -3172,9 +3219,6 @@ Tcl_LsearchObjCmd(
}
if (regexp == NULL) {
- if (startPtr != NULL) {
- Tcl_DecrRefCount(startPtr);
- }
result = TCL_ERROR;
goto done;
}
@@ -3187,24 +3231,64 @@ Tcl_LsearchObjCmd(
result = TclListObjGetElements(interp, objv[objc - 2], &listc, &listv);
if (result != TCL_OK) {
- if (startPtr != NULL) {
- Tcl_DecrRefCount(startPtr);
- }
goto done;
}
/*
+ * Check for sanity when grouping elements of the overall list together
+ * because of the -stride option. [TIP #351]
+ */
+
+ if (groupSize > 1) {
+ if (listc % groupSize) {
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "list size must be a multiple of the stride length",
+ -1));
+ Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LSEARCH", "BADSTRIDE",
+ NULL);
+ result = TCL_ERROR;
+ goto done;
+ }
+ if (sortInfo.indexc > 0) {
+ /*
+ * Use the first value in the list supplied to -index as the
+ * offset of the element within each group by which to sort.
+ */
+
+ groupOffset = TclIndexDecode(sortInfo.indexv[0], groupSize - 1);
+ if (groupOffset < 0 || groupOffset >= groupSize) {
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "when used with \"-stride\", the leading \"-index\""
+ " value must be within the group", -1));
+ Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LSEARCH",
+ "BADINDEX", NULL);
+ result = TCL_ERROR;
+ goto done;
+ }
+ if (sortInfo.indexc == 1) {
+ sortInfo.indexc = 0;
+ sortInfo.indexv = NULL;
+ } else {
+ sortInfo.indexc--;
+
+ for (i = 0; i < sortInfo.indexc; i++) {
+ sortInfo.indexv[i] = sortInfo.indexv[i+1];
+ }
+ }
+ }
+ }
+
+ /*
* Get the user-specified start offset.
*/
if (startPtr) {
- result = TclGetIntForIndexM(interp, startPtr, listc-1, &offset);
- Tcl_DecrRefCount(startPtr);
+ result = TclGetIntForIndexM(interp, startPtr, listc-1, &start);
if (result != TCL_OK) {
goto done;
}
- if (offset < 0) {
- offset = 0;
+ if (start < 0) {
+ start = 0;
}
/*
@@ -3212,16 +3296,21 @@ Tcl_LsearchObjCmd(
* "did not match anything at all" result straight away. [Bug 1374778]
*/
- if (offset > listc-1) {
- if (sortInfo.indexc > 1) {
- TclStackFree(interp, sortInfo.indexv);
- }
+ if (start > listc-1) {
if (allMatches || inlineReturn) {
Tcl_ResetResult(interp);
} else {
Tcl_SetObjResult(interp, Tcl_NewIntObj(-1));
}
- return TCL_OK;
+ goto done;
+ }
+
+ /*
+ * If start points within a group, it points to the start of the group.
+ */
+
+ if (groupSize > 1) {
+ start -= (start % groupSize);
}
}
@@ -3280,18 +3369,23 @@ Tcl_LsearchObjCmd(
* sense in doing this when the match sense is inverted.
*/
- lower = offset - 1;
+ /*
+ * With -stride, lower, upper and i are kept as multiples of groupSize.
+ */
+
+ lower = start - groupSize;
upper = listc;
- while (lower + 1 != upper && sortInfo.resultCode == TCL_OK) {
+ while (lower + groupSize != upper && sortInfo.resultCode == TCL_OK) {
i = (lower + upper)/2;
+ i -= i % groupSize;
if (sortInfo.indexc != 0) {
- itemPtr = SelectObjFromSublist(listv[i], &sortInfo);
+ itemPtr = SelectObjFromSublist(listv[i+groupOffset], &sortInfo);
if (sortInfo.resultCode != TCL_OK) {
result = sortInfo.resultCode;
goto done;
}
} else {
- itemPtr = listv[i];
+ itemPtr = listv[i+groupOffset];
}
switch ((enum datatypes) dataType) {
case ASCII:
@@ -3380,10 +3474,10 @@ Tcl_LsearchObjCmd(
if (allMatches) {
listPtr = Tcl_NewListObj(0, NULL);
}
- for (i = offset; i < listc; i++) {
+ for (i = start; i < listc; i += groupSize) {
match = 0;
if (sortInfo.indexc != 0) {
- itemPtr = SelectObjFromSublist(listv[i], &sortInfo);
+ itemPtr = SelectObjFromSublist(listv[i+groupOffset], &sortInfo);
if (sortInfo.resultCode != TCL_OK) {
if (listPtr != NULL) {
Tcl_DecrRefCount(listPtr);
@@ -3392,7 +3486,7 @@ Tcl_LsearchObjCmd(
goto done;
}
} else {
- itemPtr = listv[i];
+ itemPtr = listv[i+groupOffset];
}
switch (mode) {
@@ -3482,18 +3576,23 @@ Tcl_LsearchObjCmd(
*/
if (returnSubindices && (sortInfo.indexc != 0)) {
- itemPtr = SelectObjFromSublist(listv[i], &sortInfo);
+ itemPtr = SelectObjFromSublist(listv[i+groupOffset],
+ &sortInfo);
+ Tcl_ListObjAppendElement(interp, listPtr, itemPtr);
+ } else if (groupSize > 1) {
+ Tcl_ListObjReplace(interp, listPtr, LIST_MAX, 0,
+ groupSize, &listv[i]);
} else {
itemPtr = listv[i];
+ Tcl_ListObjAppendElement(interp, listPtr, itemPtr);
}
- Tcl_ListObjAppendElement(interp, listPtr, itemPtr);
} else if (returnSubindices) {
int j;
- itemPtr = Tcl_NewIntObj(i);
+ 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 {
@@ -3512,10 +3611,10 @@ Tcl_LsearchObjCmd(
if (returnSubindices) {
int j;
- itemPtr = Tcl_NewIntObj(index);
+ 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 {
@@ -3529,7 +3628,14 @@ Tcl_LsearchObjCmd(
Tcl_SetObjResult(interp, Tcl_NewObj());
} else {
- Tcl_SetObjResult(interp, listv[index]);
+ if (returnSubindices) {
+ Tcl_SetObjResult(interp, SelectObjFromSublist(listv[i+groupOffset],
+ &sortInfo));
+ } else if (groupSize > 1) {
+ Tcl_SetObjResult(interp, Tcl_NewListObj(groupSize, &listv[index]));
+ } else {
+ Tcl_SetObjResult(interp, listv[index]);
+ }
}
result = TCL_OK;
@@ -3538,7 +3644,10 @@ Tcl_LsearchObjCmd(
*/
done:
- if (sortInfo.indexc > 1) {
+ if (startPtr != NULL) {
+ Tcl_DecrRefCount(startPtr);
+ }
+ if (allocatedIndexVector) {
TclStackFree(interp, sortInfo.indexv);
}
return result;
@@ -3732,7 +3841,7 @@ Tcl_LsortObjCmd(
sortInfo.isIncreasing = 1;
break;
case LSORT_INDEX: {
- int indexc, dummy;
+ int indexc;
Tcl_Obj **indexv;
if (i == objc-2) {
@@ -3758,8 +3867,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;
@@ -3839,8 +3960,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]);
}
}
@@ -3911,10 +4032,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\""
@@ -3933,6 +4051,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++) {
@@ -4238,7 +4359,7 @@ SortCompare(
int order = 0;
if (infoPtr->sortMode == SORTMODE_ASCII) {
- order = strcmp(elemPtr1->collationKey.strValuePtr,
+ order = TclUtfCmp(elemPtr1->collationKey.strValuePtr,
elemPtr2->collationKey.strValuePtr);
} else if (infoPtr->sortMode == SORTMODE_ASCII_NC) {
order = TclUtfCasecmp(elemPtr1->collationKey.strValuePtr,
@@ -4501,15 +4622,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) {
generated by cgit v0.12 at 2024-11-17 09:19:46 (GMT)