summaryrefslogtreecommitdiffstats
path: root/generic/tclTest.c
diff options
context:
space:
mode:
Diffstat (limited to 'generic/tclTest.c')
-rw-r--r--generic/tclTest.c255
1 files changed, 45 insertions, 210 deletions
diff --git a/generic/tclTest.c b/generic/tclTest.c
index ebd90ae..fe68d51 100644
--- a/generic/tclTest.c
+++ b/generic/tclTest.c
@@ -302,14 +302,6 @@ static int TestlinkCmd(ClientData dummy,
static int TestlocaleCmd(ClientData dummy,
Tcl_Interp *interp, int objc,
Tcl_Obj *const objv[]);
-#ifndef TCL_NO_DEPRECATED
-static int TestMathFunc(ClientData clientData,
- Tcl_Interp *interp, Tcl_Value *args,
- Tcl_Value *resultPtr);
-static int TestMathFunc2(ClientData clientData,
- Tcl_Interp *interp, Tcl_Value *args,
- Tcl_Value *resultPtr);
-#endif /* TCL_NO_DEPRECATED */
static int TestmainthreadCmd(ClientData dummy,
Tcl_Interp *interp, int argc, const char **argv);
static int TestsetmainloopCmd(ClientData dummy,
@@ -546,10 +538,6 @@ int
Tcltest_Init(
Tcl_Interp *interp) /* Interpreter for application. */
{
-#ifndef TCL_NO_DEPRECATED
- Tcl_ValueType t3ArgTypes[2];
-#endif /* TCL_NO_DEPRECATED */
-
Tcl_Obj *listPtr;
Tcl_Obj **objv;
int objc, index;
@@ -697,10 +685,7 @@ Tcltest_Init(
Tcl_CreateCommand(interp, "testtranslatefilename",
TesttranslatefilenameCmd, NULL, NULL);
Tcl_CreateCommand(interp, "testupvar", TestupvarCmd, NULL, NULL);
-#ifndef TCL_NO_DEPRECATED
- Tcl_CreateMathFunc(interp, "T1", 0, NULL, TestMathFunc, (ClientData) 123);
- Tcl_CreateMathFunc(interp, "T2", 0, NULL, TestMathFunc, (ClientData) 345);
-#endif /* TCL_NO_DEPRECATED */
+
Tcl_CreateCommand(interp, "testmainthread", TestmainthreadCmd, NULL,
NULL);
Tcl_CreateCommand(interp, "testsetmainloop", TestsetmainloopCmd,
@@ -711,12 +696,6 @@ Tcltest_Init(
Tcl_CreateObjCommand(interp, "testcpuid", TestcpuidCmd,
(ClientData) 0, NULL);
#endif
-#ifndef TCL_NO_DEPRECATED
- t3ArgTypes[0] = TCL_EITHER;
- t3ArgTypes[1] = TCL_EITHER;
- Tcl_CreateMathFunc(interp, "T3", 2, t3ArgTypes, TestMathFunc2,
- NULL);
-#endif /* TCL_NO_DEPRECATED */
Tcl_CreateObjCommand(interp, "testnreunwind", TestNREUnwind,
NULL, NULL);
@@ -746,8 +725,8 @@ Tcltest_Init(
if (Tcl_ListObjGetElements(interp, listPtr, &objc, &objv) != TCL_OK) {
return TCL_ERROR;
}
- if (objc && (Tcl_GetIndexFromObj(NULL, objv[0], specialOptions, NULL,
- TCL_EXACT, &index) == TCL_OK)) {
+ if (objc && (Tcl_GetIndexFromObjStruct(NULL, objv[0], specialOptions,
+ sizeof(char *), NULL, TCL_EXACT, &index) == TCL_OK)) {
switch (index) {
case 0:
return TCL_ERROR;
@@ -855,7 +834,7 @@ TestasyncCmd(
asyncPtr->nextPtr = firstHandler;
firstHandler = asyncPtr;
Tcl_MutexUnlock(&asyncTestMutex);
- Tcl_SetObjResult(interp, Tcl_NewIntObj(asyncPtr->id));
+ Tcl_SetObjResult(interp, Tcl_NewLongObj(asyncPtr->id));
} else if (strcmp(argv[1], "delete") == 0) {
if (argc == 2) {
Tcl_MutexLock(&asyncTestMutex);
@@ -1109,9 +1088,9 @@ TestcmdinfoCmd(
info.deleteProc = CmdDelProc2;
info.deleteData = (ClientData) "new_delete_data";
if (Tcl_SetCommandInfo(interp, argv[2], &info) == 0) {
- Tcl_SetObjResult(interp, Tcl_NewIntObj(0));
+ Tcl_SetObjResult(interp, Tcl_NewLongObj(0));
} else {
- Tcl_SetObjResult(interp, Tcl_NewIntObj(1));
+ Tcl_SetObjResult(interp, Tcl_NewLongObj(1));
}
} else {
Tcl_AppendResult(interp, "bad option \"", argv[1],
@@ -1759,8 +1738,8 @@ TestdoubledigitsObjCmd(ClientData unused,
}
if (status != TCL_OK
|| Tcl_GetIntFromObj(interp, objv[2], &ndigits) != TCL_OK
- || Tcl_GetIndexFromObj(interp, objv[3], options, "conversion type",
- TCL_EXACT, &type) != TCL_OK) {
+ || Tcl_GetIndexFromObjStruct(interp, objv[3], options,
+ sizeof(char *), "conversion type", TCL_EXACT, &type) != TCL_OK) {
fprintf(stderr, "bad value? %g\n", d);
return TCL_ERROR;
}
@@ -1776,7 +1755,7 @@ TestdoubledigitsObjCmd(ClientData unused,
strObj = Tcl_NewStringObj(str, endPtr-str);
ckfree(str);
retval = Tcl_NewListObj(1, &strObj);
- Tcl_ListObjAppendElement(NULL, retval, Tcl_NewIntObj(decpt));
+ Tcl_ListObjAppendElement(NULL, retval, Tcl_NewLongObj(decpt));
strObj = Tcl_NewStringObj(signum ? "-" : "+", 1);
Tcl_ListObjAppendElement(NULL, retval, strObj);
Tcl_SetObjResult(interp, retval);
@@ -1871,7 +1850,7 @@ TestdstringCmd(
if (argc != 2) {
goto wrongNumArgs;
}
- Tcl_SetObjResult(interp, Tcl_NewIntObj(Tcl_DStringLength(&dstring)));
+ Tcl_SetObjResult(interp, Tcl_NewLongObj(Tcl_DStringLength(&dstring)));
} else if (strcmp(argv[1], "result") == 0) {
if (argc != 2) {
goto wrongNumArgs;
@@ -1946,8 +1925,8 @@ TestencodingObjCmd(
ENC_CREATE, ENC_DELETE
};
- if (Tcl_GetIndexFromObj(interp, objv[1], optionStrings, "option", 0,
- &index) != TCL_OK) {
+ if (Tcl_GetIndexFromObjStruct(interp, objv[1], optionStrings,
+ sizeof(char *), "option", 0, &index) != TCL_OK) {
return TCL_ERROR;
}
@@ -2206,8 +2185,8 @@ TesteventObjCmd(
Tcl_WrongNumArgs(interp, 1, objv, "subcommand ?arg ...?");
return TCL_ERROR;
}
- if (Tcl_GetIndexFromObj(interp, objv[1], subcommands, "subcommand",
- TCL_EXACT, &subCmdIndex) != TCL_OK) {
+ if (Tcl_GetIndexFromObjStruct(interp, objv[1], subcommands,
+ sizeof(char *), "subcommand", TCL_EXACT, &subCmdIndex) != TCL_OK) {
return TCL_ERROR;
}
switch (subCmdIndex) {
@@ -2216,8 +2195,8 @@ TesteventObjCmd(
Tcl_WrongNumArgs(interp, 2, objv, "name position script");
return TCL_ERROR;
}
- if (Tcl_GetIndexFromObj(interp, objv[3], positions,
- "position specifier", TCL_EXACT, &posIndex) != TCL_OK) {
+ if (Tcl_GetIndexFromObjStruct(interp, objv[3], positions,
+ sizeof(char *), "position specifier", TCL_EXACT, &posIndex) != TCL_OK) {
return TCL_ERROR;
}
ev = ckalloc(sizeof(TestEvent));
@@ -3320,8 +3299,8 @@ TestlocaleCmd(
return TCL_ERROR;
}
- if (Tcl_GetIndexFromObj(interp, objv[1], optionStrings, "option", 0,
- &index) != TCL_OK) {
+ if (Tcl_GetIndexFromObjStruct(interp, objv[1], optionStrings,
+ sizeof(char *), "option", 0, &index) != TCL_OK) {
return TCL_ERROR;
}
@@ -3340,146 +3319,6 @@ TestlocaleCmd(
/*
*----------------------------------------------------------------------
*
- * TestMathFunc --
- *
- * This is a user-defined math procedure to test out math procedures
- * with no arguments.
- *
- * Results:
- * A normal Tcl completion code.
- *
- * Side effects:
- * None.
- *
- *----------------------------------------------------------------------
- */
-
- /* ARGSUSED */
-#ifndef TCL_NO_DEPRECATED
-static int
-TestMathFunc(
- ClientData clientData, /* Integer value to return. */
- Tcl_Interp *interp, /* Not used. */
- Tcl_Value *args, /* Not used. */
- Tcl_Value *resultPtr) /* Where to store result. */
-{
- resultPtr->type = TCL_INT;
- resultPtr->intValue = PTR2INT(clientData);
- return TCL_OK;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * TestMathFunc2 --
- *
- * This is a user-defined math procedure to test out math procedures
- * that do have arguments, in this case 2.
- *
- * Results:
- * A normal Tcl completion code.
- *
- * Side effects:
- * None.
- *
- *----------------------------------------------------------------------
- */
-
- /* ARGSUSED */
-static int
-TestMathFunc2(
- ClientData clientData, /* Integer value to return. */
- Tcl_Interp *interp, /* Used to report errors. */
- Tcl_Value *args, /* Points to an array of two Tcl_Value structs
- * for the two arguments. */
- Tcl_Value *resultPtr) /* Where to store the result. */
-{
- int result = TCL_OK;
-
- /*
- * Return the maximum of the two arguments with the correct type.
- */
-
- if (args[0].type == TCL_INT) {
- int i0 = args[0].intValue;
-
- if (args[1].type == TCL_INT) {
- int i1 = args[1].intValue;
-
- resultPtr->type = TCL_INT;
- resultPtr->intValue = ((i0 > i1)? i0 : i1);
- } else if (args[1].type == TCL_DOUBLE) {
- double d0 = i0;
- double d1 = args[1].doubleValue;
-
- resultPtr->type = TCL_DOUBLE;
- resultPtr->doubleValue = ((d0 > d1)? d0 : d1);
- } else if (args[1].type == TCL_WIDE_INT) {
- Tcl_WideInt w0 = Tcl_LongAsWide(i0);
- Tcl_WideInt w1 = args[1].wideValue;
-
- resultPtr->type = TCL_WIDE_INT;
- resultPtr->wideValue = ((w0 > w1)? w0 : w1);
- } else {
- Tcl_AppendResult(interp, "T3: wrong type for arg 2", NULL);
- result = TCL_ERROR;
- }
- } else if (args[0].type == TCL_DOUBLE) {
- double d0 = args[0].doubleValue;
-
- if (args[1].type == TCL_INT) {
- double d1 = args[1].intValue;
-
- resultPtr->type = TCL_DOUBLE;
- resultPtr->doubleValue = ((d0 > d1)? d0 : d1);
- } else if (args[1].type == TCL_DOUBLE) {
- double d1 = args[1].doubleValue;
-
- resultPtr->type = TCL_DOUBLE;
- resultPtr->doubleValue = ((d0 > d1)? d0 : d1);
- } else if (args[1].type == TCL_WIDE_INT) {
- double d1 = Tcl_WideAsDouble(args[1].wideValue);
-
- resultPtr->type = TCL_DOUBLE;
- resultPtr->doubleValue = ((d0 > d1)? d0 : d1);
- } else {
- Tcl_AppendResult(interp, "T3: wrong type for arg 2", NULL);
- result = TCL_ERROR;
- }
- } else if (args[0].type == TCL_WIDE_INT) {
- Tcl_WideInt w0 = args[0].wideValue;
-
- if (args[1].type == TCL_INT) {
- Tcl_WideInt w1 = Tcl_LongAsWide(args[1].intValue);
-
- resultPtr->type = TCL_WIDE_INT;
- resultPtr->wideValue = ((w0 > w1)? w0 : w1);
- } else if (args[1].type == TCL_DOUBLE) {
- double d0 = Tcl_WideAsDouble(w0);
- double d1 = args[1].doubleValue;
-
- resultPtr->type = TCL_DOUBLE;
- resultPtr->doubleValue = ((d0 > d1)? d0 : d1);
- } else if (args[1].type == TCL_WIDE_INT) {
- Tcl_WideInt w1 = args[1].wideValue;
-
- resultPtr->type = TCL_WIDE_INT;
- resultPtr->wideValue = ((w0 > w1)? w0 : w1);
- } else {
- Tcl_AppendResult(interp, "T3: wrong type for arg 2", NULL);
- result = TCL_ERROR;
- }
- } else {
- Tcl_AppendResult(interp, "T3: wrong type for arg 1", NULL);
- result = TCL_ERROR;
- }
- return result;
-}
-#endif /* TCL_NO_DEPRECATED */
-
-/*
- *----------------------------------------------------------------------
- *
* CleanupTestSetassocdataTests --
*
* This function is called when an interpreter is deleted to clean
@@ -3658,7 +3497,7 @@ PrintParse(
Tcl_ListObjAppendElement(NULL, objPtr,
Tcl_NewStringObj(parsePtr->commandStart, parsePtr->commandSize));
Tcl_ListObjAppendElement(NULL, objPtr,
- Tcl_NewIntObj(parsePtr->numWords));
+ Tcl_NewLongObj(parsePtr->numWords));
for (i = 0; i < parsePtr->numTokens; i++) {
tokenPtr = &parsePtr->tokenPtr[i];
switch (tokenPtr->type) {
@@ -3698,7 +3537,7 @@ PrintParse(
Tcl_ListObjAppendElement(NULL, objPtr,
Tcl_NewStringObj(tokenPtr->start, tokenPtr->size));
Tcl_ListObjAppendElement(NULL, objPtr,
- Tcl_NewIntObj(tokenPtr->numComponents));
+ Tcl_NewLongObj(tokenPtr->numComponents));
}
Tcl_ListObjAppendElement(NULL, objPtr,
Tcl_NewStringObj(parsePtr->commandStart + parsePtr->commandSize,
@@ -3937,8 +3776,8 @@ TestregexpObjCmd(
if (name[0] != '-') {
break;
}
- if (Tcl_GetIndexFromObj(interp, objv[i], options, "switch", TCL_EXACT,
- &index) != TCL_OK) {
+ if (Tcl_GetIndexFromObjStruct(interp, objv[i], options,
+ sizeof(char *), "switch", TCL_EXACT, &index) != TCL_OK) {
return TCL_ERROR;
}
switch ((enum options) index) {
@@ -4013,7 +3852,7 @@ TestregexpObjCmd(
* value 0.
*/
- Tcl_SetIntObj(Tcl_GetObjResult(interp), 0);
+ Tcl_SetLongObj(Tcl_GetObjResult(interp), 0);
if (objc > 2 && (cflags&REG_EXPECT) && indices) {
const char *varName;
const char *value;
@@ -4109,7 +3948,7 @@ TestregexpObjCmd(
* Set the interpreter's object result to an integer object w/ value 1.
*/
- Tcl_SetIntObj(Tcl_GetObjResult(interp), 1);
+ Tcl_SetLongObj(Tcl_GetObjResult(interp), 1);
return TCL_OK;
}
@@ -5187,7 +5026,6 @@ TestsaveresultCmd(
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* The argument objects. */
{
- Interp* iPtr = (Interp*) interp;
int discard, result, index;
Tcl_SavedResult state;
Tcl_Obj *objPtr;
@@ -5206,8 +5044,8 @@ TestsaveresultCmd(
Tcl_WrongNumArgs(interp, 1, objv, "type script discard");
return TCL_ERROR;
}
- if (Tcl_GetIndexFromObj(interp, objv[1], optionStrings, "option", 0,
- &index) != TCL_OK) {
+ if (Tcl_GetIndexFromObjStruct(interp, objv[1], optionStrings,
+ sizeof(char *), "option", 0, &index) != TCL_OK) {
return TCL_ERROR;
}
if (Tcl_GetBooleanFromObj(interp, objv[3], &discard) != TCL_OK) {
@@ -5255,12 +5093,9 @@ TestsaveresultCmd(
}
switch ((enum options) index) {
- case RESULT_DYNAMIC: {
- int presentOrFreed = (iPtr->freeProc == TestsaveresultFree) ^ freeCount;
-
- Tcl_AppendElement(interp, presentOrFreed ? "presentOrFreed" : "missingOrLeak");
+ case RESULT_DYNAMIC:
+ Tcl_AppendElement(interp, freeCount ? "freed" : "leak");
break;
- }
case RESULT_OBJECT:
Tcl_AppendElement(interp, Tcl_GetObjResult(interp) == objPtr
? "same" : "different");
@@ -6839,7 +6674,7 @@ TestNumUtfCharsCmd(
(void) Tcl_GetIntFromObj(interp, objv[2], &len);
}
len = Tcl_NumUtfChars(Tcl_GetString(objv[1]), len);
- Tcl_SetObjResult(interp, Tcl_NewIntObj(len));
+ Tcl_SetObjResult(interp, Tcl_NewLongObj(len));
}
return TCL_OK;
}
@@ -6893,7 +6728,7 @@ TestcpuidCmd(
return status;
}
for (i=0 ; i<4 ; ++i) {
- regsObjs[i] = Tcl_NewIntObj(regs[i]);
+ regsObjs[i] = Tcl_NewLongObj(regs[i]);
}
Tcl_SetObjResult(interp, Tcl_NewListObj(4, regsObjs));
return TCL_OK;
@@ -6934,7 +6769,7 @@ TestHashSystemHashCmd(
for (i=0 ; i<limit ; i++) {
hPtr = Tcl_CreateHashEntry(&hash, INT2PTR(i), &isNew);
if (!isNew) {
- Tcl_SetObjResult(interp, Tcl_NewIntObj(i));
+ Tcl_SetObjResult(interp, Tcl_NewLongObj(i));
Tcl_AppendToObj(Tcl_GetObjResult(interp)," creation problem",-1);
Tcl_DeleteHashTable(&hash);
return TCL_ERROR;
@@ -6942,7 +6777,7 @@ TestHashSystemHashCmd(
Tcl_SetHashValue(hPtr, INT2PTR(i+42));
}
- if (hash.numEntries != limit) {
+ if (hash.numEntries != (size_t)limit) {
Tcl_AppendResult(interp, "unexpected maximal size", NULL);
Tcl_DeleteHashTable(&hash);
return TCL_ERROR;
@@ -6951,13 +6786,13 @@ TestHashSystemHashCmd(
for (i=0 ; i<limit ; i++) {
hPtr = Tcl_FindHashEntry(&hash, (char *) INT2PTR(i));
if (hPtr == NULL) {
- Tcl_SetObjResult(interp, Tcl_NewIntObj(i));
+ Tcl_SetObjResult(interp, Tcl_NewLongObj(i));
Tcl_AppendToObj(Tcl_GetObjResult(interp)," lookup problem",-1);
Tcl_DeleteHashTable(&hash);
return TCL_ERROR;
}
if (PTR2INT(Tcl_GetHashValue(hPtr)) != i+42) {
- Tcl_SetObjResult(interp, Tcl_NewIntObj(i));
+ Tcl_SetObjResult(interp, Tcl_NewLongObj(i));
Tcl_AppendToObj(Tcl_GetObjResult(interp)," value problem",-1);
Tcl_DeleteHashTable(&hash);
return TCL_ERROR;
@@ -6999,7 +6834,7 @@ TestgetintCmd(
}
total += val;
}
- Tcl_SetObjResult(interp, Tcl_NewIntObj(total));
+ Tcl_SetObjResult(interp, Tcl_NewLongObj(total));
return TCL_OK;
}
}
@@ -7069,18 +6904,18 @@ TestNRELevels(
depth = (refDepth - &depth);
- levels[0] = Tcl_NewIntObj(depth);
- levels[1] = Tcl_NewIntObj(iPtr->numLevels);
- levels[2] = Tcl_NewIntObj(iPtr->cmdFramePtr->level);
- levels[3] = Tcl_NewIntObj(iPtr->varFramePtr->level);
- levels[4] = Tcl_NewIntObj(iPtr->execEnvPtr->execStackPtr->tosPtr
+ levels[0] = Tcl_NewLongObj(depth);
+ levels[1] = Tcl_NewLongObj(iPtr->numLevels);
+ levels[2] = Tcl_NewLongObj(iPtr->cmdFramePtr->level);
+ levels[3] = Tcl_NewLongObj(iPtr->varFramePtr->level);
+ levels[4] = Tcl_NewLongObj(iPtr->execEnvPtr->execStackPtr->tosPtr
- iPtr->execEnvPtr->execStackPtr->stackWords);
while (cbPtr) {
i++;
cbPtr = cbPtr->nextPtr;
}
- levels[5] = Tcl_NewIntObj(i);
+ levels[5] = Tcl_NewLongObj(i);
Tcl_SetObjResult(interp, Tcl_NewListObj(6, levels));
return TCL_OK;
@@ -7427,8 +7262,8 @@ TestparseargsCmd(
if (Tcl_ParseArgsObjv(interp, argTable, &count, objv, &remObjv)!=TCL_OK) {
return TCL_ERROR;
}
- result[0] = Tcl_NewIntObj(foo);
- result[1] = Tcl_NewIntObj(count);
+ result[0] = Tcl_NewLongObj(foo);
+ result[1] = Tcl_NewLongObj(count);
result[2] = Tcl_NewListObj(count, remObjv);
Tcl_SetObjResult(interp, Tcl_NewListObj(3, result));
ckfree(remObjv);
@@ -7671,8 +7506,8 @@ TestInterpResolverCmd(
return TCL_ERROR;
}
}
- if (Tcl_GetIndexFromObj(interp, objv[1], table, "operation", TCL_EXACT,
- &idx) != TCL_OK) {
+ if (Tcl_GetIndexFromObjStruct(interp, objv[1], table,
+ sizeof(char *), "operation", TCL_EXACT, &idx) != TCL_OK) {
return TCL_ERROR;
}
switch (idx) {