summaryrefslogtreecommitdiffstats
path: root/generic/tclCmdIL.c
diff options
context:
space:
mode:
Diffstat (limited to 'generic/tclCmdIL.c')
-rw-r--r--generic/tclCmdIL.c1054
1 files changed, 591 insertions, 463 deletions
diff --git a/generic/tclCmdIL.c b/generic/tclCmdIL.c
index d1174ab..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.
@@ -15,8 +15,6 @@
*
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
- *
- * RCS: @(#) $Id: tclCmdIL.c,v 1.161 2008/10/14 19:26:59 dgp Exp $
*/
#include "tclInt.h"
@@ -29,13 +27,16 @@
*/
typedef struct SortElement {
- union {
- char *strValuePtr;
+ 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;
@@ -103,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,
@@ -116,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[]);
@@ -142,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);
@@ -155,30 +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},
- {"coroutine", TclInfoCoroutineCmd, 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}
};
/*
@@ -209,7 +216,7 @@ Tcl_IfObjCmd(
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
- return Tcl_NRCallObjProc(interp, TclNRIfObjCmd, dummy, objc, objv);
+ return Tcl_NRCallObjProc(interp, TclNRIfObjCmd, dummy, objc, objv);
}
int
@@ -219,40 +226,56 @@ TclNRIfObjCmd(
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
- int thenScriptIndex = 0; /* "then" script to be evaled after syntax
- * check. */
+ 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)) {
@@ -284,11 +307,31 @@ TclNRIfObjCmd(
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;
}
/*
@@ -300,14 +343,14 @@ TclNRIfObjCmd(
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) {
@@ -319,6 +362,13 @@ TclNRIfObjCmd(
iPtr->cmdFramePtr, thenScriptIndex);
}
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;
}
/*
@@ -388,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
@@ -431,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;
@@ -444,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;
}
@@ -492,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;
@@ -504,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;
}
@@ -602,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;
@@ -635,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);
@@ -782,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);
}
@@ -807,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 {
@@ -917,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;
@@ -932,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;
}
@@ -942,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));
}
@@ -960,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;
}
/*
@@ -998,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) {
@@ -1044,21 +1147,38 @@ InfoFrameCmd(
Tcl_Obj *const objv[]) /* Argument objects. */
{
Interp *iPtr = (Interp *) interp;
- int level, topLevel;
- CmdFrame *framePtr;
-
- topLevel = ((iPtr->cmdFramePtr == NULL)
- ? 0
- : iPtr->cmdFramePtr->level);
+ 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;
+ }
- if (iPtr->execEnvPtr->corPtr) {
- /*
- * A coroutine: must fix the level computations
- */
+ while (corPtr) {
+ while (*cmdFramePtrPtr) {
+ topLevel++;
+ cmdFramePtrPtr = &((*cmdFramePtrPtr)->nextPtr);
+ }
+ if (corPtr->caller.cmdFramePtr) {
+ *cmdFramePtrPtr = corPtr->caller.cmdFramePtr;
+ }
+ corPtr = corPtr->callerEEPtr->corPtr;
+ }
+ topLevel += (*cmdFramePtrPtr)->level;
- topLevel += iPtr->execEnvPtr->corPtr->caller.cmdFramePtr->level + 1 -
- iPtr->execEnvPtr->corPtr->base.cmdFramePtr->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) {
@@ -1066,11 +1186,8 @@ InfoFrameCmd(
* Just "info frame".
*/
- Tcl_SetObjResult(interp, Tcl_NewIntObj (topLevel));
- return TCL_OK;
- } else if (objc != 2) {
- Tcl_WrongNumArgs(interp, 1, objv, "?number?");
- return TCL_ERROR;
+ Tcl_SetObjResult(interp, Tcl_NewIntObj(topLevel));
+ goto done;
}
/*
@@ -1078,16 +1195,20 @@ InfoFrameCmd(
*/
if (TclGetIntFromObj(interp, objv[1], &level) != TCL_OK) {
- return TCL_ERROR;
+ code = TCL_ERROR;
+ goto done;
}
if ((level > topLevel) || (level <= - topLevel)) {
levelError:
- Tcl_AppendResult(interp, "bad level \"", TclGetString(objv[1]), "\"",
- NULL);
- return TCL_ERROR;
+ 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;
}
-
+
/*
* Let us convert to relative so that we know how many levels to go back
*/
@@ -1096,7 +1217,7 @@ InfoFrameCmd(
level -= topLevel;
}
- framePtr = iPtr->cmdFramePtr;
+ framePtr = iPtr->cmdFramePtr;
while (++level <= 0) {
framePtr = framePtr->nextPtr;
if (!framePtr) {
@@ -1105,7 +1226,31 @@ InfoFrameCmd(
}
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;
}
/*
@@ -1130,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;
@@ -1137,15 +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.
*/
@@ -1163,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:
@@ -1200,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;
/*
@@ -1233,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;
}
@@ -1253,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:
@@ -1271,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;
@@ -1357,19 +1478,42 @@ InfoFunctionsCmd(
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
- char *pattern;
+ Tcl_Obj *script;
+ int code;
- if (objc == 1) {
- pattern = NULL;
- } else if (objc == 2) {
- pattern = TclGetString(objv[1]);
- } else {
+ if (objc > 2) {
Tcl_WrongNumArgs(interp, 1, objv, "?pattern?");
return TCL_ERROR;
}
- Tcl_SetObjResult(interp, Tcl_ListMathFuncs(interp, pattern));
- return TCL_OK;
+ script = Tcl_NewStringObj(
+" ::apply [::list {{pattern *}} {\n"
+" ::set cmds {}\n"
+" ::foreach cmd [::info commands ::tcl::mathfunc::$pattern] {\n"
+" ::lappend cmds [::namespace tail $cmd]\n"
+" }\n"
+" ::foreach cmd [::info commands tcl::mathfunc::$pattern] {\n"
+" ::set cmd [::namespace tail $cmd]\n"
+" ::if {$cmd ni $cmds} {\n"
+" ::lappend cmds $cmd\n"
+" }\n"
+" }\n"
+" ::return $cmds\n"
+" } [::namespace current]] ", -1);
+
+ if (objc == 2) {
+ Tcl_Obj *arg = Tcl_NewListObj(1, &(objv[1]));
+
+ Tcl_AppendObjToObj(script, arg);
+ Tcl_DecrRefCount(arg);
+ }
+
+ Tcl_IncrRefCount(script);
+ code = Tcl_EvalObjEx(interp, script, 0);
+
+ Tcl_DecrRefCount(script);
+
+ return code;
}
/*
@@ -1411,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;
}
@@ -1481,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;
}
@@ -1526,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;
}
@@ -1558,8 +1710,7 @@ InfoLoadedCmd(
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
- char *interpName;
- int result;
+ const char *interpName;
if ((objc != 1) && (objc != 2)) {
Tcl_WrongNumArgs(interp, 1, objv, "?interp?");
@@ -1571,8 +1722,7 @@ InfoLoadedCmd(
} else { /* Get pkgs just in specified interp. */
interpName = TclGetString(objv[1]);
}
- result = TclGetLoadedPackages(interp, interpName);
- return result;
+ return TclGetLoadedPackages(interp, interpName);
}
/*
@@ -1686,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
@@ -1720,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);
@@ -2076,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;
}
}
@@ -2155,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;
}
/*
@@ -2273,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;
}
@@ -2363,7 +2514,7 @@ Tcl_LrangeObjCmd(
}
result = TclGetIntForIndexM(interp, objv[2], /*endValue*/ listLen - 1,
- &first);
+ &first);
if (result != TCL_OK) {
return result;
}
@@ -2372,12 +2523,12 @@ Tcl_LrangeObjCmd(
}
result = TclGetIntForIndexM(interp, objv[3], /*endValue*/ listLen - 1,
- &last);
+ &last);
if (result != TCL_OK) {
return result;
}
if (last >= listLen) {
- last = (listLen - 1);
+ last = listLen - 1;
}
if (first > last) {
@@ -2394,9 +2545,9 @@ Tcl_LrangeObjCmd(
}
if (Tcl_IsShared(objv[1]) ||
- (((List *) objv[1]->internalRep.twoPtrValue.ptr1)->refCount > 1)) {
+ ((ListRepPtr(objv[1])->refCount > 1))) {
Tcl_SetObjResult(interp, Tcl_NewListObj(last - first + 1,
- &(elemPtrs[first])));
+ &elemPtrs[first]));
} else {
/*
* In-place is possible.
@@ -2408,8 +2559,8 @@ Tcl_LrangeObjCmd(
}
/*
- * This one is not conditioned on (first>0) in order to
- * preserve the string-canonizing effect of [lrange 0 end].
+ * 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);
@@ -2445,7 +2596,7 @@ Tcl_LrepeatObjCmd(
/* The argument objects. */
{
int elementCount, i, totalElems;
- Tcl_Obj *listPtr, **dataArray;
+ Tcl_Obj *listPtr, **dataArray = NULL;
/*
* Check arguments for legality:
@@ -2460,8 +2611,10 @@ Tcl_LrepeatObjCmd(
return TCL_ERROR;
}
if (elementCount < 0) {
- Tcl_SetObjResult(interp, Tcl_Format(NULL,
- "bad count \"%d\": must be integer >= 0", 1, objv+1));
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "bad count \"%d\": must be integer >= 0", elementCount));
+ Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LREPEAT", "NEGARG",
+ NULL);
return TCL_ERROR;
}
@@ -2472,22 +2625,15 @@ Tcl_LrepeatObjCmd(
objc -= 2;
objv += 2;
- /*
- * Final sanity check. Total number of elements must fit in a signed
- * integer. We also limit the number of elements to 512M-1 so allocations
- * on 32-bit machines are guaranteed to be less than 2GB! [Bug 2130992]
- */
+ /* Final sanity check. Do not exceed limits on max list length. */
- totalElems = objc * elementCount;
- if (totalElems != 0 && (totalElems/objc != elementCount
- || totalElems/elementCount != objc)) {
- Tcl_AppendResult(interp, "too many elements in result list", NULL);
- return TCL_ERROR;
- }
- if (totalElems >= 0x20000000) {
- Tcl_AppendResult(interp, "too many elements in result list", NULL);
+ 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;
/*
* Get an empty list object that is allocated large enough to hold each
@@ -2496,7 +2642,8 @@ Tcl_LrepeatObjCmd(
listPtr = Tcl_NewListObj(totalElems, NULL);
if (totalElems) {
- List *listRepPtr = listPtr->internalRep.twoPtrValue.ptr1;
+ List *listRepPtr = ListRepPtr(listPtr);
+
listRepPtr->elemCount = elementCount*objc;
dataArray = &listRepPtr->elements;
}
@@ -2508,6 +2655,7 @@ Tcl_LrepeatObjCmd(
* number of times.
*/
+ CLANG_ASSERT(dataArray);
if (objc == 1) {
register Tcl_Obj *tmpPtr = objv[0];
@@ -2586,7 +2734,7 @@ Tcl_LreplaceObjCmd(
}
if (first < 0) {
- first = 0;
+ first = 0;
}
/*
@@ -2597,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;
}
@@ -2628,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.
@@ -2674,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) {
@@ -2682,15 +2832,15 @@ Tcl_LreverseObjCmd(
return TCL_OK;
}
- if (Tcl_IsShared(objv[1])) {
+ if (Tcl_IsShared(objv[1])
+ || (ListRepPtr(objv[1])->refCount > 1)) { /* Bug 1675044 */
Tcl_Obj *resultObj, **dataArray;
- List *listPtr;
+ List *listRepPtr;
- makeNewReversedList:
resultObj = Tcl_NewListObj(elemc, NULL);
- listPtr = (List *) resultObj->internalRep.twoPtrValue.ptr1;
- listPtr->elemCount = elemc;
- dataArray = &listPtr->elements;
+ listRepPtr = ListRepPtr(resultObj);
+ listRepPtr->elemCount = elemc;
+ dataArray = &listRepPtr->elements;
for (i=0,j=elemc-1 ; i<elemc ; i++,j--) {
dataArray[j] = elemv[i];
@@ -2699,15 +2849,6 @@ Tcl_LreverseObjCmd(
Tcl_SetObjResult(interp, resultObj);
} else {
- /*
- * It is theoretically possible for a list object to have a shared
- * internal representation, but be an unshared object. Check for this
- * and use the "shared" code if we have that problem. [Bug 1675044]
- */
-
- if (((List *) objv[1]->internalRep.twoPtrValue.ptr1)->refCount > 1) {
- goto makeNewReversedList;
- }
/*
* Not shared, so swap "in place". This relies on Tcl_LOGE above
@@ -2750,7 +2891,7 @@ Tcl_LsearchObjCmd(
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument values. */
{
- char *bytes, *patternBytes;
+ 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;
@@ -2759,7 +2900,7 @@ Tcl_LsearchObjCmd(
Tcl_Obj *patObj, **listv, *listPtr, *startPtr, *itemPtr;
SortStrCmpFn_t strCmpFn = strcmp;
Tcl_RegExp regexp = NULL;
- static const char *options[] = {
+ static const char *const options[] = {
"-all", "-ascii", "-bisect", "-decreasing", "-dictionary",
"-exact", "-glob", "-increasing", "-index",
"-inline", "-integer", "-nocase", "-not",
@@ -2812,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 */
@@ -2852,7 +2991,7 @@ Tcl_LsearchObjCmd(
dataType = INTEGER;
break;
case LSEARCH_NOCASE: /* -nocase */
- strCmpFn = strcasecmp;
+ strCmpFn = TclUtfCasecmp;
noCase = 1;
break;
case LSEARCH_NOT: /* -not */
@@ -2880,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]) {
@@ -2906,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;
}
@@ -2940,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);
}
/*
@@ -2953,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;
@@ -2974,14 +3112,18 @@ 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_AppendResult(interp,
- "-bisect is not compatible with -all or -not", NULL);
+ 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;
}
@@ -3011,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;
}
}
@@ -3028,10 +3168,7 @@ Tcl_LsearchObjCmd(
if (startPtr != NULL) {
Tcl_DecrRefCount(startPtr);
}
- if (sortInfo.indexc > 1) {
- ckfree((char *) sortInfo.indexv);
- }
- return result;
+ goto done;
}
/*
@@ -3042,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;
@@ -3058,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);
@@ -3080,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;
}
/*
@@ -3096,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;
}
/*
@@ -3137,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];
@@ -3157,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;
@@ -3173,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;
@@ -3246,15 +3366,13 @@ Tcl_LsearchObjCmd(
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 (mode) {
case SORTED:
case EXACT:
@@ -3268,7 +3386,7 @@ Tcl_LsearchObjCmd(
*/
if (noCase) {
- match = (strcasecmp(bytes, patternBytes) == 0);
+ match = (TclUtfCasecmp(bytes, patternBytes) == 0);
} else {
match = (memcmp(bytes, patternBytes,
(size_t) length) == 0);
@@ -3287,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;
@@ -3301,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;
@@ -3323,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;
}
@@ -3399,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;
}
/*
@@ -3442,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;
}
@@ -3450,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;
}
@@ -3519,13 +3631,20 @@ Tcl_LsortObjCmd(
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument values. */
{
- int i, j, index, unique, indices, length, nocase = 0, sortMode, indexc;
- int group, groupSize, groupOffset, idx;
+ 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", "-stride",
"-unique", NULL
@@ -3536,13 +3655,6 @@ Tcl_LsortObjCmd(
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, "?-option value ...? list");
return TCL_ERROR;
@@ -3560,29 +3672,29 @@ Tcl_LsortObjCmd(
sortInfo.interp = interp;
sortInfo.resultCode = TCL_OK;
cmdPtr = NULL;
- unique = 0;
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) {
- 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];
@@ -3598,54 +3710,41 @@ Tcl_LsortObjCmd(
sortInfo.isIncreasing = 1;
break;
case LSORT_INDEX: {
- Tcl_Obj **indices;
+ int indexc, dummy;
+ Tcl_Obj **indexv;
- 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;
- }
-
- /*
- * 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;
}
@@ -3659,35 +3758,31 @@ Tcl_LsortObjCmd(
sortInfo.sortMode = SORTMODE_REAL;
break;
case LSORT_UNIQUE:
- unique = 1;
sortInfo.unique = 1;
break;
case LSORT_INDICES:
indices = 1;
break;
case LSORT_STRIDE:
- if (i == (objc-2)) {
- if (sortInfo.indexc > 1) {
- ckfree((char *) sortInfo.indexv);
- }
- Tcl_AppendResult(interp,
- "\"-stride\" option must be followed by stride length",
- NULL);
- return TCL_ERROR;
+ 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) {
- if (sortInfo.indexc > 1) {
- ckfree((char *) sortInfo.indexv);
- }
- return TCL_ERROR;
+ sortInfo.resultCode = TCL_ERROR;
+ goto done2;
}
if (groupSize < 2) {
- if (sortInfo.indexc > 1) {
- ckfree((char *) sortInfo.indexv);
- }
- Tcl_AppendResult(interp, "stride length must be at least 2",
- NULL);
- return TCL_ERROR;
+ 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++;
@@ -3698,6 +3793,35 @@ Tcl_LsortObjCmd(
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) {
@@ -3712,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;
}
/*
@@ -3732,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;
@@ -3754,8 +3874,10 @@ Tcl_LsortObjCmd(
if (group) {
if (length % groupSize) {
- Tcl_AppendResult(interp,
+ 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;
@@ -3772,9 +3894,11 @@ Tcl_LsortObjCmd(
groupOffset = (groupOffset - SORTIDX_END) + groupSize - 1;
}
if (groupOffset < 0 || groupOffset >= groupSize) {
- Tcl_AppendResult(interp, "when used with \"-stride\", the "
- "leading \"-index\" value must be within the group",
- NULL);
+ 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;
}
@@ -3782,15 +3906,16 @@ Tcl_LsortObjCmd(
sortInfo.indexc = 0;
sortInfo.indexv = NULL;
} else {
- int *new_indexv;
-
sortInfo.indexc--;
- new_indexv = (int *) ckalloc(sizeof(int) * 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++) {
- new_indexv[i] = sortInfo.indexv[i+1];
+ sortInfo.indexv[i] = sortInfo.indexv[i+1];
}
- ckfree((char *) sortInfo.indexv);
- sortInfo.indexv = new_indexv;
}
}
}
@@ -3823,7 +3948,7 @@ 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;
@@ -3844,7 +3969,7 @@ Tcl_LsortObjCmd(
*/
if (sortMode == SORTMODE_ASCII) {
- elementArray[i].index.strValuePtr = TclGetString(indexPtr);
+ elementArray[i].collationKey.strValuePtr = TclGetString(indexPtr);
} else if (sortMode == SORTMODE_INTEGER) {
long a;
@@ -3852,17 +3977,18 @@ Tcl_LsortObjCmd(
sortInfo.resultCode = TCL_ERROR;
goto done1;
}
- elementArray[i].index.intValue = a;
- } else if (sortInfo.sortMode == SORTMODE_REAL) {
+ 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;
}
/*
@@ -3871,9 +3997,9 @@ Tcl_LsortObjCmd(
*/
if (indices || group) {
- elementArray[i].objPtr = INT2PTR(idx);
+ elementArray[i].payload.index = idx;
} else {
- elementArray[i].objPtr = listObjPtrs[idx];
+ elementArray[i].payload.objPtr = listObjPtrs[idx];
}
/*
@@ -3909,14 +4035,13 @@ Tcl_LsortObjCmd(
if (sortInfo.resultCode == TCL_OK) {
List *listRepPtr;
Tcl_Obj **newArray, *objPtr;
- int i;
resultPtr = Tcl_NewListObj(sortInfo.numElements * groupSize, NULL);
- listRepPtr = resultPtr->internalRep.twoPtrValue.ptr1;
+ listRepPtr = ListRepPtr(resultPtr);
newArray = &listRepPtr->elements;
if (group) {
for (i=0; elementPtr!=NULL ; elementPtr=elementPtr->nextPtr) {
- idx = PTR2INT(elementPtr->objPtr);
+ idx = elementPtr->payload.index;
for (j = 0; j < groupSize; j++) {
if (indices) {
objPtr = Tcl_NewIntObj(idx + j - groupOffset);
@@ -3931,13 +4056,13 @@ Tcl_LsortObjCmd(
}
} else if (indices) {
for (i=0; elementPtr != NULL ; elementPtr = elementPtr->nextPtr) {
- objPtr = Tcl_NewIntObj(PTR2INT(elementPtr->objPtr));
+ objPtr = Tcl_NewIntObj(elementPtr->payload.index);
newArray[i++] = objPtr;
Tcl_IncrRefCount(objPtr);
}
} else {
for (i=0; elementPtr != NULL ; elementPtr = elementPtr->nextPtr) {
- objPtr = elementPtr->objPtr;
+ objPtr = elementPtr->payload.objPtr;
newArray[i++] = objPtr;
Tcl_IncrRefCount(objPtr);
}
@@ -3947,16 +4072,17 @@ Tcl_LsortObjCmd(
}
done1:
- ckfree((char *) elementArray);
+ TclStackFree(interp, elementArray);
done:
- if (sortInfo.sortMode == SORTMODE_COMMAND) {
+ if (sortMode == SORTMODE_COMMAND) {
TclDecrRefCount(sortInfo.compareCmdPtr);
TclDecrRefCount(listObj);
sortInfo.compareCmdPtr = NULL;
}
- if (sortInfo.indexc > 1) {
- ckfree((char *) sortInfo.indexv);
+ done2:
+ if (allocatedIndexVector) {
+ TclStackFree(interp, sortInfo.indexv);
}
return sortInfo.resultCode;
}
@@ -3982,12 +4108,14 @@ Tcl_LsortObjCmd(
* "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.
+ *
*----------------------------------------------------------------------
*/
@@ -4089,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 = strcasecmp(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];
@@ -4124,8 +4252,8 @@ SortCompare(
}
- objPtr1 = elemPtr1->index.objValuePtr;
- objPtr2 = elemPtr2->index.objValuePtr;
+ objPtr1 = elemPtr1->collationKey.objValuePtr;
+ objPtr2 = elemPtr2->collationKey.objValuePtr;
paramObjv[0] = objPtr1;
paramObjv[1] = objPtr2;
@@ -4144,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;
}
@@ -4155,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;
}
@@ -4194,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;
@@ -4211,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++;
}
@@ -4368,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;
}
@@ -4387,5 +4514,6 @@ SelectObjFromSublist(
* mode: c
* c-basic-offset: 4
* fill-column: 78
+ * tab-width: 8
* End:
*/
generated by cgit v0.12 at 2025-10-29 20:22:55 (GMT)