summaryrefslogtreecommitdiffstats
path: root/generic/tclCmdIL.c
diff options
context:
space:
mode:
Diffstat (limited to 'generic/tclCmdIL.c')
-rw-r--r--generic/tclCmdIL.c1241
1 files changed, 764 insertions, 477 deletions
diff --git a/generic/tclCmdIL.c b/generic/tclCmdIL.c
index ea9c1e4..41c1eb6 100644
--- a/generic/tclCmdIL.c
+++ b/generic/tclCmdIL.c
@@ -3,7 +3,7 @@
*
* This file contains the top-level command routines for most of the Tcl
* built-in commands whose names begin with the letters I through L. It
- * contains only commands in the generic core (i.e. those that don't
+ * contains only commands in the generic core (i.e., those that don't
* depend much upon UNIX facilities).
*
* Copyright (c) 1987-1993 The Regents of the University of California.
@@ -27,13 +27,16 @@
*/
typedef struct SortElement {
- union {
- char *strValuePtr;
- long intValue;
+ union { /* The value that we sorting by. */
+ const char *strValuePtr;
+ long intValue;
double doubleValue;
Tcl_Obj *objValuePtr;
- } index;
- Tcl_Obj *objPtr; /* Object being sorted, or its index. */
+ } collationKey;
+ union { /* Object being sorted, or its index. */
+ Tcl_Obj *objPtr;
+ int index;
+ } payload;
struct SortElement *nextPtr;/* Next element in the list, or NULL for end
* of list. */
} SortElement;
@@ -101,7 +104,9 @@ typedef struct SortInfo {
* Forward declarations for procedures defined in this file:
*/
-static int DictionaryCompare(char *left, char *right);
+static int DictionaryCompare(const char *left, const char *right);
+static int IfConditionCallback(ClientData data[],
+ Tcl_Interp *interp, int result);
static int InfoArgsCmd(ClientData dummy, Tcl_Interp *interp,
int objc, Tcl_Obj *const objv[]);
static int InfoBodyCmd(ClientData dummy, Tcl_Interp *interp,
@@ -114,6 +119,9 @@ static int InfoCompleteCmd(ClientData dummy, Tcl_Interp *interp,
int objc, Tcl_Obj *const objv[]);
static int InfoDefaultCmd(ClientData dummy, Tcl_Interp *interp,
int objc, Tcl_Obj *const objv[]);
+/* TIP #348 - New 'info' subcommand 'errorstack' */
+static int InfoErrorStackCmd(ClientData dummy, Tcl_Interp *interp,
+ int objc, Tcl_Obj *const objv[]);
/* TIP #280 - New 'info' subcommand 'frame' */
static int InfoFrameCmd(ClientData dummy, Tcl_Interp *interp,
int objc, Tcl_Obj *const objv[]);
@@ -140,7 +148,7 @@ static int InfoSharedlibCmd(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,
+static SortElement * MergeLists(SortElement *leftPtr, SortElement *rightPtr,
SortInfo *infoPtr);
static int SortCompare(SortElement *firstPtr, SortElement *second,
SortInfo *infoPtr);
@@ -153,29 +161,31 @@ static Tcl_Obj * SelectObjFromSublist(Tcl_Obj *firstPtr,
*/
static const EnsembleImplMap defaultInfoMap[] = {
- {"args", InfoArgsCmd, NULL},
- {"body", InfoBodyCmd, NULL},
- {"cmdcount", InfoCmdCountCmd, NULL},
- {"commands", InfoCommandsCmd, NULL},
- {"complete", InfoCompleteCmd, NULL},
- {"default", InfoDefaultCmd, NULL},
- {"exists", TclInfoExistsCmd, TclCompileInfoExistsCmd},
- {"frame", InfoFrameCmd, NULL},
- {"functions", InfoFunctionsCmd, NULL},
- {"globals", TclInfoGlobalsCmd, NULL},
- {"hostname", InfoHostnameCmd, NULL},
- {"level", InfoLevelCmd, NULL},
- {"library", InfoLibraryCmd, NULL},
- {"loaded", InfoLoadedCmd, NULL},
- {"locals", TclInfoLocalsCmd, NULL},
- {"nameofexecutable", InfoNameOfExecutableCmd, NULL},
- {"patchlevel", InfoPatchLevelCmd, NULL},
- {"procs", InfoProcsCmd, NULL},
- {"script", InfoScriptCmd, NULL},
- {"sharedlibextension", InfoSharedlibCmd, NULL},
- {"tclversion", InfoTclVersionCmd, NULL},
- {"vars", TclInfoVarsCmd, NULL},
- {NULL, NULL, NULL}
+ {"args", InfoArgsCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0},
+ {"body", InfoBodyCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0},
+ {"cmdcount", InfoCmdCountCmd, TclCompileBasic0ArgCmd, NULL, NULL, 0},
+ {"commands", InfoCommandsCmd, TclCompileInfoCommandsCmd, NULL, NULL, 0},
+ {"complete", InfoCompleteCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0},
+ {"coroutine", TclInfoCoroutineCmd, TclCompileInfoCoroutineCmd, NULL, NULL, 0},
+ {"default", InfoDefaultCmd, TclCompileBasic3ArgCmd, NULL, NULL, 0},
+ {"errorstack", InfoErrorStackCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 0},
+ {"exists", TclInfoExistsCmd, TclCompileInfoExistsCmd, NULL, NULL, 0},
+ {"frame", InfoFrameCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 0},
+ {"functions", InfoFunctionsCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 0},
+ {"globals", TclInfoGlobalsCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 0},
+ {"hostname", InfoHostnameCmd, TclCompileBasic0ArgCmd, NULL, NULL, 0},
+ {"level", InfoLevelCmd, TclCompileInfoLevelCmd, NULL, NULL, 0},
+ {"library", InfoLibraryCmd, TclCompileBasic0ArgCmd, NULL, NULL, 0},
+ {"loaded", InfoLoadedCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 0},
+ {"locals", TclInfoLocalsCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 0},
+ {"nameofexecutable", InfoNameOfExecutableCmd, TclCompileBasic0ArgCmd, NULL, NULL, 0},
+ {"patchlevel", InfoPatchLevelCmd, TclCompileBasic0ArgCmd, NULL, NULL, 0},
+ {"procs", InfoProcsCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 0},
+ {"script", InfoScriptCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 0},
+ {"sharedlibextension", InfoSharedlibCmd, TclCompileBasic0ArgCmd, NULL, NULL, 0},
+ {"tclversion", InfoTclVersionCmd, TclCompileBasic0ArgCmd, NULL, NULL, 0},
+ {"vars", TclInfoVarsCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 0},
+ {NULL, NULL, NULL, NULL, NULL, 0}
};
/*
@@ -206,40 +216,66 @@ Tcl_IfObjCmd(
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
- int thenScriptIndex = 0; /* "then" script to be evaled after syntax
- * check. */
+ return Tcl_NRCallObjProc(interp, TclNRIfObjCmd, dummy, objc, objv);
+}
+
+int
+TclNRIfObjCmd(
+ ClientData dummy, /* Not used. */
+ Tcl_Interp *interp, /* Current interpreter. */
+ int objc, /* Number of arguments. */
+ Tcl_Obj *const objv[]) /* Argument objects. */
+{
+ Tcl_Obj *boolObj;
+
+ if (objc <= 1) {
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "wrong # args: no expression after \"%s\" argument",
+ TclGetString(objv[0])));
+ Tcl_SetErrorCode(interp, "TCL", "WRONGARGS", NULL);
+ return TCL_ERROR;
+ }
+
+ /*
+ * At this point, objv[1] refers to the main expression to test. The
+ * arguments after the expression must be "then" (optional) and a script
+ * to execute if the expression is true.
+ */
+
+ TclNewObj(boolObj);
+ Tcl_NRAddCallback(interp, IfConditionCallback, INT2PTR(objc),
+ (ClientData) objv, INT2PTR(1), boolObj);
+ return Tcl_NRExprObj(interp, objv[1], boolObj);
+}
+
+static int
+IfConditionCallback(
+ ClientData data[],
+ Tcl_Interp *interp,
+ int result)
+{
Interp *iPtr = (Interp *) interp;
- int i, result, value;
- char *clause;
+ int objc = PTR2INT(data[0]);
+ Tcl_Obj *const *objv = data[1];
+ int i = PTR2INT(data[2]);
+ Tcl_Obj *boolObj = data[3];
+ int value, thenScriptIndex = 0;
+ const char *clause;
- i = 1;
- while (1) {
- /*
- * At this point in the loop, objv and objc refer to an expression to
- * test, either for the main expression or an expression following an
- * "elseif". The arguments after the expression must be "then"
- * (optional) and a script to execute if the expression is true.
- */
+ if (result != TCL_OK) {
+ TclDecrRefCount(boolObj);
+ return result;
+ }
+ if (Tcl_GetBooleanFromObj(interp, boolObj, &value) != TCL_OK) {
+ TclDecrRefCount(boolObj);
+ return TCL_ERROR;
+ }
+ TclDecrRefCount(boolObj);
- if (i >= objc) {
- clause = TclGetString(objv[i-1]);
- Tcl_AppendResult(interp, "wrong # args: ",
- "no expression after \"", clause, "\" argument", NULL);
- return TCL_ERROR;
- }
- if (!thenScriptIndex) {
- result = Tcl_ExprBooleanObj(interp, objv[i], &value);
- if (result != TCL_OK) {
- return result;
- }
- }
+ while (1) {
i++;
if (i >= objc) {
- missingScript:
- clause = TclGetString(objv[i-1]);
- Tcl_AppendResult(interp, "wrong # args: ",
- "no script following \"", clause, "\" argument", NULL);
- return TCL_ERROR;
+ goto missingScript;
}
clause = TclGetString(objv[i]);
if ((i < objc) && (strcmp(clause, "then") == 0)) {
@@ -265,17 +301,37 @@ Tcl_IfObjCmd(
* TIP #280. Make invoking context available to branch.
*/
- return TclEvalObjEx(interp, objv[thenScriptIndex], 0,
+ return TclNREvalObjEx(interp, objv[thenScriptIndex], 0,
iPtr->cmdFramePtr, thenScriptIndex);
}
return TCL_OK;
}
clause = TclGetString(objv[i]);
- if ((clause[0] == 'e') && (strcmp(clause, "elseif") == 0)) {
- i++;
- continue;
+ if ((clause[0] != 'e') || (strcmp(clause, "elseif") != 0)) {
+ break;
+ }
+ i++;
+
+ /*
+ * At this point in the loop, objv and objc refer to an expression to
+ * test, either for the main expression or an expression following an
+ * "elseif". The arguments after the expression must be "then"
+ * (optional) and a script to execute if the expression is true.
+ */
+
+ if (i >= objc) {
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "wrong # args: no expression after \"%s\" argument",
+ clause));
+ Tcl_SetErrorCode(interp, "TCL", "WRONGARGS", NULL);
+ return TCL_ERROR;
+ }
+ if (!thenScriptIndex) {
+ TclNewObj(boolObj);
+ Tcl_NRAddCallback(interp, IfConditionCallback, data[0], data[1],
+ INT2PTR(i), boolObj);
+ return Tcl_NRExprObj(interp, objv[i], boolObj);
}
- break;
}
/*
@@ -287,14 +343,14 @@ Tcl_IfObjCmd(
if (strcmp(clause, "else") == 0) {
i++;
if (i >= objc) {
- Tcl_AppendResult(interp, "wrong # args: ",
- "no script following \"else\" argument", NULL);
- return TCL_ERROR;
+ goto missingScript;
}
}
if (i < objc - 1) {
- Tcl_AppendResult(interp, "wrong # args: ",
- "extra words after \"else\" clause in \"if\" command", NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "wrong # args: extra words after \"else\" clause in \"if\" command",
+ -1));
+ Tcl_SetErrorCode(interp, "TCL", "WRONGARGS", NULL);
return TCL_ERROR;
}
if (thenScriptIndex) {
@@ -302,10 +358,17 @@ Tcl_IfObjCmd(
* TIP #280. Make invoking context available to branch/else.
*/
- return TclEvalObjEx(interp, objv[thenScriptIndex], 0,
+ return TclNREvalObjEx(interp, objv[thenScriptIndex], 0,
iPtr->cmdFramePtr, thenScriptIndex);
}
- return TclEvalObjEx(interp, objv[i], 0, iPtr->cmdFramePtr, i);
+ return TclNREvalObjEx(interp, objv[i], 0, iPtr->cmdFramePtr, i);
+
+ missingScript:
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "wrong # args: no script following \"%s\" argument",
+ TclGetString(objv[i-1])));
+ Tcl_SetErrorCode(interp, "TCL", "WRONGARGS", NULL);
+ return TCL_ERROR;
}
/*
@@ -375,7 +438,7 @@ Tcl_IncrObjCmd(
* documentation for details on what it does.
*
* Results:
- * FIXME
+ * Handle for the info command, or NULL on failure.
*
* Side effects:
* none
@@ -418,7 +481,7 @@ InfoArgsCmd(
Tcl_Obj *const objv[]) /* Argument objects. */
{
register Interp *iPtr = (Interp *) interp;
- char *name;
+ const char *name;
Proc *procPtr;
CompiledLocal *localPtr;
Tcl_Obj *listObjPtr;
@@ -431,7 +494,9 @@ InfoArgsCmd(
name = TclGetString(objv[1]);
procPtr = TclFindProc(iPtr, name);
if (procPtr == NULL) {
- Tcl_AppendResult(interp, "\"", name, "\" isn't a procedure", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "\"%s\" isn't a procedure", name));
+ Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "PROCEDURE", name, NULL);
return TCL_ERROR;
}
@@ -479,7 +544,7 @@ InfoBodyCmd(
Tcl_Obj *const objv[]) /* Argument objects. */
{
register Interp *iPtr = (Interp *) interp;
- char *name;
+ const char *name;
Proc *procPtr;
Tcl_Obj *bodyPtr, *resultPtr;
@@ -491,7 +556,9 @@ InfoBodyCmd(
name = TclGetString(objv[1]);
procPtr = TclFindProc(iPtr, name);
if (procPtr == NULL) {
- Tcl_AppendResult(interp, "\"", name, "\" isn't a procedure", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "\"%s\" isn't a procedure", name));
+ Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "PROCEDURE", name, NULL);
return TCL_ERROR;
}
@@ -511,7 +578,7 @@ InfoBodyCmd(
* run before. [Bug #545644]
*/
- (void) TclGetString(bodyPtr);
+ TclGetString(bodyPtr);
}
resultPtr = Tcl_NewStringObj(bodyPtr->bytes, bodyPtr->length);
@@ -589,7 +656,7 @@ InfoCommandsCmd(
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
- char *cmdName, *pattern;
+ const char *cmdName, *pattern;
const char *simplePattern;
register Tcl_HashEntry *entryPtr;
Tcl_HashSearch search;
@@ -622,8 +689,8 @@ InfoCommandsCmd(
Namespace *dummy1NsPtr, *dummy2NsPtr;
pattern = TclGetString(objv[1]);
- TclGetNamespaceForQualName(interp, pattern, (Namespace *) NULL, 0,
- &nsPtr, &dummy1NsPtr, &dummy2NsPtr, &simplePattern);
+ TclGetNamespaceForQualName(interp, pattern, NULL, 0, &nsPtr,
+ &dummy1NsPtr, &dummy2NsPtr, &simplePattern);
if (nsPtr != NULL) { /* We successfully found the pattern's ns. */
specificNsInPattern = (strcmp(simplePattern, pattern) != 0);
@@ -659,7 +726,7 @@ InfoCommandsCmd(
entryPtr = Tcl_FindHashEntry(&nsPtr->cmdTable, simplePattern);
if (entryPtr != NULL) {
if (specificNsInPattern) {
- cmd = (Tcl_Command) Tcl_GetHashValue(entryPtr);
+ cmd = Tcl_GetHashValue(entryPtr);
elemObjPtr = Tcl_NewObj();
Tcl_GetCommandFullName(interp, cmd, elemObjPtr);
} else {
@@ -710,7 +777,7 @@ InfoCommandsCmd(
if ((simplePattern == NULL)
|| Tcl_StringMatch(cmdName, simplePattern)) {
if (specificNsInPattern) {
- cmd = (Tcl_Command) Tcl_GetHashValue(entryPtr);
+ cmd = Tcl_GetHashValue(entryPtr);
elemObjPtr = Tcl_NewObj();
Tcl_GetCommandFullName(interp, cmd, elemObjPtr);
} else {
@@ -769,7 +836,7 @@ InfoCommandsCmd(
elemObjPtr = Tcl_NewStringObj(cmdName, -1);
Tcl_ListObjAppendElement(interp, listPtr, elemObjPtr);
(void) Tcl_CreateHashEntry(&addedCommandsTable,
- (char *)elemObjPtr, &isNew);
+ elemObjPtr, &isNew);
}
entryPtr = Tcl_NextHashEntry(&search);
}
@@ -794,7 +861,7 @@ InfoCommandsCmd(
|| Tcl_StringMatch(cmdName, simplePattern)) {
elemObjPtr = Tcl_NewStringObj(cmdName, -1);
(void) Tcl_CreateHashEntry(&addedCommandsTable,
- (char *) elemObjPtr, &isNew);
+ elemObjPtr, &isNew);
if (isNew) {
Tcl_ListObjAppendElement(interp, listPtr, elemObjPtr);
} else {
@@ -904,7 +971,7 @@ InfoDefaultCmd(
Tcl_Obj *const objv[]) /* Argument objects. */
{
Interp *iPtr = (Interp *) interp;
- char *procName, *argName, *varName;
+ const char *procName, *argName;
Proc *procPtr;
CompiledLocal *localPtr;
Tcl_Obj *valueObjPtr;
@@ -919,7 +986,10 @@ InfoDefaultCmd(
procPtr = TclFindProc(iPtr, procName);
if (procPtr == NULL) {
- Tcl_AppendResult(interp, "\"", procName, "\" isn't a procedure",NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "\"%s\" isn't a procedure", procName));
+ Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "PROCEDURE", procName,
+ NULL);
return TCL_ERROR;
}
@@ -929,17 +999,18 @@ InfoDefaultCmd(
&& (strcmp(argName, localPtr->name) == 0)) {
if (localPtr->defValuePtr != NULL) {
valueObjPtr = Tcl_ObjSetVar2(interp, objv[3], NULL,
- localPtr->defValuePtr, 0);
+ localPtr->defValuePtr, TCL_LEAVE_ERR_MSG);
if (valueObjPtr == NULL) {
- goto defStoreError;
+ return TCL_ERROR;
}
Tcl_SetObjResult(interp, Tcl_NewIntObj(1));
} else {
Tcl_Obj *nullObjPtr = Tcl_NewObj();
+
valueObjPtr = Tcl_ObjSetVar2(interp, objv[3], NULL,
- nullObjPtr, 0);
+ nullObjPtr, TCL_LEAVE_ERR_MSG);
if (valueObjPtr == NULL) {
- goto defStoreError;
+ return TCL_ERROR;
}
Tcl_SetObjResult(interp, Tcl_NewIntObj(0));
}
@@ -947,15 +1018,60 @@ InfoDefaultCmd(
}
}
- Tcl_AppendResult(interp, "procedure \"", procName,
- "\" doesn't have an argument \"", argName, "\"", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "procedure \"%s\" doesn't have an argument \"%s\"",
+ procName, argName));
+ Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ARGUMENT", argName, NULL);
return TCL_ERROR;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * InfoErrorStackCmd --
+ *
+ * Called to implement the "info errorstack" command that returns information
+ * about the last error's call stack. Handles the following syntax:
+ *
+ * info errorstack ?interp?
+ *
+ * Results:
+ * Returns TCL_OK if successful and TCL_ERROR if there is an error.
+ *
+ * Side effects:
+ * Returns a result in the interpreter's result object. If there is an
+ * error, the result is an error message.
+ *
+ *----------------------------------------------------------------------
+ */
- defStoreError:
- varName = TclGetString(objv[3]);
- Tcl_AppendResult(interp, "couldn't store default value in variable \"",
- varName, "\"", NULL);
- return TCL_ERROR;
+static int
+InfoErrorStackCmd(
+ ClientData dummy, /* Not used. */
+ Tcl_Interp *interp, /* Current interpreter. */
+ int objc, /* Number of arguments. */
+ Tcl_Obj *const objv[]) /* Argument objects. */
+{
+ Tcl_Interp *target;
+ Interp *iPtr;
+
+ if ((objc != 1) && (objc != 2)) {
+ Tcl_WrongNumArgs(interp, 1, objv, "?interp?");
+ return TCL_ERROR;
+ }
+
+ target = interp;
+ if (objc == 2) {
+ target = Tcl_GetSlave(interp, Tcl_GetString(objv[1]));
+ if (target == NULL) {
+ return TCL_ERROR;
+ }
+ }
+
+ iPtr = (Interp *) target;
+ Tcl_SetObjResult(interp, iPtr->errorStack);
+
+ return TCL_OK;
}
/*
@@ -985,7 +1101,7 @@ TclInfoExistsCmd(
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
- char *varName;
+ const char *varName;
Var *varPtr;
if (objc != 2) {
@@ -1031,22 +1147,47 @@ InfoFrameCmd(
Tcl_Obj *const objv[]) /* Argument objects. */
{
Interp *iPtr = (Interp *) interp;
- int level;
- CmdFrame *framePtr;
+ int level, code = TCL_OK;
+ CmdFrame *framePtr, **cmdFramePtrPtr = &iPtr->cmdFramePtr;
+ CoroutineData *corPtr = iPtr->execEnvPtr->corPtr;
+ int topLevel = 0;
+
+ if (objc > 2) {
+ Tcl_WrongNumArgs(interp, 1, objv, "?number?");
+ return TCL_ERROR;
+ }
+
+ while (corPtr) {
+ while (*cmdFramePtrPtr) {
+ topLevel++;
+ cmdFramePtrPtr = &((*cmdFramePtrPtr)->nextPtr);
+ }
+ if (corPtr->caller.cmdFramePtr) {
+ *cmdFramePtrPtr = corPtr->caller.cmdFramePtr;
+ }
+ corPtr = corPtr->callerEEPtr->corPtr;
+ }
+ topLevel += (*cmdFramePtrPtr)->level;
+
+ if (topLevel != iPtr->cmdFramePtr->level) {
+ framePtr = iPtr->cmdFramePtr;
+ while (framePtr) {
+ framePtr->level = topLevel--;
+ framePtr = framePtr->nextPtr;
+ }
+ if (topLevel) {
+ Tcl_Panic("Broken frame level calculation");
+ }
+ topLevel = iPtr->cmdFramePtr->level;
+ }
if (objc == 1) {
/*
* Just "info frame".
*/
- int levels =
- (iPtr->cmdFramePtr == NULL ? 0 : iPtr->cmdFramePtr->level);
-
- Tcl_SetObjResult(interp, Tcl_NewIntObj (levels));
- return TCL_OK;
- } else if (objc != 2) {
- Tcl_WrongNumArgs(interp, 1, objv, "?number?");
- return TCL_ERROR;
+ Tcl_SetObjResult(interp, Tcl_NewIntObj(topLevel));
+ goto done;
}
/*
@@ -1054,40 +1195,62 @@ InfoFrameCmd(
*/
if (TclGetIntFromObj(interp, objv[1], &level) != TCL_OK) {
- return TCL_ERROR;
+ code = TCL_ERROR;
+ goto done;
}
- if (level <= 0) {
- /*
- * Negative levels are adressing relative to the current frame's
- * depth.
- */
- if (iPtr->cmdFramePtr == NULL) {
- levelError:
- Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "bad level \"",
- TclGetString(objv[1]), "\"", NULL);
- return TCL_ERROR;
- }
+ if ((level > topLevel) || (level <= - topLevel)) {
+ levelError:
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "bad level \"%s\"", TclGetString(objv[1])));
+ Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "STACK_FRAME",
+ TclGetString(objv[1]), NULL);
+ code = TCL_ERROR;
+ goto done;
+ }
- /*
- * Convert to absolute.
- */
+ /*
+ * Let us convert to relative so that we know how many levels to go back
+ */
- level += iPtr->cmdFramePtr->level;
+ if (level > 0) {
+ level -= topLevel;
}
- for (framePtr = iPtr->cmdFramePtr; framePtr != NULL;
- framePtr = framePtr->nextPtr) {
- if (framePtr->level == level) {
- break;
+ framePtr = iPtr->cmdFramePtr;
+ while (++level <= 0) {
+ framePtr = framePtr->nextPtr;
+ if (!framePtr) {
+ goto levelError;
}
}
- if (framePtr == NULL) {
- goto levelError;
- }
Tcl_SetObjResult(interp, TclInfoFrame(interp, framePtr));
- return TCL_OK;
+
+ done:
+ cmdFramePtrPtr = &iPtr->cmdFramePtr;
+ corPtr = iPtr->execEnvPtr->corPtr;
+ while (corPtr) {
+ CmdFrame *endPtr = corPtr->caller.cmdFramePtr;
+
+ if (endPtr) {
+ if (*cmdFramePtrPtr == endPtr) {
+ *cmdFramePtrPtr = NULL;
+ } else {
+ CmdFrame *runPtr = *cmdFramePtrPtr;
+
+ while (runPtr->nextPtr != endPtr) {
+ runPtr->level -= endPtr->level;
+ runPtr = runPtr->nextPtr;
+ }
+ runPtr->level = 1;
+ runPtr->nextPtr = NULL;
+ }
+ cmdFramePtrPtr = &corPtr->caller.cmdFramePtr;
+ }
+ corPtr = corPtr->callerEEPtr->corPtr;
+ }
+ return code;
}
/*
@@ -1112,6 +1275,7 @@ TclInfoFrame(
CmdFrame *framePtr) /* Frame to get info for. */
{
Interp *iPtr = (Interp *) interp;
+ Tcl_Obj *tmpObj;
Tcl_Obj *lv[20]; /* Keep uptodate when more keys are added to
* the dict. */
int lc = 0;
@@ -1119,14 +1283,12 @@ TclInfoFrame(
* This array is indexed by the TCL_LOCATION_... values, except
* for _LAST.
*/
- static const char *typeString[TCL_LOCATION_LAST] = {
+ static const char *const typeString[TCL_LOCATION_LAST] = {
"eval", "eval", "eval", "precompiled", "source", "proc"
};
- Tcl_Obj *tmpObj;
- Proc *procPtr =
- framePtr->framePtr ? framePtr->framePtr->procPtr : NULL;
+ Proc *procPtr = framePtr->framePtr ? framePtr->framePtr->procPtr : NULL;
- /*
+ /*
* Pull the information and construct the dictionary to return, as list.
* Regarding use of the CmdFrame fields see tclInt.h, and its definition.
*/
@@ -1144,28 +1306,12 @@ TclInfoFrame(
*/
ADD_PAIR("type", Tcl_NewStringObj(typeString[framePtr->type], -1));
- ADD_PAIR("line", Tcl_NewIntObj(framePtr->line[0]));
- ADD_PAIR("cmd", Tcl_NewStringObj(framePtr->cmd.str.cmd,
- framePtr->cmd.str.len));
- break;
-
- case TCL_LOCATION_EVAL_LIST:
- /*
- * List optimized evaluation. Type, line, cmd, the latter through
- * listPtr, possibly a frame.
- */
-
- ADD_PAIR("type", Tcl_NewStringObj(typeString[framePtr->type], -1));
- ADD_PAIR("line", Tcl_NewIntObj(1));
-
- /*
- * We put a duplicate of the command list obj into the result to
- * ensure that the 'pure List'-property of the command itself is not
- * destroyed. Otherwise the query here would disable the list
- * optimization path in Tcl_EvalObjEx.
- */
-
- ADD_PAIR("cmd", Tcl_DuplicateObj(framePtr->cmd.listPtr));
+ if (framePtr->line) {
+ ADD_PAIR("line", Tcl_NewIntObj(framePtr->line[0]));
+ } else {
+ ADD_PAIR("line", Tcl_NewIntObj(1));
+ }
+ ADD_PAIR("cmd", TclGetSourceFromFrame(framePtr, 0, NULL));
break;
case TCL_LOCATION_PREBC:
@@ -1181,9 +1327,8 @@ TclInfoFrame(
* Execution of bytecode. Talk to the BC engine to fill out the frame.
*/
- CmdFrame *fPtr;
+ CmdFrame *fPtr = TclStackAlloc(interp, sizeof(CmdFrame));
- fPtr = (CmdFrame *) TclStackAlloc(interp, sizeof(CmdFrame));
*fPtr = *framePtr;
/*
@@ -1214,8 +1359,7 @@ TclInfoFrame(
Tcl_DecrRefCount(fPtr->data.eval.path);
}
- ADD_PAIR("cmd",
- Tcl_NewStringObj(fPtr->cmd.str.cmd, fPtr->cmd.str.len));
+ ADD_PAIR("cmd", TclGetSourceFromFrame(fPtr, 0, NULL));
TclStackFree(interp, fPtr);
break;
}
@@ -1234,8 +1378,7 @@ TclInfoFrame(
* the result list object.
*/
- ADD_PAIR("cmd", Tcl_NewStringObj(framePtr->cmd.str.cmd,
- framePtr->cmd.str.len));
+ ADD_PAIR("cmd", TclGetSourceFromFrame(framePtr, 0, NULL));
break;
case TCL_LOCATION_PROC:
@@ -1252,19 +1395,16 @@ TclInfoFrame(
Tcl_HashEntry *namePtr = procPtr->cmdPtr->hPtr;
if (namePtr) {
+ Tcl_Obj *procNameObj;
+
/*
* This is a regular command.
*/
- char *procName = Tcl_GetHashKey(namePtr->tablePtr, namePtr);
- char *nsName = procPtr->cmdPtr->nsPtr->fullName;
-
- ADD_PAIR("proc", Tcl_NewStringObj(nsName, -1));
-
- if (strcmp(nsName, "::") != 0) {
- Tcl_AppendToObj(lv[lc-1], "::", -1);
- }
- Tcl_AppendToObj(lv[lc-1], procName, -1);
+ TclNewObj(procNameObj);
+ Tcl_GetCommandFullName(interp, (Tcl_Command) procPtr->cmdPtr,
+ procNameObj);
+ ADD_PAIR("proc", procNameObj);
} else if (procPtr->cmdPtr->clientData) {
ExtraFrameInfo *efiPtr = procPtr->cmdPtr->clientData;
int i;
@@ -1415,7 +1555,10 @@ InfoHostnameCmd(
Tcl_SetObjResult(interp, Tcl_NewStringObj(name, -1));
return TCL_OK;
}
- Tcl_SetResult(interp, "unable to determine name of host", TCL_STATIC);
+
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "unable to determine name of host", -1));
+ Tcl_SetErrorCode(interp, "TCL", "OPERATION", "HOSTNAME", "UNKNOWN", NULL);
return TCL_ERROR;
}
@@ -1485,8 +1628,10 @@ InfoLevelCmd(
return TCL_ERROR;
levelError:
- Tcl_AppendResult(interp, "bad level \"", TclGetString(objv[1]), "\"",
- NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "bad level \"%s\"", TclGetString(objv[1])));
+ Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "STACK_LEVEL",
+ TclGetString(objv[1]), NULL);
return TCL_ERROR;
}
@@ -1530,7 +1675,10 @@ InfoLibraryCmd(
Tcl_SetObjResult(interp, Tcl_NewStringObj(libDirName, -1));
return TCL_OK;
}
- Tcl_SetResult(interp, "no library has been specified for Tcl",TCL_STATIC);
+
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "no library has been specified for Tcl", -1));
+ Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "VARIABLE", "tcl_library",NULL);
return TCL_ERROR;
}
@@ -1562,7 +1710,7 @@ InfoLoadedCmd(
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
- char *interpName;
+ const char *interpName;
if ((objc != 1) && (objc != 2)) {
Tcl_WrongNumArgs(interp, 1, objv, "?interp?");
@@ -1688,7 +1836,7 @@ InfoProcsCmd(
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
- char *cmdName, *pattern;
+ const char *cmdName, *pattern;
const char *simplePattern;
Namespace *nsPtr;
#ifdef INFO_PROCS_SEARCH_GLOBAL_NS
@@ -1722,9 +1870,8 @@ InfoProcsCmd(
Namespace *dummy1NsPtr, *dummy2NsPtr;
pattern = TclGetString(objv[1]);
- TclGetNamespaceForQualName(interp, pattern, (Namespace *) NULL,
- /*flags*/ 0, &nsPtr, &dummy1NsPtr, &dummy2NsPtr,
- &simplePattern);
+ TclGetNamespaceForQualName(interp, pattern, NULL, /*flags*/ 0, &nsPtr,
+ &dummy1NsPtr, &dummy2NsPtr, &simplePattern);
if (nsPtr != NULL) { /* We successfully found the pattern's ns. */
specificNsInPattern = (strcmp(simplePattern, pattern) != 0);
@@ -1750,7 +1897,7 @@ InfoProcsCmd(
if (simplePattern != NULL && TclMatchIsTrivial(simplePattern)) {
entryPtr = Tcl_FindHashEntry(&nsPtr->cmdTable, simplePattern);
if (entryPtr != NULL) {
- cmdPtr = (Command *) Tcl_GetHashValue(entryPtr);
+ cmdPtr = Tcl_GetHashValue(entryPtr);
if (!TclIsProc(cmdPtr)) {
realCmdPtr = (Command *)
@@ -1778,7 +1925,7 @@ InfoProcsCmd(
cmdName = Tcl_GetHashKey(&nsPtr->cmdTable, entryPtr);
if ((simplePattern == NULL)
|| Tcl_StringMatch(cmdName, simplePattern)) {
- cmdPtr = (Command *) Tcl_GetHashValue(entryPtr);
+ cmdPtr = Tcl_GetHashValue(entryPtr);
if (!TclIsProc(cmdPtr)) {
realCmdPtr = (Command *)
@@ -1825,7 +1972,7 @@ InfoProcsCmd(
if ((simplePattern == NULL)
|| Tcl_StringMatch(cmdName, simplePattern)) {
if (Tcl_FindHashEntry(&nsPtr->cmdTable,cmdName) == NULL) {
- cmdPtr = (Command *) Tcl_GetHashValue(entryPtr);
+ cmdPtr = Tcl_GetHashValue(entryPtr);
realCmdPtr = (Command *) TclGetOriginalCommand(
(Tcl_Command) cmdPtr);
@@ -2063,8 +2210,8 @@ Tcl_LassignObjCmd(
int listObjc; /* The length of the list. */
int code = TCL_OK;
- if (objc < 3) {
- Tcl_WrongNumArgs(interp, 1, objv, "list varName ?varName ...?");
+ if (objc < 2) {
+ Tcl_WrongNumArgs(interp, 1, objv, "list ?varName ...?");
return TCL_ERROR;
}
@@ -2078,20 +2225,22 @@ Tcl_LassignObjCmd(
objc -= 2;
objv += 2;
while (code == TCL_OK && objc > 0 && listObjc > 0) {
- if (NULL == Tcl_ObjSetVar2(interp, *objv++, NULL,
- *listObjv++, TCL_LEAVE_ERR_MSG)) {
+ if (Tcl_ObjSetVar2(interp, *objv++, NULL, *listObjv++,
+ TCL_LEAVE_ERR_MSG) == NULL) {
code = TCL_ERROR;
}
- objc--; listObjc--;
+ objc--;
+ listObjc--;
}
if (code == TCL_OK && objc > 0) {
Tcl_Obj *emptyObj;
+
TclNewObj(emptyObj);
Tcl_IncrRefCount(emptyObj);
while (code == TCL_OK && objc-- > 0) {
- if (NULL == Tcl_ObjSetVar2(interp, *objv++, NULL,
- emptyObj, TCL_LEAVE_ERR_MSG)) {
+ if (Tcl_ObjSetVar2(interp, *objv++, NULL, emptyObj,
+ TCL_LEAVE_ERR_MSG) == NULL) {
code = TCL_ERROR;
}
}
@@ -2134,7 +2283,7 @@ Tcl_LindexObjCmd(
Tcl_Obj *elemPtr; /* Pointer to the element being extracted. */
if (objc < 2) {
- Tcl_WrongNumArgs(interp, 1, objv, "list ?index...?");
+ Tcl_WrongNumArgs(interp, 1, objv, "list ?index ...?");
return TCL_ERROR;
}
@@ -2157,11 +2306,11 @@ Tcl_LindexObjCmd(
if (elemPtr == NULL) {
return TCL_ERROR;
- } else {
- Tcl_SetObjResult(interp, elemPtr);
- Tcl_DecrRefCount(elemPtr);
- return TCL_OK;
}
+
+ Tcl_SetObjResult(interp, elemPtr);
+ Tcl_DecrRefCount(elemPtr);
+ return TCL_OK;
}
/*
@@ -2192,8 +2341,8 @@ Tcl_LinsertObjCmd(
Tcl_Obj *listPtr;
int index, len, result;
- if (objc < 4) {
- Tcl_WrongNumArgs(interp, 1, objv, "list index element ?element ...?");
+ if (objc < 3) {
+ Tcl_WrongNumArgs(interp, 1, objv, "list index ?element ...?");
return TCL_ERROR;
}
@@ -2275,7 +2424,7 @@ Tcl_ListObjCmd(
*/
if (objc > 1) {
- Tcl_SetObjResult(interp, Tcl_NewListObj((objc-1), &(objv[1])));
+ Tcl_SetObjResult(interp, Tcl_NewListObj(objc-1, &objv[1]));
}
return TCL_OK;
}
@@ -2351,52 +2500,74 @@ Tcl_LrangeObjCmd(
register Tcl_Obj *const objv[])
/* Argument objects. */
{
- Tcl_Obj *listPtr, **elemPtrs;
- int listLen, first, result;
+ Tcl_Obj **elemPtrs;
+ int listLen, first, last, result;
if (objc != 4) {
Tcl_WrongNumArgs(interp, 1, objv, "list first last");
return TCL_ERROR;
}
- /*
- * Make sure the list argument is a list object and get its length and a
- * pointer to its array of element pointers.
- */
-
- listPtr = TclListObjCopy(interp, objv[1]);
- if (listPtr == NULL) {
- return TCL_ERROR;
+ result = TclListObjLength(interp, objv[1], &listLen);
+ if (result != TCL_OK) {
+ return result;
}
- TclListObjGetElements(NULL, listPtr, &listLen, &elemPtrs);
result = TclGetIntForIndexM(interp, objv[2], /*endValue*/ listLen - 1,
&first);
- if (result == TCL_OK) {
- int last;
+ if (result != TCL_OK) {
+ return result;
+ }
+ if (first < 0) {
+ first = 0;
+ }
- 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;
+ }
- result = TclGetIntForIndexM(interp, objv[3], /*endValue*/ listLen - 1,
- &last);
- if (result == TCL_OK) {
- if (last >= listLen) {
- last = (listLen - 1);
- }
+ if (first > last) {
+ /*
+ * Returning an empty list is easy.
+ */
- if (first <= last) {
- int numElems = (last - first + 1);
+ return TCL_OK;
+ }
- Tcl_SetObjResult(interp,
- Tcl_NewListObj(numElems, &(elemPtrs[first])));
- }
+ 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_DecrRefCount(listPtr);
- return result;
+ return TCL_OK;
}
/*
@@ -2425,23 +2596,25 @@ Tcl_LrepeatObjCmd(
/* The argument objects. */
{
int elementCount, i, totalElems;
- Tcl_Obj *listPtr, **dataArray;
- List *listRepPtr;
+ Tcl_Obj *listPtr, **dataArray = NULL;
/*
* Check arguments for legality:
- * lrepeat posInt value ?value ...?
+ * lrepeat count ?value ...?
*/
- if (objc < 3) {
- Tcl_WrongNumArgs(interp, 1, objv, "positiveCount value ?value ...?");
+ if (objc < 2) {
+ Tcl_WrongNumArgs(interp, 1, objv, "count ?value ...?");
return TCL_ERROR;
}
- if (TCL_ERROR == TclGetIntFromObj(interp, objv[1], &elementCount)) {
+ if (TCL_OK != TclGetIntFromObj(interp, objv[1], &elementCount)) {
return TCL_ERROR;
}
- if (elementCount < 1) {
- Tcl_AppendResult(interp, "must have a count of at least 1", NULL);
+ if (elementCount < 0) {
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "bad count \"%d\": must be integer >= 0", elementCount));
+ Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LREPEAT", "NEGARG",
+ NULL);
return TCL_ERROR;
}
@@ -2454,9 +2627,10 @@ Tcl_LrepeatObjCmd(
/* Final sanity check. Do not exceed limits on max list length. */
- if (objc > LIST_MAX/elementCount) {
+ if (elementCount && objc > LIST_MAX/elementCount) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"max length of a Tcl list (%d elements) exceeded", LIST_MAX));
+ Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL);
return TCL_ERROR;
}
totalElems = objc * elementCount;
@@ -2467,9 +2641,12 @@ Tcl_LrepeatObjCmd(
*/
listPtr = Tcl_NewListObj(totalElems, NULL);
- listRepPtr = ListRepPtr(listPtr);
- listRepPtr->elemCount = elementCount*objc;
- dataArray = &listRepPtr->elements;
+ if (totalElems) {
+ List *listRepPtr = ListRepPtr(listPtr);
+
+ listRepPtr->elemCount = elementCount*objc;
+ dataArray = &listRepPtr->elements;
+ }
/*
* Set the elements. Note that we handle the common degenerate case of a
@@ -2478,6 +2655,7 @@ Tcl_LrepeatObjCmd(
* number of times.
*/
+ CLANG_ASSERT(dataArray);
if (objc == 1) {
register Tcl_Obj *tmpPtr = objv[0];
@@ -2530,7 +2708,7 @@ Tcl_LreplaceObjCmd(
if (objc < 4) {
Tcl_WrongNumArgs(interp, 1, objv,
- "list first last ?element element ...?");
+ "list first last ?element ...?");
return TCL_ERROR;
}
@@ -2556,7 +2734,7 @@ Tcl_LreplaceObjCmd(
}
if (first < 0) {
- first = 0;
+ first = 0;
}
/*
@@ -2567,15 +2745,17 @@ Tcl_LreplaceObjCmd(
*/
if ((first >= listLen) && (listLen > 0)) {
- Tcl_AppendResult(interp, "list doesn't contain element ",
- TclGetString(objv[2]), NULL);
+ 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 (last >= listLen) {
- last = (listLen - 1);
+ last = listLen - 1;
}
if (first <= last) {
- numToDelete = (last - first + 1);
+ numToDelete = last - first + 1;
} else {
numToDelete = 0;
}
@@ -2598,7 +2778,7 @@ Tcl_LreplaceObjCmd(
* optimize this case away.
*/
- Tcl_ListObjReplace(NULL, listPtr, first, numToDelete, objc-4, &(objv[4]));
+ Tcl_ListObjReplace(NULL, listPtr, first, numToDelete, objc-4, objv+4);
/*
* Set the interpreter's object result.
@@ -2644,7 +2824,7 @@ Tcl_LreverseObjCmd(
}
/*
- * If the list is empty, just return it [Bug 1876793]
+ * If the list is empty, just return it. [Bug 1876793]
*/
if (!elemc) {
@@ -2711,8 +2891,8 @@ Tcl_LsearchObjCmd(
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument values. */
{
- char *bytes, *patternBytes;
- int i, match, mode, index, result, listc, length, elemLen;
+ const char *bytes, *patternBytes;
+ int i, match, index, result, listc, length, elemLen, bisect;
int dataType, isIncreasing, lower, upper, patInt, objInt, offset;
int allMatches, inlineReturn, negatedMatch, returnSubindices, noCase;
double patDouble, objDouble;
@@ -2720,19 +2900,19 @@ Tcl_LsearchObjCmd(
Tcl_Obj *patObj, **listv, *listPtr, *startPtr, *itemPtr;
SortStrCmpFn_t strCmpFn = strcmp;
Tcl_RegExp regexp = NULL;
- static const char *options[] = {
- "-all", "-ascii", "-decreasing", "-dictionary",
+ static const char *const options[] = {
+ "-all", "-ascii", "-bisect", "-decreasing", "-dictionary",
"-exact", "-glob", "-increasing", "-index",
"-inline", "-integer", "-nocase", "-not",
"-real", "-regexp", "-sorted", "-start",
"-subindices", NULL
};
enum options {
- LSEARCH_ALL, LSEARCH_ASCII, LSEARCH_DECREASING, 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_ALL, LSEARCH_ASCII, LSEARCH_BISECT, LSEARCH_DECREASING,
+ 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
};
enum datatypes {
ASCII, DICTIONARY, INTEGER, REAL
@@ -2740,6 +2920,7 @@ Tcl_LsearchObjCmd(
enum modes {
EXACT, GLOB, REGEXP, SORTED
};
+ enum modes mode;
mode = GLOB;
dataType = ASCII;
@@ -2748,6 +2929,7 @@ Tcl_LsearchObjCmd(
inlineReturn = 0;
returnSubindices = 0;
negatedMatch = 0;
+ bisect = 0;
listPtr = NULL;
startPtr = NULL;
offset = 0;
@@ -2761,7 +2943,7 @@ Tcl_LsearchObjCmd(
sortInfo.indexc = 0;
if (objc < 3) {
- Tcl_WrongNumArgs(interp, 1, objv, "?options? list pattern");
+ Tcl_WrongNumArgs(interp, 1, objv, "?-option value ...? list pattern");
return TCL_ERROR;
}
@@ -2771,10 +2953,8 @@ Tcl_LsearchObjCmd(
if (startPtr != NULL) {
Tcl_DecrRefCount(startPtr);
}
- if (sortInfo.indexc > 1) {
- ckfree((char *) sortInfo.indexv);
- }
- return TCL_ERROR;
+ result = TCL_ERROR;
+ goto done;
}
switch ((enum options) index) {
case LSEARCH_ALL: /* -all */
@@ -2783,6 +2963,10 @@ Tcl_LsearchObjCmd(
case LSEARCH_ASCII: /* -ascii */
dataType = ASCII;
break;
+ case LSEARCH_BISECT: /* -bisect */
+ mode = SORTED;
+ bisect = 1;
+ break;
case LSEARCH_DECREASING: /* -decreasing */
isIncreasing = 0;
sortInfo.isIncreasing = 0;
@@ -2835,11 +3019,11 @@ Tcl_LsearchObjCmd(
Tcl_DecrRefCount(startPtr);
}
if (i > objc-4) {
- if (sortInfo.indexc > 1) {
- ckfree((char *) sortInfo.indexv);
- }
- Tcl_AppendResult(interp, "missing starting index", NULL);
- return TCL_ERROR;
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "missing starting index", -1));
+ Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "MISSING", NULL);
+ result = TCL_ERROR;
+ goto done;
}
i++;
if (objv[i] == objv[objc - 2]) {
@@ -2861,15 +3045,16 @@ Tcl_LsearchObjCmd(
int j;
if (sortInfo.indexc > 1) {
- ckfree((char *) sortInfo.indexv);
+ TclStackFree(interp, sortInfo.indexv);
}
if (i > objc-4) {
if (startPtr != NULL) {
Tcl_DecrRefCount(startPtr);
}
- Tcl_AppendResult(interp,
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
"\"-index\" option must be followed by list index",
- NULL);
+ -1));
+ Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "MISSING", NULL);
return TCL_ERROR;
}
@@ -2895,8 +3080,8 @@ Tcl_LsearchObjCmd(
sortInfo.indexv = &sortInfo.singleIndex;
break;
default:
- sortInfo.indexv = (int *)
- ckalloc(sizeof(int) * sortInfo.indexc);
+ sortInfo.indexv =
+ TclStackAlloc(interp, sizeof(int) * sortInfo.indexc);
}
/*
@@ -2908,12 +3093,10 @@ Tcl_LsearchObjCmd(
for (j=0 ; j<sortInfo.indexc ; j++) {
if (TclGetIntForIndexM(interp, indices[j], SORTIDX_END,
&sortInfo.indexv[j]) != TCL_OK) {
- if (sortInfo.indexc > 1) {
- ckfree((char *) sortInfo.indexv);
- }
Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
"\n (-index option item number %d)", j));
- return TCL_ERROR;
+ result = TCL_ERROR;
+ goto done;
}
}
break;
@@ -2929,12 +3112,22 @@ Tcl_LsearchObjCmd(
if (startPtr != NULL) {
Tcl_DecrRefCount(startPtr);
}
- Tcl_AppendResult(interp,
- "-subindices cannot be used without -index option", NULL);
+ 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;
+ }
+
+ if (bisect && (allMatches || negatedMatch)) {
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "-bisect is not compatible with -all or -not", -1));
+ Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LSEARCH",
+ "BAD_OPTION_MIX", NULL);
return TCL_ERROR;
}
- if ((enum modes) mode == REGEXP) {
+ if (mode == REGEXP) {
/*
* We can shimmer regexp/list if listv[i] == pattern, so get the
* regexp rep before the list rep. First time round, omit the interp
@@ -2960,10 +3153,8 @@ Tcl_LsearchObjCmd(
if (startPtr != NULL) {
Tcl_DecrRefCount(startPtr);
}
- if (sortInfo.indexc > 1) {
- ckfree((char *) sortInfo.indexv);
- }
- return TCL_ERROR;
+ result = TCL_ERROR;
+ goto done;
}
}
@@ -2977,10 +3168,7 @@ Tcl_LsearchObjCmd(
if (startPtr != NULL) {
Tcl_DecrRefCount(startPtr);
}
- if (sortInfo.indexc > 1) {
- ckfree((char *) sortInfo.indexv);
- }
- return result;
+ goto done;
}
/*
@@ -2991,10 +3179,7 @@ Tcl_LsearchObjCmd(
result = TclGetIntForIndexM(interp, startPtr, listc-1, &offset);
Tcl_DecrRefCount(startPtr);
if (result != TCL_OK) {
- if (sortInfo.indexc > 1) {
- ckfree((char *) sortInfo.indexv);
- }
- return result;
+ goto done;
}
if (offset < 0) {
offset = 0;
@@ -3007,7 +3192,7 @@ Tcl_LsearchObjCmd(
if (offset > listc-1) {
if (sortInfo.indexc > 1) {
- ckfree((char *) sortInfo.indexv);
+ TclStackFree(interp, sortInfo.indexv);
}
if (allMatches || inlineReturn) {
Tcl_ResetResult(interp);
@@ -3020,7 +3205,7 @@ Tcl_LsearchObjCmd(
patObj = objv[objc - 1];
patternBytes = NULL;
- if ((enum modes) mode == EXACT || (enum modes) mode == SORTED) {
+ if (mode == EXACT || mode == SORTED) {
switch ((enum datatypes) dataType) {
case ASCII:
case DICTIONARY:
@@ -3029,10 +3214,7 @@ Tcl_LsearchObjCmd(
case INTEGER:
result = TclGetIntFromObj(interp, patObj, &patInt);
if (result != TCL_OK) {
- if (sortInfo.indexc > 1) {
- ckfree((char *) sortInfo.indexv);
- }
- return result;
+ goto done;
}
/*
@@ -3045,10 +3227,7 @@ Tcl_LsearchObjCmd(
case REAL:
result = Tcl_GetDoubleFromObj(interp, patObj, &patDouble);
if (result != TCL_OK) {
- if (sortInfo.indexc > 1) {
- ckfree((char *) sortInfo.indexv);
- }
- return result;
+ goto done;
}
/*
@@ -3071,7 +3250,7 @@ Tcl_LsearchObjCmd(
index = -1;
match = 0;
- if ((enum modes) mode == SORTED && !allMatches && !negatedMatch) {
+ if (mode == SORTED && !allMatches && !negatedMatch) {
/*
* If the data is sorted, we can do a more intelligent search. Note
* that there is no point in being smart when -all was specified; in
@@ -3086,10 +3265,8 @@ Tcl_LsearchObjCmd(
if (sortInfo.indexc != 0) {
itemPtr = SelectObjFromSublist(listv[i], &sortInfo);
if (sortInfo.resultCode != TCL_OK) {
- if (sortInfo.indexc > 1) {
- ckfree((char *) sortInfo.indexv);
- }
- return sortInfo.resultCode;
+ result = sortInfo.resultCode;
+ goto done;
}
} else {
itemPtr = listv[i];
@@ -3106,10 +3283,7 @@ Tcl_LsearchObjCmd(
case INTEGER:
result = TclGetIntFromObj(interp, itemPtr, &objInt);
if (result != TCL_OK) {
- if (sortInfo.indexc > 1) {
- ckfree((char *) sortInfo.indexv);
- }
- return result;
+ goto done;
}
if (patInt == objInt) {
match = 0;
@@ -3122,10 +3296,7 @@ Tcl_LsearchObjCmd(
case REAL:
result = Tcl_GetDoubleFromObj(interp, itemPtr, &objDouble);
if (result != TCL_OK) {
- if (sortInfo.indexc > 1) {
- ckfree((char *) sortInfo.indexv);
- }
- return result;
+ goto done;
}
if (patDouble == objDouble) {
match = 0;
@@ -3149,10 +3320,16 @@ Tcl_LsearchObjCmd(
* variation means that a search always makes log n
* comparisons (normal binary search might "get lucky" with an
* early comparison).
+ *
+ * In bisect mode though, we want the last of equals.
*/
index = i;
- upper = i;
+ if (bisect) {
+ lower = i;
+ } else {
+ upper = i;
+ }
} else if (match > 0) {
if (isIncreasing) {
lower = i;
@@ -3167,7 +3344,9 @@ Tcl_LsearchObjCmd(
}
}
}
-
+ if (bisect && index < 0) {
+ index = lower;
+ }
} else {
/*
* We need to do a linear search, because (at least one) of:
@@ -3181,22 +3360,20 @@ Tcl_LsearchObjCmd(
}
for (i = offset; i < listc; i++) {
match = 0;
- if (sortInfo.indexc != 0) {
+ if (sortInfo.indexc != 0) {
itemPtr = SelectObjFromSublist(listv[i], &sortInfo);
if (sortInfo.resultCode != TCL_OK) {
if (listPtr != NULL) {
Tcl_DecrRefCount(listPtr);
}
- if (sortInfo.indexc > 1) {
- ckfree((char *) sortInfo.indexv);
- }
- return sortInfo.resultCode;
+ result = sortInfo.resultCode;
+ goto done;
}
} else {
itemPtr = listv[i];
}
-
- switch ((enum modes) mode) {
+
+ switch (mode) {
case SORTED:
case EXACT:
switch ((enum datatypes) dataType) {
@@ -3228,10 +3405,7 @@ Tcl_LsearchObjCmd(
if (listPtr != NULL) {
Tcl_DecrRefCount(listPtr);
}
- if (sortInfo.indexc > 1) {
- ckfree((char *) sortInfo.indexv);
- }
- return result;
+ goto done;
}
match = (objInt == patInt);
break;
@@ -3242,10 +3416,7 @@ Tcl_LsearchObjCmd(
if (listPtr) {
Tcl_DecrRefCount(listPtr);
}
- if (sortInfo.indexc > 1) {
- ckfree((char *) sortInfo.indexv);
- }
- return result;
+ goto done;
}
match = (objDouble == patDouble);
break;
@@ -3264,10 +3435,8 @@ Tcl_LsearchObjCmd(
if (listPtr != NULL) {
Tcl_DecrRefCount(listPtr);
}
- if (sortInfo.indexc > 1) {
- ckfree((char *) sortInfo.indexv);
- }
- return TCL_ERROR;
+ result = TCL_ERROR;
+ goto done;
}
break;
}
@@ -3340,15 +3509,17 @@ Tcl_LsearchObjCmd(
} else {
Tcl_SetObjResult(interp, listv[index]);
}
+ result = TCL_OK;
/*
* Cleanup the index list array.
*/
+ done:
if (sortInfo.indexc > 1) {
- ckfree((char *) sortInfo.indexv);
+ TclStackFree(interp, sortInfo.indexv);
}
- return TCL_OK;
+ return result;
}
/*
@@ -3383,7 +3554,8 @@ Tcl_LsetObjCmd(
*/
if (objc < 3) {
- Tcl_WrongNumArgs(interp, 1, objv, "listVar ?index? ?index...? value");
+ Tcl_WrongNumArgs(interp, 1, objv,
+ "listVar ?index? ?index ...? value");
return TCL_ERROR;
}
@@ -3391,8 +3563,7 @@ Tcl_LsetObjCmd(
* Look up the list variable's value.
*/
- listPtr = Tcl_ObjGetVar2(interp, objv[1], (Tcl_Obj *) NULL,
- TCL_LEAVE_ERR_MSG);
+ listPtr = Tcl_ObjGetVar2(interp, objv[1], NULL, TCL_LEAVE_ERR_MSG);
if (listPtr == NULL) {
return TCL_ERROR;
}
@@ -3462,29 +3633,30 @@ Tcl_LsortObjCmd(
{
int i, j, index, indices, length, nocase = 0, indexc;
int sortMode = SORTMODE_ASCII;
+ int group, groupSize, groupOffset, idx, allocatedIndexVector = 0;
Tcl_Obj *resultPtr, *cmdPtr, **listObjPtrs, *listObj, *indexPtr;
SortElement *elementArray, *elementPtr;
SortInfo sortInfo; /* Information about this sort that needs to
* be passed to the comparison function. */
- static const char *switches[] = {
+# define NUM_LISTS 30
+ SortElement *subList[NUM_LISTS+1];
+ /* This array holds pointers to temporary
+ * lists built during the merge sort. Element
+ * i of the array holds a list of length
+ * 2**i. */
+ static const char *const switches[] = {
"-ascii", "-command", "-decreasing", "-dictionary", "-increasing",
- "-index", "-indices", "-integer", "-nocase", "-real", "-unique", NULL
+ "-index", "-indices", "-integer", "-nocase", "-real", "-stride",
+ "-unique", NULL
};
enum Lsort_Switches {
LSORT_ASCII, LSORT_COMMAND, LSORT_DECREASING, LSORT_DICTIONARY,
LSORT_INCREASING, LSORT_INDEX, LSORT_INDICES, LSORT_INTEGER,
- LSORT_NOCASE, LSORT_REAL, LSORT_UNIQUE
+ LSORT_NOCASE, LSORT_REAL, LSORT_STRIDE, LSORT_UNIQUE
};
- /*
- * The subList array below holds pointers to temporary lists built during
- * the merge sort. Element i of the array holds a list of length 2**i.
- */
-# define NUM_LISTS 30
- SortElement *subList[NUM_LISTS+1];
-
if (objc < 2) {
- Tcl_WrongNumArgs(interp, 1, objv, "?options? list");
+ Tcl_WrongNumArgs(interp, 1, objv, "?-option value ...? list");
return TCL_ERROR;
}
@@ -3498,30 +3670,31 @@ Tcl_LsortObjCmd(
sortInfo.indexc = 0;
sortInfo.unique = 0;
sortInfo.interp = interp;
- sortInfo.resultCode = TCL_OK;
+ sortInfo.resultCode = TCL_OK;
cmdPtr = NULL;
indices = 0;
+ group = 0;
+ groupSize = 1;
+ groupOffset = 0;
+ indexPtr = NULL;
for (i = 1; i < objc-1; i++) {
if (Tcl_GetIndexFromObj(interp, objv[i], switches, "option", 0,
&index) != TCL_OK) {
- if (sortInfo.indexc > 1) {
- ckfree((char *) sortInfo.indexv);
- }
- return TCL_ERROR;
+ sortInfo.resultCode = TCL_ERROR;
+ goto done2;
}
switch ((enum Lsort_Switches) index) {
case LSORT_ASCII:
sortInfo.sortMode = SORTMODE_ASCII;
break;
case LSORT_COMMAND:
- if (i == (objc-2)) {
- if (sortInfo.indexc > 1) {
- ckfree((char *) sortInfo.indexv);
- }
- Tcl_AppendResult(interp,
+ if (i == objc-2) {
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
"\"-command\" option must be followed "
- "by comparison command", NULL);
- return TCL_ERROR;
+ "by comparison command", -1));
+ Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "MISSING", NULL);
+ sortInfo.resultCode = TCL_ERROR;
+ goto done2;
}
sortInfo.sortMode = SORTMODE_COMMAND;
cmdPtr = objv[i+1];
@@ -3537,54 +3710,41 @@ Tcl_LsortObjCmd(
sortInfo.isIncreasing = 1;
break;
case LSORT_INDEX: {
- Tcl_Obj **indices;
-
- if (sortInfo.indexc > 1) {
- ckfree((char *) sortInfo.indexv);
- }
- if (i == (objc-2)) {
- Tcl_AppendResult(interp, "\"-index\" option must be "
- "followed by list index", NULL);
- return TCL_ERROR;
- }
+ int indexc, dummy;
+ Tcl_Obj **indexv;
- /*
- * Take copy to prevent shimmering problems.
- */
-
- if (TclListObjGetElements(interp, objv[i+1], &sortInfo.indexc,
- &indices) != TCL_OK) {
- return TCL_ERROR;
+ if (i == objc-2) {
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "\"-index\" option must be followed by list index",
+ -1));
+ Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "MISSING", NULL);
+ sortInfo.resultCode = TCL_ERROR;
+ goto done2;
}
- switch (sortInfo.indexc) {
- case 0:
- sortInfo.indexv = NULL;
- break;
- case 1:
- sortInfo.indexv = &sortInfo.singleIndex;
- break;
- default:
- sortInfo.indexv = (int *)
- ckalloc(sizeof(int) * sortInfo.indexc);
+ if (TclListObjGetElements(interp, objv[i+1], &indexc,
+ &indexv) != TCL_OK) {
+ sortInfo.resultCode = TCL_ERROR;
+ goto done2;
}
/*
- * Fill the array by parsing each index. We don't know whether
- * their scale is sensible yet, but we at least perform the
- * syntactic check here.
+ * Check each of the indices for syntactic correctness. Note that
+ * we do not store the converted values here because we do not
+ * know if this is the only -index option yet and so we can't
+ * allocate any space; that happens after the scan through all the
+ * options is done.
*/
- for (j=0 ; j<sortInfo.indexc ; j++) {
- if (TclGetIntForIndexM(interp, indices[j], SORTIDX_END,
- &sortInfo.indexv[j]) != TCL_OK) {
- if (sortInfo.indexc > 1) {
- ckfree((char *) sortInfo.indexv);
- }
+ for (j=0 ; j<indexc ; j++) {
+ if (TclGetIntForIndexM(interp, indexv[j], SORTIDX_END,
+ &dummy) != TCL_OK) {
Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
"\n (-index option item number %d)", j));
- return TCL_ERROR;
+ sortInfo.resultCode = TCL_ERROR;
+ goto done2;
}
}
+ indexPtr = objv[i+1];
i++;
break;
}
@@ -3603,12 +3763,65 @@ Tcl_LsortObjCmd(
case LSORT_INDICES:
indices = 1;
break;
+ case LSORT_STRIDE:
+ if (i == objc-2) {
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "\"-stride\" option must be "
+ "followed by stride length", -1));
+ Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "MISSING", NULL);
+ sortInfo.resultCode = TCL_ERROR;
+ goto done2;
+ }
+ if (Tcl_GetIntFromObj(interp, objv[i+1], &groupSize) != TCL_OK) {
+ sortInfo.resultCode = TCL_ERROR;
+ goto done2;
+ }
+ if (groupSize < 2) {
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "stride length must be at least 2", -1));
+ Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LSORT",
+ "BADSTRIDE", NULL);
+ sortInfo.resultCode = TCL_ERROR;
+ goto done2;
+ }
+ group = 1;
+ i++;
+ break;
}
}
if (nocase && (sortInfo.sortMode == SORTMODE_ASCII)) {
sortInfo.sortMode = SORTMODE_ASCII_NC;
}
+ /*
+ * Now extract the -index list for real, if present. No failures are
+ * expected here; the values are all of the right type or convertible to
+ * it.
+ */
+
+ if (indexPtr) {
+ Tcl_Obj **indexv;
+
+ TclListObjGetElements(interp, indexPtr, &sortInfo.indexc, &indexv);
+ switch (sortInfo.indexc) {
+ case 0:
+ sortInfo.indexv = NULL;
+ break;
+ case 1:
+ sortInfo.indexv = &sortInfo.singleIndex;
+ break;
+ default:
+ sortInfo.indexv =
+ TclStackAlloc(interp, sizeof(int) * sortInfo.indexc);
+ allocatedIndexVector = 1; /* Cannot use indexc field, as it
+ * might be decreased by 1 later. */
+ }
+ for (j=0 ; j<sortInfo.indexc ; j++) {
+ TclGetIntForIndexM(interp, indexv[j], SORTIDX_END,
+ &sortInfo.indexv[j]);
+ }
+ }
+
listObj = objv[objc-1];
if (sortInfo.sortMode == SORTMODE_COMMAND) {
@@ -3623,10 +3836,8 @@ Tcl_LsortObjCmd(
listObj = TclListObjCopy(interp, listObj);
if (listObj == NULL) {
- if (sortInfo.indexc > 1) {
- ckfree((char *) sortInfo.indexv);
- }
- return TCL_ERROR;
+ sortInfo.resultCode = TCL_ERROR;
+ goto done2;
}
/*
@@ -3643,10 +3854,8 @@ Tcl_LsortObjCmd(
TclDecrRefCount(listObj);
Tcl_IncrRefCount(newObjPtr);
TclDecrRefCount(newObjPtr);
- if (sortInfo.indexc > 1) {
- ckfree((char *) sortInfo.indexv);
- }
- return TCL_ERROR;
+ sortInfo.resultCode = TCL_ERROR;
+ goto done2;
}
Tcl_ListObjAppendElement(interp, newCommandPtr, Tcl_NewObj());
sortInfo.compareCmdPtr = newCommandPtr;
@@ -3657,8 +3866,62 @@ Tcl_LsortObjCmd(
if (sortInfo.resultCode != TCL_OK || length <= 0) {
goto done;
}
+
+ /*
+ * Check for sanity when grouping elements of the overall list together
+ * because of the -stride option. [TIP #326]
+ */
+
+ if (group) {
+ if (length % groupSize) {
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "list size must be a multiple of the stride length",
+ -1));
+ Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LSORT", "BADSTRIDE",
+ NULL);
+ sortInfo.resultCode = TCL_ERROR;
+ goto done;
+ }
+ length = length / groupSize;
+ 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 = sortInfo.indexv[0];
+ if (groupOffset <= SORTIDX_END) {
+ groupOffset = (groupOffset - SORTIDX_END) + 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", "LSORT",
+ "BADINDEX", NULL);
+ sortInfo.resultCode = TCL_ERROR;
+ goto done;
+ }
+ if (sortInfo.indexc == 1) {
+ sortInfo.indexc = 0;
+ sortInfo.indexv = NULL;
+ } else {
+ sortInfo.indexc--;
+
+ /*
+ * Do not shrink the actual memory block used; that doesn't
+ * work with TclStackAlloc-allocated memory. [Bug 2918962]
+ */
+
+ for (i = 0; i < sortInfo.indexc; i++) {
+ sortInfo.indexv[i] = sortInfo.indexv[i+1];
+ }
+ }
+ }
+ }
+
sortInfo.numElements = length;
-
+
indexc = sortInfo.indexc;
sortMode = sortInfo.sortMode;
if ((sortMode == SORTMODE_ASCII_NC)
@@ -3666,7 +3929,7 @@ Tcl_LsortObjCmd(
/*
* For this function's purpose all string-based modes are equivalent
*/
-
+
sortMode = SORTMODE_ASCII;
}
@@ -3675,7 +3938,7 @@ Tcl_LsortObjCmd(
* contain a sorted sublist of length 2**i. Use one extra subList at the
* end, always at NULL, to indicate the end of the lists.
*/
-
+
for (j=0 ; j<=NUM_LISTS ; j++) {
subList[j] = NULL;
}
@@ -3685,57 +3948,65 @@ Tcl_LsortObjCmd(
* begins sorting it into the sublists as it appears.
*/
- elementArray = (SortElement *) ckalloc( length * sizeof(SortElement));
+ elementArray = TclStackAlloc(interp, length * sizeof(SortElement));
for (i=0; i < length; i++){
+ idx = groupSize * i + groupOffset;
if (indexc) {
/*
* If this is an indexed sort, retrieve the corresponding element
*/
- indexPtr = SelectObjFromSublist(listObjPtrs[i], &sortInfo);
+ indexPtr = SelectObjFromSublist(listObjPtrs[idx], &sortInfo);
if (sortInfo.resultCode != TCL_OK) {
goto done1;
}
} else {
- indexPtr = listObjPtrs[i];
+ indexPtr = listObjPtrs[idx];
}
/*
* Determine the "value" of this object for sorting purposes
*/
-
+
if (sortMode == SORTMODE_ASCII) {
- elementArray[i].index.strValuePtr = TclGetString(indexPtr);
+ elementArray[i].collationKey.strValuePtr = TclGetString(indexPtr);
} else if (sortMode == SORTMODE_INTEGER) {
long a;
+
if (TclGetLongFromObj(sortInfo.interp, indexPtr, &a) != TCL_OK) {
sortInfo.resultCode = TCL_ERROR;
goto done1;
}
- elementArray[i].index.intValue = a;
+ elementArray[i].collationKey.intValue = a;
} else if (sortMode == SORTMODE_REAL) {
double a;
- if (Tcl_GetDoubleFromObj(sortInfo.interp, indexPtr, &a) != TCL_OK) {
+
+ if (Tcl_GetDoubleFromObj(sortInfo.interp, indexPtr,
+ &a) != TCL_OK) {
sortInfo.resultCode = TCL_ERROR;
goto done1;
}
- elementArray[i].index.doubleValue = a;
+ elementArray[i].collationKey.doubleValue = a;
} else {
- elementArray[i].index.objValuePtr = indexPtr;
+ elementArray[i].collationKey.objValuePtr = indexPtr;
}
/*
* Determine the representation of this element in the result: either
* the objPtr itself, or its index in the original list.
*/
-
- elementArray[i].objPtr = (indices ? INT2PTR(i) : listObjPtrs[i]);
+
+ if (indices || group) {
+ elementArray[i].payload.index = idx;
+ } else {
+ elementArray[i].payload.objPtr = listObjPtrs[idx];
+ }
/*
* Merge this element in the pre-existing sublists (and merge together
* sublists when we have two of the same size).
*/
-
+
elementArray[i].nextPtr = NULL;
elementPtr = &elementArray[i];
for (j=0 ; subList[j] ; j++) {
@@ -3751,34 +4022,47 @@ Tcl_LsortObjCmd(
/*
* Merge all sublists
*/
-
+
elementPtr = subList[0];
for (j=1 ; j<NUM_LISTS ; j++) {
elementPtr = MergeLists(subList[j], elementPtr, &sortInfo);
}
-
/*
* Now store the sorted elements in the result list.
*/
-
+
if (sortInfo.resultCode == TCL_OK) {
List *listRepPtr;
Tcl_Obj **newArray, *objPtr;
- int i;
-
- resultPtr = Tcl_NewListObj(sortInfo.numElements, NULL);
+
+ resultPtr = Tcl_NewListObj(sortInfo.numElements * groupSize, NULL);
listRepPtr = ListRepPtr(resultPtr);
newArray = &listRepPtr->elements;
- if (indices) {
- for (i = 0; elementPtr != NULL ; elementPtr = elementPtr->nextPtr){
- objPtr = Tcl_NewIntObj(PTR2INT(elementPtr->objPtr));
+ if (group) {
+ for (i=0; elementPtr!=NULL ; elementPtr=elementPtr->nextPtr) {
+ idx = elementPtr->payload.index;
+ for (j = 0; j < groupSize; j++) {
+ if (indices) {
+ objPtr = Tcl_NewIntObj(idx + j - groupOffset);
+ newArray[i++] = objPtr;
+ Tcl_IncrRefCount(objPtr);
+ } else {
+ objPtr = listObjPtrs[idx + j - groupOffset];
+ newArray[i++] = objPtr;
+ Tcl_IncrRefCount(objPtr);
+ }
+ }
+ }
+ } else if (indices) {
+ for (i=0; elementPtr != NULL ; elementPtr = elementPtr->nextPtr) {
+ objPtr = Tcl_NewIntObj(elementPtr->payload.index);
newArray[i++] = objPtr;
Tcl_IncrRefCount(objPtr);
}
} else {
- for (i = 0; elementPtr != NULL ; elementPtr = elementPtr->nextPtr){
- objPtr = elementPtr->objPtr;
+ for (i=0; elementPtr != NULL ; elementPtr = elementPtr->nextPtr) {
+ objPtr = elementPtr->payload.objPtr;
newArray[i++] = objPtr;
Tcl_IncrRefCount(objPtr);
}
@@ -3788,7 +4072,7 @@ Tcl_LsortObjCmd(
}
done1:
- ckfree((char *)elementArray);
+ TclStackFree(interp, elementArray);
done:
if (sortMode == SORTMODE_COMMAND) {
@@ -3796,8 +4080,9 @@ Tcl_LsortObjCmd(
TclDecrRefCount(listObj);
sortInfo.compareCmdPtr = NULL;
}
- if (sortInfo.indexc > 1) {
- ckfree((char *) sortInfo.indexv);
+ done2:
+ if (allocatedIndexVector) {
+ TclStackFree(interp, sortInfo.indexv);
}
return sortInfo.resultCode;
}
@@ -3814,21 +4099,23 @@ Tcl_LsortObjCmd(
* The unified list of SortElement structures.
*
* Side effects:
- * If infoPtr->unique is set then infoPtr->numElements may be updated.
+ * If infoPtr->unique is set then infoPtr->numElements may be updated.
* Possibly others, if a user-defined comparison command does something
- * weird.
+ * weird.
*
* Note:
- * If infoPtr->unique is set, the merge assumes that there are no
+ * If infoPtr->unique is set, the merge assumes that there are no
* "repeated" elements in each of the left and right lists. In that case,
* if any element of the left list is equivalent to one in the right list
* it is omitted from the merged list.
- * This simplified mechanism works because of the special way
- * our MergeSort creates the sublists to be merged and will fail to
- * eliminate all repeats in the general case where they are already
- * present in either the left or right list. A general code would need to
- * skip adjacent initial repeats in the left and right lists before
- * comparing their initial elements, at each step.
+ *
+ * This simplified mechanism works because of the special way our
+ * MergeSort creates the sublists to be merged and will fail to eliminate
+ * all repeats in the general case where they are already present in
+ * either the left or right list. A general code would need to skip
+ * adjacent initial repeats in the left and right lists before comparing
+ * their initial elements, at each step.
+ *
*----------------------------------------------------------------------
*/
@@ -3930,25 +4217,25 @@ SortCompare(
int order = 0;
if (infoPtr->sortMode == SORTMODE_ASCII) {
- order = strcmp(elemPtr1->index.strValuePtr,
- elemPtr2->index.strValuePtr);
+ order = strcmp(elemPtr1->collationKey.strValuePtr,
+ elemPtr2->collationKey.strValuePtr);
} else if (infoPtr->sortMode == SORTMODE_ASCII_NC) {
- order = TclUtfCasecmp(elemPtr1->index.strValuePtr,
- elemPtr2->index.strValuePtr);
+ order = TclUtfCasecmp(elemPtr1->collationKey.strValuePtr,
+ elemPtr2->collationKey.strValuePtr);
} else if (infoPtr->sortMode == SORTMODE_DICTIONARY) {
- order = DictionaryCompare(elemPtr1->index.strValuePtr,
- elemPtr2->index.strValuePtr);
+ order = DictionaryCompare(elemPtr1->collationKey.strValuePtr,
+ elemPtr2->collationKey.strValuePtr);
} else if (infoPtr->sortMode == SORTMODE_INTEGER) {
long a, b;
- a = elemPtr1->index.intValue;
- b = elemPtr2->index.intValue;
+ a = elemPtr1->collationKey.intValue;
+ b = elemPtr2->collationKey.intValue;
order = ((a >= b) - (a <= b));
} else if (infoPtr->sortMode == SORTMODE_REAL) {
double a, b;
- a = elemPtr1->index.doubleValue;
- b = elemPtr2->index.doubleValue;
+ a = elemPtr1->collationKey.doubleValue;
+ b = elemPtr2->collationKey.doubleValue;
order = ((a >= b) - (a <= b));
} else {
Tcl_Obj **objv, *paramObjv[2];
@@ -3960,14 +4247,14 @@ SortCompare(
* Once an error has occurred, skip any future comparisons so as
* to preserve the error message in sortInterp->result.
*/
-
+
return 0;
}
- objPtr1 = elemPtr1->index.objValuePtr;
- objPtr2 = elemPtr2->index.objValuePtr;
-
+ objPtr1 = elemPtr1->collationKey.objValuePtr;
+ objPtr2 = elemPtr2->collationKey.objValuePtr;
+
paramObjv[0] = objPtr1;
paramObjv[1] = objPtr2;
@@ -3985,8 +4272,7 @@ SortCompare(
infoPtr->resultCode = Tcl_EvalObjv(infoPtr->interp, objc, objv, 0);
if (infoPtr->resultCode != TCL_OK) {
- Tcl_AddErrorInfo(infoPtr->interp,
- "\n (-compare command)");
+ Tcl_AddErrorInfo(infoPtr->interp, "\n (-compare command)");
return 0;
}
@@ -3996,9 +4282,10 @@ SortCompare(
if (TclGetIntFromObj(infoPtr->interp,
Tcl_GetObjResult(infoPtr->interp), &order) != TCL_OK) {
- Tcl_ResetResult(infoPtr->interp);
- Tcl_AppendResult(infoPtr->interp,
- "-compare command returned non-integer result", NULL);
+ Tcl_SetObjResult(infoPtr->interp, Tcl_NewStringObj(
+ "-compare command returned non-integer result", -1));
+ Tcl_SetErrorCode(infoPtr->interp, "TCL", "OPERATION", "LSORT",
+ "COMPARISONFAILED", NULL);
infoPtr->resultCode = TCL_ERROR;
return 0;
}
@@ -4035,7 +4322,7 @@ SortCompare(
static int
DictionaryCompare(
- char *left, char *right) /* The strings to compare. */
+ const char *left, const char *right) /* The strings to compare. */
{
Tcl_UniChar uniLeft, uniRight, uniLeftLower, uniRightLower;
int diff, zeros;
@@ -4052,11 +4339,11 @@ DictionaryCompare(
*/
zeros = 0;
- while ((*right == '0') && (isdigit(UCHAR(right[1])))) {
+ while ((*right == '0') && isdigit(UCHAR(right[1]))) {
right++;
zeros--;
}
- while ((*left == '0') && (isdigit(UCHAR(left[1])))) {
+ while ((*left == '0') && isdigit(UCHAR(left[1]))) {
left++;
zeros++;
}
@@ -4209,12 +4496,11 @@ SelectObjFromSublist(
return NULL;
}
if (currentObj == NULL) {
- char buffer[TCL_INTEGER_SPACE];
-
- TclFormatInt(buffer, index);
- Tcl_AppendResult(infoPtr->interp, "element ", buffer,
- " missing from sublist \"", TclGetString(objPtr), "\"",
- NULL);
+ Tcl_SetObjResult(infoPtr->interp, Tcl_ObjPrintf(
+ "element %d missing from sublist \"%s\"",
+ index, TclGetString(objPtr)));
+ Tcl_SetErrorCode(infoPtr->interp, "TCL", "OPERATION", "LSORT",
+ "INDEXFAILED", NULL);
infoPtr->resultCode = TCL_ERROR;
return NULL;
}
@@ -4228,5 +4514,6 @@ SelectObjFromSublist(
* mode: c
* c-basic-offset: 4
* fill-column: 78
+ * tab-width: 8
* End:
*/
generated by cgit v0.12 at 2024-11-21 18:27:51 (GMT)