summaryrefslogtreecommitdiffstats
path: root/generic/tclCmdIL.c
diff options
context:
space:
mode:
Diffstat (limited to 'generic/tclCmdIL.c')
-rw-r--r--generic/tclCmdIL.c531
1 files changed, 288 insertions, 243 deletions
diff --git a/generic/tclCmdIL.c b/generic/tclCmdIL.c
index b38ec9f..41c1eb6 100644
--- a/generic/tclCmdIL.c
+++ b/generic/tclCmdIL.c
@@ -27,15 +27,15 @@
*/
typedef struct SortElement {
- union { /* The value that we sorting by. */
+ union { /* The value that we sorting by. */
const char *strValuePtr;
long intValue;
double doubleValue;
Tcl_Obj *objValuePtr;
} collationKey;
- union { /* Object being sorted, or its index. */
- Tcl_Obj *objPtr;
- int index;
+ 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. */
@@ -161,30 +161,30 @@ static Tcl_Obj * SelectObjFromSublist(Tcl_Obj *firstPtr,
*/
static const EnsembleImplMap defaultInfoMap[] = {
- {"args", InfoArgsCmd, NULL, NULL, NULL, 0},
- {"body", InfoBodyCmd, NULL, NULL, NULL, 0},
- {"cmdcount", InfoCmdCountCmd, NULL, NULL, NULL, 0},
- {"commands", InfoCommandsCmd, NULL, NULL, NULL, 0},
- {"complete", InfoCompleteCmd, NULL, NULL, NULL, 0},
- {"coroutine", TclInfoCoroutineCmd, NULL, NULL, NULL, 0},
- {"default", InfoDefaultCmd, NULL, NULL, NULL, 0},
- {"errorstack", InfoErrorStackCmd, NULL, NULL, NULL, 0},
+ {"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, NULL, NULL, NULL, 0},
- {"functions", InfoFunctionsCmd, NULL, NULL, NULL, 0},
- {"globals", TclInfoGlobalsCmd, NULL, NULL, NULL, 0},
- {"hostname", InfoHostnameCmd, NULL, NULL, NULL, 0},
- {"level", InfoLevelCmd, NULL, NULL, NULL, 0},
- {"library", InfoLibraryCmd, NULL, NULL, NULL, 0},
- {"loaded", InfoLoadedCmd, NULL, NULL, NULL, 0},
- {"locals", TclInfoLocalsCmd, NULL, NULL, NULL, 0},
- {"nameofexecutable", InfoNameOfExecutableCmd, NULL, NULL, NULL, 0},
- {"patchlevel", InfoPatchLevelCmd, NULL, NULL, NULL, 0},
- {"procs", InfoProcsCmd, NULL, NULL, NULL, 0},
- {"script", InfoScriptCmd, NULL, NULL, NULL, 0},
- {"sharedlibextension", InfoSharedlibCmd, NULL, NULL, NULL, 0},
- {"tclversion", InfoTclVersionCmd, NULL, NULL, NULL, 0},
- {"vars", TclInfoVarsCmd, NULL, 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}
};
@@ -229,8 +229,9 @@ TclNRIfObjCmd(
Tcl_Obj *boolObj;
if (objc <= 1) {
- Tcl_AppendResult(interp, "wrong # args: no expression after \"",
- TclGetString(objv[0]), "\" argument", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "wrong # args: no expression after \"%s\" argument",
+ TclGetString(objv[0])));
Tcl_SetErrorCode(interp, "TCL", "WRONGARGS", NULL);
return TCL_ERROR;
}
@@ -319,8 +320,9 @@ IfConditionCallback(
*/
if (i >= objc) {
- Tcl_AppendResult(interp, "wrong # args: ",
- "no expression after \"", clause, "\" argument", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "wrong # args: no expression after \"%s\" argument",
+ clause));
Tcl_SetErrorCode(interp, "TCL", "WRONGARGS", NULL);
return TCL_ERROR;
}
@@ -345,8 +347,9 @@ IfConditionCallback(
}
}
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;
}
@@ -361,9 +364,9 @@ IfConditionCallback(
return TclNREvalObjEx(interp, objv[i], 0, iPtr->cmdFramePtr, i);
missingScript:
- clause = TclGetString(objv[i-1]);
- Tcl_AppendResult(interp, "wrong # args: no script following \"", clause,
- "\" argument", NULL);
+ 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;
}
@@ -491,7 +494,8 @@ 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;
}
@@ -552,7 +556,8 @@ 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;
}
@@ -966,7 +971,7 @@ InfoDefaultCmd(
Tcl_Obj *const objv[]) /* Argument objects. */
{
Interp *iPtr = (Interp *) interp;
- const char *procName, *argName, *varName;
+ const char *procName, *argName;
Proc *procPtr;
CompiledLocal *localPtr;
Tcl_Obj *valueObjPtr;
@@ -981,7 +986,8 @@ 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;
@@ -993,18 +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));
}
@@ -1012,16 +1018,11 @@ 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;
-
- defStoreError:
- varName = TclGetString(objv[3]);
- Tcl_AppendResult(interp, "couldn't store default value in variable \"",
- varName, "\"", NULL);
- return TCL_ERROR;
}
/*
@@ -1058,18 +1059,18 @@ InfoErrorStackCmd(
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;
- }
+ 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;
}
@@ -1146,32 +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 AND the cmdFrame chain,
- * which is interrupted at the base.
- */
+ while (corPtr) {
+ while (*cmdFramePtrPtr) {
+ topLevel++;
+ cmdFramePtrPtr = &((*cmdFramePtrPtr)->nextPtr);
+ }
+ if (corPtr->caller.cmdFramePtr) {
+ *cmdFramePtrPtr = corPtr->caller.cmdFramePtr;
+ }
+ corPtr = corPtr->callerEEPtr->corPtr;
+ }
+ topLevel += (*cmdFramePtrPtr)->level;
- CoroutineData *corPtr = iPtr->execEnvPtr->corPtr;
- CmdFrame *runPtr = iPtr->cmdFramePtr;
- CmdFrame *lastPtr = NULL;
-
- topLevel += corPtr->caller.cmdFramePtr->level;
- while (runPtr && (runPtr != corPtr->caller.cmdFramePtr)) {
- lastPtr = runPtr;
- runPtr = runPtr->nextPtr;
- }
- if (lastPtr && !runPtr) {
- lastPtr->nextPtr = corPtr->caller.cmdFramePtr;
- }
+ 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) {
@@ -1180,10 +1187,7 @@ InfoFrameCmd(
*/
Tcl_SetObjResult(interp, Tcl_NewIntObj(topLevel));
- return TCL_OK;
- } else if (objc != 2) {
- Tcl_WrongNumArgs(interp, 1, objv, "?number?");
- return TCL_ERROR;
+ goto done;
}
/*
@@ -1191,16 +1195,18 @@ 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);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "bad level \"%s\"", TclGetString(objv[1])));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "STACK_FRAME",
TclGetString(objv[1]), NULL);
- return TCL_ERROR;
+ code = TCL_ERROR;
+ goto done;
}
/*
@@ -1220,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;
}
/*
@@ -1276,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:
@@ -1345,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;
}
@@ -1365,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:
@@ -1383,15 +1395,15 @@ TclInfoFrame(
Tcl_HashEntry *namePtr = procPtr->cmdPtr->hPtr;
if (namePtr) {
- Tcl_Obj *procNameObj;
+ Tcl_Obj *procNameObj;
/*
* This is a regular command.
*/
- TclNewObj(procNameObj);
- Tcl_GetCommandFullName(interp, (Tcl_Command) procPtr->cmdPtr,
- procNameObj);
+ TclNewObj(procNameObj);
+ Tcl_GetCommandFullName(interp, (Tcl_Command) procPtr->cmdPtr,
+ procNameObj);
ADD_PAIR("proc", procNameObj);
} else if (procPtr->cmdPtr->clientData) {
ExtraFrameInfo *efiPtr = procPtr->cmdPtr->clientData;
@@ -1466,19 +1478,42 @@ InfoFunctionsCmd(
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
- const 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;
}
/*
@@ -1520,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;
}
@@ -1590,8 +1628,8 @@ 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;
@@ -1637,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;
}
@@ -1670,7 +1711,6 @@ InfoLoadedCmd(
Tcl_Obj *const objv[]) /* Argument objects. */
{
const char *interpName;
- int result;
if ((objc != 1) && (objc != 2)) {
Tcl_WrongNumArgs(interp, 1, objv, "?interp?");
@@ -1682,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);
}
/*
@@ -2267,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;
}
/*
@@ -2385,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;
}
@@ -2506,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.
@@ -2572,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;
}
@@ -2584,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
@@ -2608,7 +2642,7 @@ 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;
@@ -2711,8 +2745,10 @@ 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) {
@@ -2796,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 = 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];
@@ -2813,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
@@ -2964,7 +2991,7 @@ Tcl_LsearchObjCmd(
dataType = INTEGER;
break;
case LSEARCH_NOCASE: /* -nocase */
- strCmpFn = strcasecmp;
+ strCmpFn = TclUtfCasecmp;
noCase = 1;
break;
case LSEARCH_NOT: /* -not */
@@ -2992,7 +3019,9 @@ Tcl_LsearchObjCmd(
Tcl_DecrRefCount(startPtr);
}
if (i > objc-4) {
- Tcl_AppendResult(interp, "missing starting index", NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "missing starting index", -1));
+ Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "MISSING", NULL);
result = TCL_ERROR;
goto done;
}
@@ -3022,9 +3051,10 @@ Tcl_LsearchObjCmd(
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;
}
@@ -3082,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;
}
@@ -3352,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);
@@ -3521,7 +3555,7 @@ Tcl_LsetObjCmd(
if (objc < 3) {
Tcl_WrongNumArgs(interp, 1, objv,
- "listVar ?index? ?index ...? value");
+ "listVar ?index? ?index ...? value");
return TCL_ERROR;
}
@@ -3597,7 +3631,8 @@ Tcl_LsortObjCmd(
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument values. */
{
- int i, j, index, indices, length, nocase = 0, sortMode, indexc;
+ 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;
@@ -3654,9 +3689,10 @@ Tcl_LsortObjCmd(
break;
case LSORT_COMMAND:
if (i == objc-2) {
- Tcl_AppendResult(interp,
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
"\"-command\" option must be followed "
- "by comparison command", NULL);
+ "by comparison command", -1));
+ Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "MISSING", NULL);
sortInfo.resultCode = TCL_ERROR;
goto done2;
}
@@ -3674,28 +3710,30 @@ Tcl_LsortObjCmd(
sortInfo.isIncreasing = 1;
break;
case LSORT_INDEX: {
- int indexc, dummy;
+ int indexc, dummy;
Tcl_Obj **indexv;
if (i == objc-2) {
- Tcl_AppendResult(interp, "\"-index\" option must be "
- "followed by list index", NULL);
- sortInfo.resultCode = TCL_ERROR;
- goto done2;
+ 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;
}
if (TclListObjGetElements(interp, objv[i+1], &indexc,
&indexv) != TCL_OK) {
- sortInfo.resultCode = TCL_ERROR;
- goto done2;
+ sortInfo.resultCode = TCL_ERROR;
+ goto done2;
}
- /*
- * 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.
- */
+ /*
+ * 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<indexc ; j++) {
if (TclGetIntForIndexM(interp, indexv[j], SORTIDX_END,
@@ -3707,7 +3745,7 @@ Tcl_LsortObjCmd(
}
}
indexPtr = objv[i+1];
- i++;
+ i++;
break;
}
case LSORT_INTEGER:
@@ -3727,8 +3765,10 @@ Tcl_LsortObjCmd(
break;
case LSORT_STRIDE:
if (i == objc-2) {
- Tcl_AppendResult(interp, "\"-stride\" option must be ",
- "followed by stride length", NULL);
+ 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;
}
@@ -3737,8 +3777,10 @@ Tcl_LsortObjCmd(
goto done2;
}
if (groupSize < 2) {
- Tcl_AppendResult(interp, "stride length must be at least 2",
- NULL);
+ 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;
}
@@ -3758,26 +3800,26 @@ Tcl_LsortObjCmd(
*/
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 =
+ 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,
+ 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];
@@ -3832,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;
@@ -3850,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;
}
@@ -3932,7 +3978,7 @@ Tcl_LsortObjCmd(
goto done1;
}
elementArray[i].collationKey.intValue = a;
- } else if (sortInfo.sortMode == SORTMODE_REAL) {
+ } else if (sortMode == SORTMODE_REAL) {
double a;
if (Tcl_GetDoubleFromObj(sortInfo.interp, indexPtr,
@@ -3991,7 +4037,7 @@ Tcl_LsortObjCmd(
Tcl_Obj **newArray, *objPtr;
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) {
@@ -4029,7 +4075,7 @@ Tcl_LsortObjCmd(
TclStackFree(interp, elementArray);
done:
- if (sortInfo.sortMode == SORTMODE_COMMAND) {
+ if (sortMode == SORTMODE_COMMAND) {
TclDecrRefCount(sortInfo.compareCmdPtr);
TclDecrRefCount(listObj);
sortInfo.compareCmdPtr = NULL;
@@ -4174,7 +4220,7 @@ SortCompare(
order = strcmp(elemPtr1->collationKey.strValuePtr,
elemPtr2->collationKey.strValuePtr);
} else if (infoPtr->sortMode == SORTMODE_ASCII_NC) {
- order = strcasecmp(elemPtr1->collationKey.strValuePtr,
+ order = TclUtfCasecmp(elemPtr1->collationKey.strValuePtr,
elemPtr2->collationKey.strValuePtr);
} else if (infoPtr->sortMode == SORTMODE_DICTIONARY) {
order = DictionaryCompare(elemPtr1->collationKey.strValuePtr,
@@ -4236,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;
}
@@ -4449,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;
}
@@ -4469,6 +4515,5 @@ SelectObjFromSublist(
* c-basic-offset: 4
* fill-column: 78
* tab-width: 8
- * indent-tabs-mode: nil
* End:
*/
generated by cgit v0.12 at 2025-10-23 09:49:33 (GMT)