summaryrefslogtreecommitdiffstats
path: root/generic/tclTestObj.c
diff options
context:
space:
mode:
Diffstat (limited to 'generic/tclTestObj.c')
-rw-r--r--generic/tclTestObj.c1030
1 files changed, 408 insertions, 622 deletions
diff --git a/generic/tclTestObj.c b/generic/tclTestObj.c
index 9f31cff..f113cfe 100644
--- a/generic/tclTestObj.c
+++ b/generic/tclTestObj.c
@@ -6,70 +6,59 @@
* These commands are not normally included in Tcl applications; they're
* only used for testing.
*
- * Copyright © 1995-1998 Sun Microsystems, Inc.
- * Copyright © 1999 Scriptics Corporation.
- * Copyright © 2005 Kevin B. Kenny. All rights reserved.
+ * Copyright (c) 1995-1998 Sun Microsystems, Inc.
+ * Copyright (c) 1999 by Scriptics Corporation.
+ * Copyright (c) 2005 by Kevin B. Kenny. All rights reserved.
*
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*/
-#undef BUILD_tcl
-#ifndef USE_TCL_STUBS
-# define USE_TCL_STUBS
-#endif
+
#include "tclInt.h"
-#ifdef TCL_WITH_EXTERNAL_TOMMATH
-# include "tommath.h"
-#else
-# include "tclTomMath.h"
-#endif
-#include "tclStringRep.h"
+#include "tommath.h"
-#ifdef __GNUC__
/*
- * The rest of this file shouldn't warn about deprecated functions; they're
- * there because we intend them to be so and know that this file is OK to
- * touch those fields.
+ * An array of Tcl_Obj pointers used in the commands that operate on or get
+ * the values of Tcl object-valued variables. varPtr[i] is the i-th variable's
+ * Tcl_Obj *.
*/
-#pragma GCC diagnostic ignored "-Wdeprecated-declarations"
-#endif
+
+#define NUMBER_OF_OBJECT_VARS 20
+static Tcl_Obj *varPtr[NUMBER_OF_OBJECT_VARS];
/*
* Forward declarations for functions defined later in this file:
*/
-static int CheckIfVarUnset(Tcl_Interp *interp, Tcl_Obj **varPtr, Tcl_Size varIndex);
+static int CheckIfVarUnset(Tcl_Interp *interp, int varIndex);
static int GetVariableIndex(Tcl_Interp *interp,
- Tcl_Obj *obj, Tcl_Size *indexPtr);
-static void SetVarToObj(Tcl_Obj **varPtr, Tcl_Size varIndex, Tcl_Obj *objPtr);
-static Tcl_ObjCmdProc TestbignumobjCmd;
-static Tcl_ObjCmdProc TestbooleanobjCmd;
-static Tcl_ObjCmdProc TestdoubleobjCmd;
-static Tcl_ObjCmdProc TestindexobjCmd;
-static Tcl_ObjCmdProc TestintobjCmd;
-static Tcl_ObjCmdProc TestlistobjCmd;
-static Tcl_ObjCmdProc TestobjCmd;
-static Tcl_ObjCmdProc TeststringobjCmd;
-
-#define VARPTR_KEY "TCLOBJTEST_VARPTR"
-#define NUMBER_OF_OBJECT_VARS 20
-
-static void VarPtrDeleteProc(void *clientData, TCL_UNUSED(Tcl_Interp *))
-{
- int i;
- Tcl_Obj **varPtr = (Tcl_Obj **) clientData;
- for (i = 0; i < NUMBER_OF_OBJECT_VARS; i++) {
- if (varPtr[i]) Tcl_DecrRefCount(varPtr[i]);
- }
- ckfree(varPtr);
-}
-
-static Tcl_Obj **GetVarPtr(Tcl_Interp *interp)
-{
- Tcl_InterpDeleteProc *proc;
-
- return (Tcl_Obj **) Tcl_GetAssocData(interp, VARPTR_KEY, &proc);
-}
+ const char *string, int *indexPtr);
+static void SetVarToObj(int varIndex, Tcl_Obj *objPtr);
+int TclObjTest_Init(Tcl_Interp *interp);
+static int TestbignumobjCmd(ClientData dummy, Tcl_Interp *interp,
+ int objc, Tcl_Obj *const objv[]);
+static int TestbooleanobjCmd(ClientData dummy,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *const objv[]);
+static int TestdoubleobjCmd(ClientData dummy, Tcl_Interp *interp,
+ int objc, Tcl_Obj *const objv[]);
+static int TestindexobjCmd(ClientData dummy, Tcl_Interp *interp,
+ int objc, Tcl_Obj *const objv[]);
+static int TestintobjCmd(ClientData dummy, Tcl_Interp *interp,
+ int objc, Tcl_Obj *const objv[]);
+static int TestlistobjCmd(ClientData dummy, Tcl_Interp *interp,
+ int objc, Tcl_Obj *const objv[]);
+static int TestobjCmd(ClientData dummy, Tcl_Interp *interp,
+ int objc, Tcl_Obj *const objv[]);
+static int TeststringobjCmd(ClientData dummy, Tcl_Interp *interp,
+ int objc, Tcl_Obj *const objv[]);
+
+typedef struct TestString {
+ int numChars;
+ size_t allocated;
+ size_t uallocated;
+ Tcl_UniChar unicode[2];
+} TestString;
/*
*----------------------------------------------------------------------
@@ -93,38 +82,27 @@ int
TclObjTest_Init(
Tcl_Interp *interp)
{
- int i;
- /*
- * An array of Tcl_Obj pointers used in the commands that operate on or get
- * the values of Tcl object-valued variables. varPtr[i] is the i-th variable's
- * Tcl_Obj *.
- */
- Tcl_Obj **varPtr;
+ register int i;
- varPtr = (Tcl_Obj **)ckalloc(NUMBER_OF_OBJECT_VARS *sizeof(varPtr[0]));
- if (!varPtr) {
- return TCL_ERROR;
- }
- Tcl_SetAssocData(interp, VARPTR_KEY, VarPtrDeleteProc, varPtr);
for (i = 0; i < NUMBER_OF_OBJECT_VARS; i++) {
- varPtr[i] = NULL;
+ varPtr[i] = NULL;
}
Tcl_CreateObjCommand(interp, "testbignumobj", TestbignumobjCmd,
- NULL, NULL);
+ (ClientData) 0, NULL);
Tcl_CreateObjCommand(interp, "testbooleanobj", TestbooleanobjCmd,
- NULL, NULL);
+ (ClientData) 0, NULL);
Tcl_CreateObjCommand(interp, "testdoubleobj", TestdoubleobjCmd,
- NULL, NULL);
+ (ClientData) 0, NULL);
Tcl_CreateObjCommand(interp, "testintobj", TestintobjCmd,
- NULL, NULL);
+ (ClientData) 0, NULL);
Tcl_CreateObjCommand(interp, "testindexobj", TestindexobjCmd,
- NULL, NULL);
+ (ClientData) 0, NULL);
Tcl_CreateObjCommand(interp, "testlistobj", TestlistobjCmd,
- NULL, NULL);
- Tcl_CreateObjCommand(interp, "testobj", TestobjCmd, NULL, NULL);
+ (ClientData) 0, NULL);
+ Tcl_CreateObjCommand(interp, "testobj", TestobjCmd, (ClientData) 0, NULL);
Tcl_CreateObjCommand(interp, "teststringobj", TeststringobjCmd,
- NULL, NULL);
+ (ClientData) 0, NULL);
return TCL_OK;
}
@@ -133,7 +111,7 @@ TclObjTest_Init(
*
* TestbignumobjCmd --
*
- * This function implements the "testbignumobj" command. It is used
+ * This function implmenets the "testbignumobj" command. It is used
* to exercise the bignum Tcl object type implementation.
*
* Results:
@@ -148,38 +126,36 @@ TclObjTest_Init(
static int
TestbignumobjCmd(
- TCL_UNUSED(void *),
+ ClientData clientData, /* unused */
Tcl_Interp *interp, /* Tcl interpreter */
int objc, /* Argument count */
Tcl_Obj *const objv[]) /* Argument vector */
{
- static const char *const subcmds[] = {
- "set", "get", "mult10", "div10", "iseven", "radixsize", NULL
+ const char * subcmds[] = {
+ "set", "get", "mult10", "div10", NULL
};
enum options {
- BIGNUM_SET, BIGNUM_GET, BIGNUM_MULT10, BIGNUM_DIV10, BIGNUM_ISEVEN,
- BIGNUM_RADIXSIZE
+ BIGNUM_SET, BIGNUM_GET, BIGNUM_MULT10, BIGNUM_DIV10
};
- int index;
- Tcl_Size varIndex;
- const char *string;
- mp_int bignumValue;
- Tcl_Obj **varPtr;
+
+ int index, varIndex;
+ char* string;
+ mp_int bignumValue, newValue;
if (objc < 3) {
- Tcl_WrongNumArgs(interp, 1, objv, "option ?arg ...?");
+ Tcl_WrongNumArgs(interp, 1, objv, "option ?arg?...");
return TCL_ERROR;
}
if (Tcl_GetIndexFromObj(interp, objv[1], subcmds, "option", 0,
&index) != TCL_OK) {
return TCL_ERROR;
}
- if (GetVariableIndex(interp, objv[2], &varIndex) != TCL_OK) {
+ string = Tcl_GetString(objv[2]);
+ if (GetVariableIndex(interp, string, &varIndex) != TCL_OK) {
return TCL_ERROR;
}
- varPtr = GetVarPtr(interp);
- switch ((enum options)index) {
+ switch (index) {
case BIGNUM_SET:
if (objc != 4) {
Tcl_WrongNumArgs(interp, 2, objv, "var value");
@@ -209,7 +185,7 @@ TestbignumobjCmd(
if ((varPtr[varIndex] != NULL) && !Tcl_IsShared(varPtr[varIndex])) {
Tcl_SetBignumObj(varPtr[varIndex], &bignumValue);
} else {
- SetVarToObj(varPtr, varIndex, Tcl_NewBignumObj(&bignumValue));
+ SetVarToObj(varIndex, Tcl_NewBignumObj(&bignumValue));
}
break;
@@ -218,7 +194,7 @@ TestbignumobjCmd(
Tcl_WrongNumArgs(interp, 2, objv, "varIndex");
return TCL_ERROR;
}
- if (CheckIfVarUnset(interp, varPtr,varIndex)) {
+ if (CheckIfVarUnset(interp, varIndex)) {
return TCL_ERROR;
}
break;
@@ -228,23 +204,26 @@ TestbignumobjCmd(
Tcl_WrongNumArgs(interp, 2, objv, "varIndex");
return TCL_ERROR;
}
- if (CheckIfVarUnset(interp, varPtr,varIndex)) {
+ if (CheckIfVarUnset(interp, varIndex)) {
return TCL_ERROR;
}
if (Tcl_GetBignumFromObj(interp, varPtr[varIndex],
&bignumValue) != TCL_OK) {
return TCL_ERROR;
}
- if (mp_mul_d(&bignumValue, 10, &bignumValue) != MP_OKAY) {
+ if (mp_init(&newValue) != MP_OKAY
+ || (mp_mul_d(&bignumValue, 10, &newValue) != MP_OKAY)) {
mp_clear(&bignumValue);
+ mp_clear(&newValue);
Tcl_SetObjResult(interp,
Tcl_NewStringObj("error in mp_mul_d", -1));
return TCL_ERROR;
}
+ mp_clear(&bignumValue);
if (!Tcl_IsShared(varPtr[varIndex])) {
- Tcl_SetBignumObj(varPtr[varIndex], &bignumValue);
+ Tcl_SetBignumObj(varPtr[varIndex], &newValue);
} else {
- SetVarToObj(varPtr, varIndex, Tcl_NewBignumObj(&bignumValue));
+ SetVarToObj(varIndex, Tcl_NewBignumObj(&newValue));
}
break;
@@ -253,74 +232,27 @@ TestbignumobjCmd(
Tcl_WrongNumArgs(interp, 2, objv, "varIndex");
return TCL_ERROR;
}
- if (CheckIfVarUnset(interp, varPtr,varIndex)) {
+ if (CheckIfVarUnset(interp, varIndex)) {
return TCL_ERROR;
}
if (Tcl_GetBignumFromObj(interp, varPtr[varIndex],
&bignumValue) != TCL_OK) {
return TCL_ERROR;
}
- if (mp_div_d(&bignumValue, 10, &bignumValue, NULL) != MP_OKAY) {
+ if (mp_init(&newValue) != MP_OKAY
+ || (mp_div_d(&bignumValue, 10, &newValue, NULL) != MP_OKAY)) {
mp_clear(&bignumValue);
+ mp_clear(&newValue);
Tcl_SetObjResult(interp,
Tcl_NewStringObj("error in mp_div_d", -1));
return TCL_ERROR;
}
- if (!Tcl_IsShared(varPtr[varIndex])) {
- Tcl_SetBignumObj(varPtr[varIndex], &bignumValue);
- } else {
- SetVarToObj(varPtr, varIndex, Tcl_NewBignumObj(&bignumValue));
- }
- break;
-
- case BIGNUM_ISEVEN:
- if (objc != 3) {
- Tcl_WrongNumArgs(interp, 2, objv, "varIndex");
- return TCL_ERROR;
- }
- if (CheckIfVarUnset(interp, varPtr,varIndex)) {
- return TCL_ERROR;
- }
- if (Tcl_GetBignumFromObj(interp, varPtr[varIndex],
- &bignumValue) != TCL_OK) {
- return TCL_ERROR;
- }
- if (mp_mod_2d(&bignumValue, 1, &bignumValue) != MP_OKAY) {
- mp_clear(&bignumValue);
- Tcl_SetObjResult(interp,
- Tcl_NewStringObj("error in mp_mod_2d", -1));
- return TCL_ERROR;
- }
- if (!Tcl_IsShared(varPtr[varIndex])) {
- Tcl_SetBooleanObj(varPtr[varIndex], mp_iszero(&bignumValue));
- } else {
- SetVarToObj(varPtr, varIndex, Tcl_NewBooleanObj(mp_iszero(&bignumValue)));
- }
mp_clear(&bignumValue);
- break;
-
- case BIGNUM_RADIXSIZE:
- if (objc != 3) {
- Tcl_WrongNumArgs(interp, 2, objv, "varIndex");
- return TCL_ERROR;
- }
- if (CheckIfVarUnset(interp, varPtr,varIndex)) {
- return TCL_ERROR;
- }
- if (Tcl_GetBignumFromObj(interp, varPtr[varIndex],
- &bignumValue) != TCL_OK) {
- return TCL_ERROR;
- }
- if (mp_radix_size(&bignumValue, 10, &index) != MP_OKAY) {
- return TCL_ERROR;
- }
if (!Tcl_IsShared(varPtr[varIndex])) {
- Tcl_SetWideIntObj(varPtr[varIndex], index);
+ Tcl_SetBignumObj(varPtr[varIndex], &newValue);
} else {
- SetVarToObj(varPtr, varIndex, Tcl_NewWideIntObj(index));
+ SetVarToObj(varIndex, Tcl_NewBignumObj(&newValue));
}
- mp_clear(&bignumValue);
- break;
}
Tcl_SetObjResult(interp, varPtr[varIndex]);
@@ -347,15 +279,13 @@ TestbignumobjCmd(
static int
TestbooleanobjCmd(
- TCL_UNUSED(void *),
+ ClientData clientData, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
- Tcl_Size varIndex;
- int boolValue;
- const char *subCmd;
- Tcl_Obj **varPtr;
+ int varIndex, boolValue;
+ char *index, *subCmd;
if (objc < 3) {
wrongNumArgs:
@@ -363,12 +293,11 @@ TestbooleanobjCmd(
return TCL_ERROR;
}
- if (GetVariableIndex(interp, objv[2], &varIndex) != TCL_OK) {
+ index = Tcl_GetString(objv[2]);
+ if (GetVariableIndex(interp, index, &varIndex) != TCL_OK) {
return TCL_ERROR;
}
- varPtr = GetVarPtr(interp);
-
subCmd = Tcl_GetString(objv[1]);
if (strcmp(subCmd, "set") == 0) {
if (objc != 4) {
@@ -389,14 +318,14 @@ TestbooleanobjCmd(
if ((varPtr[varIndex] != NULL) && !Tcl_IsShared(varPtr[varIndex])) {
Tcl_SetBooleanObj(varPtr[varIndex], boolValue);
} else {
- SetVarToObj(varPtr, varIndex, Tcl_NewBooleanObj(boolValue));
+ SetVarToObj(varIndex, Tcl_NewBooleanObj(boolValue));
}
Tcl_SetObjResult(interp, varPtr[varIndex]);
} else if (strcmp(subCmd, "get") == 0) {
if (objc != 3) {
goto wrongNumArgs;
}
- if (CheckIfVarUnset(interp, varPtr,varIndex)) {
+ if (CheckIfVarUnset(interp, varIndex)) {
return TCL_ERROR;
}
Tcl_SetObjResult(interp, varPtr[varIndex]);
@@ -404,7 +333,7 @@ TestbooleanobjCmd(
if (objc != 3) {
goto wrongNumArgs;
}
- if (CheckIfVarUnset(interp, varPtr,varIndex)) {
+ if (CheckIfVarUnset(interp, varIndex)) {
return TCL_ERROR;
}
if (Tcl_GetBooleanFromObj(interp, varPtr[varIndex],
@@ -414,13 +343,13 @@ TestbooleanobjCmd(
if (!Tcl_IsShared(varPtr[varIndex])) {
Tcl_SetBooleanObj(varPtr[varIndex], !boolValue);
} else {
- SetVarToObj(varPtr, varIndex, Tcl_NewBooleanObj(!boolValue));
+ SetVarToObj(varIndex, Tcl_NewBooleanObj(!boolValue));
}
Tcl_SetObjResult(interp, varPtr[varIndex]);
} else {
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
"bad option \"", Tcl_GetString(objv[1]),
- "\": must be set, get, or not", (void *)NULL);
+ "\": must be set, get, or not", NULL);
return TCL_ERROR;
}
return TCL_OK;
@@ -447,15 +376,14 @@ TestbooleanobjCmd(
static int
TestdoubleobjCmd(
- TCL_UNUSED(void *),
+ ClientData clientData, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
- Tcl_Size varIndex;
+ int varIndex;
double doubleValue;
- const char *subCmd;
- Tcl_Obj **varPtr;
+ char *index, *subCmd, *string;
if (objc < 3) {
wrongNumArgs:
@@ -463,9 +391,8 @@ TestdoubleobjCmd(
return TCL_ERROR;
}
- varPtr = GetVarPtr(interp);
-
- if (GetVariableIndex(interp, objv[2], &varIndex) != TCL_OK) {
+ index = Tcl_GetString(objv[2]);
+ if (GetVariableIndex(interp, index, &varIndex) != TCL_OK) {
return TCL_ERROR;
}
@@ -474,7 +401,8 @@ TestdoubleobjCmd(
if (objc != 4) {
goto wrongNumArgs;
}
- if (Tcl_GetDouble(interp, Tcl_GetString(objv[3]), &doubleValue) != TCL_OK) {
+ string = Tcl_GetString(objv[3]);
+ if (Tcl_GetDouble(interp, string, &doubleValue) != TCL_OK) {
return TCL_ERROR;
}
@@ -489,14 +417,14 @@ TestdoubleobjCmd(
if ((varPtr[varIndex] != NULL) && !Tcl_IsShared(varPtr[varIndex])) {
Tcl_SetDoubleObj(varPtr[varIndex], doubleValue);
} else {
- SetVarToObj(varPtr, varIndex, Tcl_NewDoubleObj(doubleValue));
+ SetVarToObj(varIndex, Tcl_NewDoubleObj(doubleValue));
}
Tcl_SetObjResult(interp, varPtr[varIndex]);
} else if (strcmp(subCmd, "get") == 0) {
if (objc != 3) {
goto wrongNumArgs;
}
- if (CheckIfVarUnset(interp, varPtr,varIndex)) {
+ if (CheckIfVarUnset(interp, varIndex)) {
return TCL_ERROR;
}
Tcl_SetObjResult(interp, varPtr[varIndex]);
@@ -504,7 +432,7 @@ TestdoubleobjCmd(
if (objc != 3) {
goto wrongNumArgs;
}
- if (CheckIfVarUnset(interp, varPtr,varIndex)) {
+ if (CheckIfVarUnset(interp, varIndex)) {
return TCL_ERROR;
}
if (Tcl_GetDoubleFromObj(interp, varPtr[varIndex],
@@ -512,32 +440,32 @@ TestdoubleobjCmd(
return TCL_ERROR;
}
if (!Tcl_IsShared(varPtr[varIndex])) {
- Tcl_SetDoubleObj(varPtr[varIndex], doubleValue * 10.0);
+ Tcl_SetDoubleObj(varPtr[varIndex], (doubleValue * 10.0));
} else {
- SetVarToObj(varPtr, varIndex, Tcl_NewDoubleObj(doubleValue * 10.0));
+ SetVarToObj(varIndex, Tcl_NewDoubleObj( (doubleValue * 10.0) ));
}
Tcl_SetObjResult(interp, varPtr[varIndex]);
} else if (strcmp(subCmd, "div10") == 0) {
if (objc != 3) {
goto wrongNumArgs;
}
- if (CheckIfVarUnset(interp, varPtr,varIndex)) {
+ if (CheckIfVarUnset(interp, varIndex)) {
return TCL_ERROR;
}
if (Tcl_GetDoubleFromObj(interp, varPtr[varIndex],
- &doubleValue) != TCL_OK) {
+ &doubleValue) != TCL_OK) {
return TCL_ERROR;
}
if (!Tcl_IsShared(varPtr[varIndex])) {
- Tcl_SetDoubleObj(varPtr[varIndex], doubleValue / 10.0);
+ Tcl_SetDoubleObj(varPtr[varIndex], (doubleValue / 10.0));
} else {
- SetVarToObj(varPtr, varIndex, Tcl_NewDoubleObj(doubleValue / 10.0));
+ SetVarToObj(varIndex, Tcl_NewDoubleObj( (doubleValue / 10.0) ));
}
Tcl_SetObjResult(interp, varPtr[varIndex]);
} else {
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
"bad option \"", Tcl_GetString(objv[1]),
- "\": must be set, get, mult10, or div10", (void *)NULL);
+ "\": must be set, get, mult10, or div10", NULL);
return TCL_ERROR;
}
return TCL_OK;
@@ -563,24 +491,23 @@ TestdoubleobjCmd(
static int
TestindexobjCmd(
- TCL_UNUSED(void *),
+ ClientData clientData, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
- int allowAbbrev, index, setError, i, result;
- Tcl_Size index2;
+ int allowAbbrev, index, index2, setError, i, result;
const char **argv;
- static const char *const tablePtr[] = {"a", "b", "check", NULL};
-
+ static const char *tablePtr[] = {"a", "b", "check", NULL};
/*
* Keep this structure declaration in sync with tclIndexObj.c
*/
struct IndexRep {
- void *tablePtr; /* Pointer to the table of strings. */
- Tcl_Size offset; /* Offset between table entries. */
- Tcl_Size index; /* Selected index into table. */
- } *indexRep;
+ VOID *tablePtr; /* Pointer to the table of strings */
+ int offset; /* Offset between table entries */
+ int index; /* Selected index into table. */
+ };
+ struct IndexRep *indexRep;
if ((objc == 3) && (strcmp(Tcl_GetString(objv[1]),
"check") == 0)) {
@@ -590,17 +517,17 @@ TestindexobjCmd(
* lookups.
*/
- if (Tcl_GetIntForIndex(interp, objv[2], TCL_INDEX_NONE, &index2) != TCL_OK) {
+ if (Tcl_GetIntFromObj(interp, objv[2], &index2) != TCL_OK) {
return TCL_ERROR;
}
Tcl_GetIndexFromObj(NULL, objv[1], tablePtr, "token", 0, &index);
- indexRep = (struct IndexRep *)objv[1]->internalRep.twoPtrValue.ptr1;
+ indexRep = (struct IndexRep *) objv[1]->internalRep.twoPtrValue.ptr1;
indexRep->index = index2;
result = Tcl_GetIndexFromObj(NULL, objv[1],
tablePtr, "token", 0, &index);
if (result == TCL_OK) {
- Tcl_SetWideIntObj(Tcl_GetObjResult(interp), index);
+ Tcl_SetIntObj(Tcl_GetObjResult(interp), index);
}
return result;
}
@@ -617,18 +544,33 @@ TestindexobjCmd(
return TCL_ERROR;
}
- argv = (const char **)ckalloc((objc-3) * sizeof(char *));
+ argv = (const char **) ckalloc((unsigned) ((objc-3) * sizeof(char *)));
for (i = 4; i < objc; i++) {
argv[i-4] = Tcl_GetString(objv[i]);
}
argv[objc-4] = NULL;
+ /*
+ * Tcl_GetIndexFromObj assumes that the table is statically-allocated so
+ * that its address is different for each index object. If we accidently
+ * allocate a table at the same address as that cached in the index
+ * object, clear out the object's cached state.
+ */
+
+ if ( objv[3]->typePtr != NULL
+ && !strcmp( "index", objv[3]->typePtr->name ) ) {
+ indexRep = (struct IndexRep *) objv[3]->internalRep.twoPtrValue.ptr1;
+ if (indexRep->tablePtr == (VOID *) argv) {
+ objv[3]->typePtr->freeIntRepProc(objv[3]);
+ objv[3]->typePtr = NULL;
+ }
+ }
+
result = Tcl_GetIndexFromObj((setError? interp : NULL), objv[3],
- argv, "token", TCL_INDEX_TEMP_TABLE|(allowAbbrev? 0 : TCL_EXACT),
- &index);
- ckfree(argv);
+ argv, "token", (allowAbbrev? 0 : TCL_EXACT), &index);
+ ckfree((char *) argv);
if (result == TCL_OK) {
- Tcl_SetWideIntObj(Tcl_GetObjResult(interp), index);
+ Tcl_SetIntObj(Tcl_GetObjResult(interp), index);
}
return result;
}
@@ -653,18 +595,14 @@ TestindexobjCmd(
static int
TestintobjCmd(
- TCL_UNUSED(void *),
+ ClientData clientData, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
- Tcl_Size varIndex;
-#if (INT_MAX != LONG_MAX) /* int is not the same size as long */
- int i;
-#endif
- Tcl_WideInt wideValue;
- const char *subCmd;
- Tcl_Obj **varPtr;
+ int intValue, varIndex, i;
+ long longValue;
+ char *index, *subCmd, *string;
if (objc < 3) {
wrongNumArgs:
@@ -672,8 +610,8 @@ TestintobjCmd(
return TCL_ERROR;
}
- varPtr = GetVarPtr(interp);
- if (GetVariableIndex(interp, objv[2], &varIndex) != TCL_OK) {
+ index = Tcl_GetString(objv[2]);
+ if (GetVariableIndex(interp, index, &varIndex) != TCL_OK) {
return TCL_ERROR;
}
@@ -682,9 +620,11 @@ TestintobjCmd(
if (objc != 4) {
goto wrongNumArgs;
}
- if (Tcl_GetWideIntFromObj(interp, objv[3], &wideValue) != TCL_OK) {
+ string = Tcl_GetString(objv[3]);
+ if (Tcl_GetInt(interp, string, &i) != TCL_OK) {
return TCL_ERROR;
}
+ intValue = i;
/*
* If the object currently bound to the variable with index varIndex
@@ -695,63 +635,67 @@ TestintobjCmd(
*/
if ((varPtr[varIndex] != NULL) && !Tcl_IsShared(varPtr[varIndex])) {
- Tcl_SetWideIntObj(varPtr[varIndex], wideValue);
+ Tcl_SetIntObj(varPtr[varIndex], intValue);
} else {
- SetVarToObj(varPtr, varIndex, Tcl_NewWideIntObj(wideValue));
+ SetVarToObj(varIndex, Tcl_NewIntObj(intValue));
}
Tcl_SetObjResult(interp, varPtr[varIndex]);
} else if (strcmp(subCmd, "set2") == 0) { /* doesn't set result */
if (objc != 4) {
goto wrongNumArgs;
}
- if (Tcl_GetWideIntFromObj(interp, objv[3], &wideValue) != TCL_OK) {
+ string = Tcl_GetString(objv[3]);
+ if (Tcl_GetInt(interp, string, &i) != TCL_OK) {
return TCL_ERROR;
}
+ intValue = i;
if ((varPtr[varIndex] != NULL) && !Tcl_IsShared(varPtr[varIndex])) {
- Tcl_SetWideIntObj(varPtr[varIndex], wideValue);
+ Tcl_SetIntObj(varPtr[varIndex], intValue);
} else {
- SetVarToObj(varPtr, varIndex, Tcl_NewWideIntObj(wideValue));
+ SetVarToObj(varIndex, Tcl_NewIntObj(intValue));
}
- } else if (strcmp(subCmd, "setint") == 0) {
+ } else if (strcmp(subCmd, "setlong") == 0) {
if (objc != 4) {
goto wrongNumArgs;
}
- if (Tcl_GetWideIntFromObj(interp, objv[3], &wideValue) != TCL_OK) {
+ string = Tcl_GetString(objv[3]);
+ if (Tcl_GetInt(interp, string, &i) != TCL_OK) {
return TCL_ERROR;
}
+ intValue = i;
if ((varPtr[varIndex] != NULL) && !Tcl_IsShared(varPtr[varIndex])) {
- Tcl_SetWideIntObj(varPtr[varIndex], wideValue);
+ Tcl_SetLongObj(varPtr[varIndex], intValue);
} else {
- SetVarToObj(varPtr, varIndex, Tcl_NewWideIntObj(wideValue));
+ SetVarToObj(varIndex, Tcl_NewLongObj(intValue));
}
Tcl_SetObjResult(interp, varPtr[varIndex]);
- } else if (strcmp(subCmd, "setmax") == 0) {
- Tcl_WideInt maxWide = WIDE_MAX;
+ } else if (strcmp(subCmd, "setmaxlong") == 0) {
+ long maxLong = LONG_MAX;
if (objc != 3) {
goto wrongNumArgs;
}
if ((varPtr[varIndex] != NULL) && !Tcl_IsShared(varPtr[varIndex])) {
- Tcl_SetWideIntObj(varPtr[varIndex], maxWide);
+ Tcl_SetLongObj(varPtr[varIndex], maxLong);
} else {
- SetVarToObj(varPtr, varIndex, Tcl_NewWideIntObj(maxWide));
+ SetVarToObj(varIndex, Tcl_NewLongObj(maxLong));
}
- } else if (strcmp(subCmd, "ismax") == 0) {
+ } else if (strcmp(subCmd, "ismaxlong") == 0) {
if (objc != 3) {
goto wrongNumArgs;
}
- if (CheckIfVarUnset(interp, varPtr,varIndex)) {
+ if (CheckIfVarUnset(interp, varIndex)) {
return TCL_ERROR;
}
- if (Tcl_GetWideIntFromObj(interp, varPtr[varIndex], &wideValue) != TCL_OK) {
+ if (Tcl_GetLongFromObj(interp, varPtr[varIndex], &longValue) != TCL_OK) {
return TCL_ERROR;
}
Tcl_AppendToObj(Tcl_GetObjResult(interp),
- ((wideValue == WIDE_MAX)? "1" : "0"), -1);
+ ((longValue == LONG_MAX)? "1" : "0"), -1);
} else if (strcmp(subCmd, "get") == 0) {
if (objc != 3) {
goto wrongNumArgs;
}
- if (CheckIfVarUnset(interp, varPtr,varIndex)) {
+ if (CheckIfVarUnset(interp, varIndex)) {
return TCL_ERROR;
}
Tcl_SetObjResult(interp, varPtr[varIndex]);
@@ -759,10 +703,11 @@ TestintobjCmd(
if (objc != 3) {
goto wrongNumArgs;
}
- if (CheckIfVarUnset(interp, varPtr,varIndex)) {
+ if (CheckIfVarUnset(interp, varIndex)) {
return TCL_ERROR;
}
- Tcl_AppendToObj(Tcl_GetObjResult(interp), Tcl_GetString(varPtr[varIndex]), -1);
+ string = Tcl_GetString(varPtr[varIndex]);
+ Tcl_AppendToObj(Tcl_GetObjResult(interp), string, -1);
} else if (strcmp(subCmd, "inttoobigtest") == 0) {
/*
* If long ints have more bits than ints on this platform, verify that
@@ -778,9 +723,9 @@ TestintobjCmd(
Tcl_AppendToObj(Tcl_GetObjResult(interp), "1", -1);
#else
if ((varPtr[varIndex] != NULL) && !Tcl_IsShared(varPtr[varIndex])) {
- Tcl_SetWideIntObj(varPtr[varIndex], LONG_MAX);
+ Tcl_SetLongObj(varPtr[varIndex], LONG_MAX);
} else {
- SetVarToObj(varPtr, varIndex, Tcl_NewWideIntObj(LONG_MAX));
+ SetVarToObj(varIndex, Tcl_NewLongObj(LONG_MAX));
}
if (Tcl_GetIntFromObj(interp, varPtr[varIndex], &i) != TCL_OK) {
Tcl_ResetResult(interp);
@@ -793,40 +738,40 @@ TestintobjCmd(
if (objc != 3) {
goto wrongNumArgs;
}
- if (CheckIfVarUnset(interp, varPtr,varIndex)) {
+ if (CheckIfVarUnset(interp, varIndex)) {
return TCL_ERROR;
}
- if (Tcl_GetWideIntFromObj(interp, varPtr[varIndex],
- &wideValue) != TCL_OK) {
+ if (Tcl_GetIntFromObj(interp, varPtr[varIndex],
+ &intValue) != TCL_OK) {
return TCL_ERROR;
}
if (!Tcl_IsShared(varPtr[varIndex])) {
- Tcl_SetWideIntObj(varPtr[varIndex], wideValue * 10);
+ Tcl_SetIntObj(varPtr[varIndex], (intValue * 10));
} else {
- SetVarToObj(varPtr, varIndex, Tcl_NewWideIntObj(wideValue * 10));
+ SetVarToObj(varIndex, Tcl_NewIntObj( (intValue * 10) ));
}
Tcl_SetObjResult(interp, varPtr[varIndex]);
} else if (strcmp(subCmd, "div10") == 0) {
if (objc != 3) {
goto wrongNumArgs;
}
- if (CheckIfVarUnset(interp, varPtr,varIndex)) {
+ if (CheckIfVarUnset(interp, varIndex)) {
return TCL_ERROR;
}
- if (Tcl_GetWideIntFromObj(interp, varPtr[varIndex],
- &wideValue) != TCL_OK) {
+ if (Tcl_GetIntFromObj(interp, varPtr[varIndex],
+ &intValue) != TCL_OK) {
return TCL_ERROR;
}
if (!Tcl_IsShared(varPtr[varIndex])) {
- Tcl_SetWideIntObj(varPtr[varIndex], wideValue / 10);
+ Tcl_SetIntObj(varPtr[varIndex], (intValue / 10));
} else {
- SetVarToObj(varPtr, varIndex, Tcl_NewWideIntObj(wideValue / 10));
+ SetVarToObj(varIndex, Tcl_NewIntObj( (intValue / 10) ));
}
Tcl_SetObjResult(interp, varPtr[varIndex]);
} else {
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
"bad option \"", Tcl_GetString(objv[1]),
- "\": must be set, get, get2, mult10, or div10", (void *)NULL);
+ "\": must be set, get, get2, mult10, or div10", NULL);
return TCL_ERROR;
}
return TCL_OK;
@@ -841,35 +786,6 @@ TestintobjCmd(
* test a few possible corner cases in list object manipulation from
* C code that cannot occur at the Tcl level.
*
- * Following new commands are added for 8.7 as regression tests for
- * memory leaks and use-after-free. Unlike 8.6, 8.7 has multiple internal
- * representations for lists. It has to be ensured that corresponding
- * implementations obey the invariants of the C list API. The script
- * level tests do not suffice as Tcl list commands do not execute
- * the same exact code path as the exported C API.
- *
- * Note these new commands are only useful when Tcl is compiled with
- * TCL_MEM_DEBUG defined.
- *
- * indexmemcheck - loops calling Tcl_ListObjIndex on each element. This
- * is to test that abstract lists returning elements do not depend
- * on caller to free them. The test case should check allocated counts
- * with the following sequence:
- * set before <get memory counts>
- * testobj set VARINDEX [list a b c] (or lseq etc.)
- * testlistobj indexnoop VARINDEX
- * testobj unset VARINDEX
- * set after <get memory counts>
- * after calling this command AND freeing the passed list. The targeted
- * bug is if Tcl_LOI returns a ephemeral Tcl_Obj with no other reference
- * resulting in a memory leak. Conversely, the command also checks
- * that the Tcl_Obj returned by Tcl_LOI does not have a zero reference
- * count since it is supposed to have at least one reference held
- * by the list implementation. Returns a message in interp otherwise.
- *
- * getelementsmemcheck - as above but for Tcl_ListObjGetElements
-
- *
* Results:
* A standard Tcl object result.
*
@@ -881,42 +797,35 @@ TestintobjCmd(
static int
TestlistobjCmd(
- TCL_UNUSED(void *),
+ ClientData clientData, /* Not used */
Tcl_Interp *interp, /* Tcl interpreter */
int objc, /* Number of arguments */
Tcl_Obj *const objv[]) /* Argument objects */
{
/* Subcommands supported by this command */
- static const char* const subcommands[] = {
+ const char* subcommands[] = {
"set",
"get",
- "replace",
- "indexmemcheck",
- "getelementsmemcheck",
- "index",
- NULL
+ "replace"
};
enum listobjCmdIndex {
LISTOBJ_SET,
LISTOBJ_GET,
- LISTOBJ_REPLACE,
- LISTOBJ_INDEXMEMCHECK,
- LISTOBJ_GETELEMENTSMEMCHECK,
- LISTOBJ_INDEX,
- } cmdIndex;
-
- Tcl_Size varIndex; /* Variable number converted to binary */
- Tcl_Size first; /* First index in the list */
- Tcl_Size count; /* Count of elements in a list */
- Tcl_Obj **varPtr;
- Tcl_Size i, len;
+ LISTOBJ_REPLACE
+ };
+
+ const char* index; /* Argument giving the variable number */
+ int varIndex; /* Variable number converted to binary */
+ int cmdIndex; /* Ordinal number of the subcommand */
+ int first; /* First index in the list */
+ int count; /* Count of elements in a list */
if (objc < 3) {
Tcl_WrongNumArgs(interp, 1, objv, "option arg ?arg...?");
return TCL_ERROR;
}
- varPtr = GetVarPtr(interp);
- if (GetVariableIndex(interp, objv[2], &varIndex) != TCL_OK) {
+ index = Tcl_GetString(objv[2]);
+ if (GetVariableIndex(interp, index, &varIndex) != TCL_OK) {
return TCL_ERROR;
}
if (Tcl_GetIndexFromObj(interp, objv[1], subcommands, "command",
@@ -928,7 +837,7 @@ TestlistobjCmd(
if ((varPtr[varIndex] != NULL) && !Tcl_IsShared(varPtr[varIndex])) {
Tcl_SetListObj(varPtr[varIndex], objc-3, objv+3);
} else {
- SetVarToObj(varPtr, varIndex, Tcl_NewListObj(objc-3, objv+3));
+ SetVarToObj(varIndex, Tcl_NewListObj(objc-3, objv+3));
}
Tcl_SetObjResult(interp, varPtr[varIndex]);
break;
@@ -938,7 +847,7 @@ TestlistobjCmd(
Tcl_WrongNumArgs(interp, 2, objv, "varIndex");
return TCL_ERROR;
}
- if (CheckIfVarUnset(interp, varPtr,varIndex)) {
+ if (CheckIfVarUnset(interp, varIndex)) {
return TCL_ERROR;
}
Tcl_SetObjResult(interp, varPtr[varIndex]);
@@ -950,86 +859,16 @@ TestlistobjCmd(
"varIndex start count ?element...?");
return TCL_ERROR;
}
- if (Tcl_GetIntForIndex(interp, objv[3], TCL_INDEX_NONE, &first) != TCL_OK
- || Tcl_GetIntForIndex(interp, objv[4], TCL_INDEX_NONE, &count) != TCL_OK) {
+ if (Tcl_GetIntFromObj(interp, objv[3], &first) != TCL_OK
+ || Tcl_GetIntFromObj(interp, objv[4], &count) != TCL_OK) {
return TCL_ERROR;
}
if (Tcl_IsShared(varPtr[varIndex])) {
- SetVarToObj(varPtr, varIndex, Tcl_DuplicateObj(varPtr[varIndex]));
+ SetVarToObj(varIndex, Tcl_DuplicateObj(varPtr[varIndex]));
}
Tcl_ResetResult(interp);
return Tcl_ListObjReplace(interp, varPtr[varIndex], first, count,
objc-5, objv+5);
-
- case LISTOBJ_INDEXMEMCHECK:
- if (objc != 3) {
- Tcl_WrongNumArgs(interp, 2, objv, "varIndex");
- return TCL_ERROR;
- }
- if (CheckIfVarUnset(interp, varPtr, varIndex)) {
- return TCL_ERROR;
- }
- if (Tcl_ListObjLength(interp, varPtr[varIndex], &len) != TCL_OK) {
- return TCL_ERROR;
- }
- for (i = 0; i < len; ++i) {
- Tcl_Obj *objP;
- if (Tcl_ListObjIndex(interp, varPtr[varIndex], i, &objP)
- != TCL_OK) {
- return TCL_ERROR;
- }
- if (objP->refCount <= 0) {
- Tcl_SetObjResult(interp, Tcl_NewStringObj(
- "Tcl_ListObjIndex returned object with ref count <= 0",
- TCL_INDEX_NONE));
- /* Keep looping since we are also looping for leaks */
- }
- }
- break;
-
- case LISTOBJ_GETELEMENTSMEMCHECK:
- if (objc != 3) {
- Tcl_WrongNumArgs(interp, 2, objv, "varIndex");
- return TCL_ERROR;
- }
- if (CheckIfVarUnset(interp, varPtr, varIndex)) {
- return TCL_ERROR;
- } else {
- Tcl_Obj **elems;
- if (Tcl_ListObjGetElements(interp, varPtr[varIndex], &len, &elems)
- != TCL_OK) {
- return TCL_ERROR;
- }
- for (i = 0; i < len; ++i) {
- if (elems[i]->refCount <= 0) {
- Tcl_SetObjResult(interp, Tcl_NewStringObj(
- "Tcl_ListObjGetElements element has ref count <= 0",
- TCL_INDEX_NONE));
- break;
- }
- }
- }
- break;
- case LISTOBJ_INDEX:
- /*
- * Tcl_ListObjIndex semantics differ from lindex for out of bounds.
- * Hence this explicit test.
- */
- if (objc != 4) {
- Tcl_WrongNumArgs(interp, 2, objv,
- "varIndex listIndex");
- return TCL_ERROR;
- }
- if (Tcl_GetIntForIndex(interp, objv[3], TCL_INDEX_NONE, &first) != TCL_OK) {
- return TCL_ERROR;
- } else {
- Tcl_Obj *objP;
- if (Tcl_ListObjIndex(interp, varPtr[varIndex], first, &objP) != TCL_OK) {
- return TCL_ERROR;
- }
- Tcl_SetObjResult(interp, objP ? objP : Tcl_NewStringObj("null", -1));
- }
- break;
}
return TCL_OK;
}
@@ -1053,28 +892,14 @@ TestlistobjCmd(
static int
TestobjCmd(
- TCL_UNUSED(void *),
+ ClientData clientData, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
- Tcl_Size varIndex, destIndex;
- int i;
- const Tcl_ObjType *targetType;
- Tcl_Obj **varPtr;
- static const char *const subcommands[] = {
- "freeallvars", "bug3598580",
- "types", "objtype", "newobj", "set",
- "assign", "convert", "duplicate",
- "invalidateStringRep", "refcount", "type",
- NULL
- };
- enum testobjCmdIndex {
- TESTOBJ_FREEALLVARS, TESTOBJ_BUG3598580,
- TESTOBJ_TYPES, TESTOBJ_OBJTYPE, TESTOBJ_NEWOBJ, TESTOBJ_SET,
- TESTOBJ_ASSIGN, TESTOBJ_CONVERT, TESTOBJ_DUPLICATE,
- TESTOBJ_INVALIDATESTRINGREP, TESTOBJ_REFCOUNT, TESTOBJ_TYPE,
- } cmdIndex;
+ int varIndex, destIndex, i;
+ char *index, *subCmd, *string;
+ Tcl_ObjType *targetType;
if (objc < 2) {
wrongNumArgs:
@@ -1082,175 +907,172 @@ TestobjCmd(
return TCL_ERROR;
}
- varPtr = GetVarPtr(interp);
- if (Tcl_GetIndexFromObj(
- interp, objv[1], subcommands, "command", 0, &cmdIndex)
- != TCL_OK) {
- return TCL_ERROR;
- }
- switch (cmdIndex) {
- case TESTOBJ_FREEALLVARS:
- if (objc != 2) {
- goto wrongNumArgs;
- }
- for (i = 0; i < NUMBER_OF_OBJECT_VARS; i++) {
- if (varPtr[i] != NULL) {
- Tcl_DecrRefCount(varPtr[i]);
- varPtr[i] = NULL;
- }
- }
- return TCL_OK;
- case TESTOBJ_BUG3598580:
- if (objc != 2) {
- goto wrongNumArgs;
- } else {
- Tcl_Obj *listObjPtr, *elemObjPtr;
- elemObjPtr = Tcl_NewWideIntObj(123);
- listObjPtr = Tcl_NewListObj(1, &elemObjPtr);
- /* Replace the single list element through itself, nonsense but
- * legal. */
- Tcl_ListObjReplace(interp, listObjPtr, 0, 1, 1, &elemObjPtr);
- Tcl_SetObjResult(interp, listObjPtr);
+ subCmd = Tcl_GetString(objv[1]);
+ if (strcmp(subCmd, "assign") == 0) {
+ if (objc != 4) {
+ goto wrongNumArgs;
+ }
+ index = Tcl_GetString(objv[2]);
+ if (GetVariableIndex(interp, index, &varIndex) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ if (CheckIfVarUnset(interp, varIndex)) {
+ return TCL_ERROR;
}
- return TCL_OK;
- case TESTOBJ_TYPES:
+ string = Tcl_GetString(objv[3]);
+ if (GetVariableIndex(interp, string, &destIndex) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ SetVarToObj(destIndex, varPtr[varIndex]);
+ Tcl_SetObjResult(interp, varPtr[destIndex]);
+ } else if (strcmp(subCmd, "bug3598580") == 0) {
+ Tcl_Obj *listObjPtr, *elemObjPtr;
if (objc != 2) {
goto wrongNumArgs;
- } else {
- Tcl_Obj *typesObj = Tcl_NewListObj(0, NULL);
- Tcl_AppendAllObjTypes(interp, typesObj);
- Tcl_SetObjResult(interp, typesObj);
- }
- return TCL_OK;
- case TESTOBJ_OBJTYPE:
- /*
- * Return an object containing the name of the argument's type of
- * internal rep. If none exists, return "none".
- */
-
- if (objc != 3) {
- goto wrongNumArgs;
- } else {
- const char *typeName;
-
- if (objv[2]->typePtr == NULL) {
- Tcl_SetObjResult(interp, Tcl_NewStringObj("none", -1));
- } else {
- typeName = objv[2]->typePtr->name;
- if (!strcmp(typeName, "utf32string"))
- typeName = "string";
-#ifndef TCL_WIDE_INT_IS_LONG
- else if (!strcmp(typeName, "wideInt")) typeName = "int";
-#endif
- Tcl_SetObjResult(interp, Tcl_NewStringObj(typeName, -1));
- }
}
+ elemObjPtr = Tcl_NewIntObj(123);
+ listObjPtr = Tcl_NewListObj(1, &elemObjPtr);
+ /* Replace the single list element through itself, nonsense but legal. */
+ Tcl_ListObjReplace(interp, listObjPtr, 0, 1, 1, &elemObjPtr);
+ Tcl_SetObjResult(interp, listObjPtr);
return TCL_OK;
- case TESTOBJ_NEWOBJ:
- if (objc != 3) {
- goto wrongNumArgs;
- }
- if (GetVariableIndex(interp, objv[2], &varIndex) != TCL_OK) {
+ } else if (strcmp(subCmd, "convert") == 0) {
+ char *typeName;
+ if (objc != 4) {
+ goto wrongNumArgs;
+ }
+ index = Tcl_GetString(objv[2]);
+ if (GetVariableIndex(interp, index, &varIndex) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ if (CheckIfVarUnset(interp, varIndex)) {
return TCL_ERROR;
}
- SetVarToObj(varPtr, varIndex, Tcl_NewObj());
+ typeName = Tcl_GetString(objv[3]);
+ if ((targetType = Tcl_GetObjType(typeName)) == NULL) {
+ Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
+ "no type ", typeName, " found", NULL);
+ return TCL_ERROR;
+ }
+ if (Tcl_ConvertToType(interp, varPtr[varIndex], targetType)
+ != TCL_OK) {
+ return TCL_ERROR;
+ }
Tcl_SetObjResult(interp, varPtr[varIndex]);
- return TCL_OK;
- case TESTOBJ_SET:
- if (objc != 4) {
- goto wrongNumArgs;
- }
- if (GetVariableIndex(interp, objv[2], &varIndex) != TCL_OK) {
- return TCL_ERROR;
- }
- SetVarToObj(varPtr, varIndex, objv[3]);
- return TCL_OK;
-
- default:
- break;
- }
-
- /* All further commands expect an occupied varindex argument */
- if (objc < 3) {
- goto wrongNumArgs;
- }
-
- if (GetVariableIndex(interp, objv[2], &varIndex) != TCL_OK) {
- return TCL_ERROR;
- }
- if (CheckIfVarUnset(interp, varPtr, varIndex)) {
- return TCL_ERROR;
- }
-
- switch (cmdIndex) {
- case TESTOBJ_ASSIGN:
- if (objc != 4) {
- goto wrongNumArgs;
- }
- if (GetVariableIndex(interp, objv[3], &destIndex) != TCL_OK) {
+ } else if (strcmp(subCmd, "duplicate") == 0) {
+ if (objc != 4) {
+ goto wrongNumArgs;
+ }
+ index = Tcl_GetString(objv[2]);
+ if (GetVariableIndex(interp, index, &varIndex) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ if (CheckIfVarUnset(interp, varIndex)) {
return TCL_ERROR;
}
- SetVarToObj(varPtr, destIndex, varPtr[varIndex]);
+ string = Tcl_GetString(objv[3]);
+ if (GetVariableIndex(interp, string, &destIndex) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ SetVarToObj(destIndex, Tcl_DuplicateObj(varPtr[varIndex]));
Tcl_SetObjResult(interp, varPtr[destIndex]);
- break;
- case TESTOBJ_CONVERT:
- if (objc != 4) {
+ } else if (strcmp(subCmd, "freeallvars") == 0) {
+ if (objc != 2) {
+ goto wrongNumArgs;
+ }
+ for (i = 0; i < NUMBER_OF_OBJECT_VARS; i++) {
+ if (varPtr[i] != NULL) {
+ Tcl_DecrRefCount(varPtr[i]);
+ varPtr[i] = NULL;
+ }
+ }
+ } else if ( strcmp ( subCmd, "invalidateStringRep" ) == 0 ) {
+ if ( objc != 3 ) {
goto wrongNumArgs;
}
- if ((targetType = Tcl_GetObjType(Tcl_GetString(objv[3]))) == NULL) {
- Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
- "no type ", Tcl_GetString(objv[3]), " found", (void *)NULL);
+ index = Tcl_GetString( objv[2] );
+ if ( GetVariableIndex( interp, index, &varIndex ) != TCL_OK ) {
return TCL_ERROR;
}
- if (Tcl_ConvertToType(interp, varPtr[varIndex], targetType)
- != TCL_OK) {
+ if (CheckIfVarUnset(interp, varIndex)) {
return TCL_ERROR;
}
+ Tcl_InvalidateStringRep( varPtr[varIndex] );
+ Tcl_SetObjResult( interp, varPtr[varIndex] );
+ } else if (strcmp(subCmd, "newobj") == 0) {
+ if (objc != 3) {
+ goto wrongNumArgs;
+ }
+ index = Tcl_GetString(objv[2]);
+ if (GetVariableIndex(interp, index, &varIndex) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ SetVarToObj(varIndex, Tcl_NewObj());
Tcl_SetObjResult(interp, varPtr[varIndex]);
- break;
- case TESTOBJ_DUPLICATE:
- if (objc != 4) {
- goto wrongNumArgs;
+ } else if (strcmp(subCmd, "objtype") == 0) {
+ const char *typeName;
+
+ /*
+ * return an object containing the name of the argument's type
+ * of internal rep. If none exists, return "none".
+ */
+
+ if (objc != 3) {
+ goto wrongNumArgs;
+ }
+ if (objv[2]->typePtr == NULL) {
+ Tcl_SetObjResult(interp, Tcl_NewStringObj("none", -1));
+ } else {
+ typeName = objv[2]->typePtr->name;
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(typeName, -1));
}
- if (GetVariableIndex(interp, objv[3], &destIndex) != TCL_OK) {
+ } else if (strcmp(subCmd, "refcount") == 0) {
+ char buf[TCL_INTEGER_SPACE];
+
+ if (objc != 3) {
+ goto wrongNumArgs;
+ }
+ index = Tcl_GetString(objv[2]);
+ if (GetVariableIndex(interp, index, &varIndex) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ if (CheckIfVarUnset(interp, varIndex)) {
return TCL_ERROR;
}
- SetVarToObj(varPtr, destIndex, Tcl_DuplicateObj(varPtr[varIndex]));
- Tcl_SetObjResult(interp, varPtr[destIndex]);
- break;
- case TESTOBJ_INVALIDATESTRINGREP:
- if (objc != 3) {
- goto wrongNumArgs;
- }
- Tcl_InvalidateStringRep(varPtr[varIndex]);
- Tcl_SetObjResult(interp, varPtr[varIndex]);
- break;
- case TESTOBJ_REFCOUNT:
- if (objc != 3) {
- goto wrongNumArgs;
- }
- Tcl_SetObjResult(interp, Tcl_NewWideIntObj(varPtr[varIndex]->refCount));
- break;
- case TESTOBJ_TYPE:
- if (objc != 3) {
- goto wrongNumArgs;
+ TclFormatInt(buf, varPtr[varIndex]->refCount);
+ Tcl_SetResult(interp, buf, TCL_VOLATILE);
+ } else if (strcmp(subCmd, "type") == 0) {
+ if (objc != 3) {
+ goto wrongNumArgs;
+ }
+ index = Tcl_GetString(objv[2]);
+ if (GetVariableIndex(interp, index, &varIndex) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ if (CheckIfVarUnset(interp, varIndex)) {
+ return TCL_ERROR;
}
- if (varPtr[varIndex]->typePtr == NULL) { /* a string! */
+ if (varPtr[varIndex]->typePtr == NULL) { /* a string! */
Tcl_AppendToObj(Tcl_GetObjResult(interp), "string", -1);
-#ifndef TCL_WIDE_INT_IS_LONG
- } else if (!strcmp(varPtr[varIndex]->typePtr->name, "wideInt")) {
- Tcl_AppendToObj(Tcl_GetObjResult(interp),
- "int", -1);
-#endif
- } else {
- Tcl_AppendToObj(Tcl_GetObjResult(interp),
- varPtr[varIndex]->typePtr->name, -1);
+ } else {
+ Tcl_AppendToObj(Tcl_GetObjResult(interp),
+ varPtr[varIndex]->typePtr->name, -1);
+ }
+ } else if (strcmp(subCmd, "types") == 0) {
+ if (objc != 2) {
+ goto wrongNumArgs;
+ }
+ if (Tcl_AppendAllObjTypes(interp,
+ Tcl_GetObjResult(interp)) != TCL_OK) {
+ return TCL_ERROR;
}
- break;
- default:
- break;
+ } else {
+ Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
+ "bad option \"", Tcl_GetString(objv[1]),
+ "\": must be assign, convert, duplicate, freeallvars, "
+ "newobj, objcount, objtype, refcount, type, or types", NULL);
+ return TCL_ERROR;
}
-
return TCL_OK;
}
@@ -1274,23 +1096,20 @@ TestobjCmd(
static int
TeststringobjCmd(
- TCL_UNUSED(void *),
+ ClientData clientData, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
- unsigned short *unicode;
- Tcl_Size size, varIndex;
- int option, i;
- Tcl_Size length;
+ int varIndex, option, i, length;
+ Tcl_UniChar *unicode;
#define MAX_STRINGS 11
- const char *string, *strings[MAX_STRINGS+1];
- String *strPtr;
- Tcl_Obj **varPtr;
- static const char *const options[] = {
+ char *index, *string, *strings[MAX_STRINGS+1];
+ TestString *strPtr;
+ static const char *options[] = {
"append", "appendstrings", "get", "get2", "length", "length2",
- "set", "set2", "setlength", "maxchars", "range", "appendself",
- "appendself2", "newunicode", NULL
+ "set", "set2", "setlength", "ualloc", "getunicode",
+ "appendself", "appendself2", NULL
};
if (objc < 3) {
@@ -1299,8 +1118,8 @@ TeststringobjCmd(
return TCL_ERROR;
}
- varPtr = GetVarPtr(interp);
- if (GetVariableIndex(interp, objv[2], &varIndex) != TCL_OK) {
+ index = Tcl_GetString(objv[2]);
+ if (GetVariableIndex(interp, index, &varIndex) != TCL_OK) {
return TCL_ERROR;
}
@@ -1313,11 +1132,11 @@ TeststringobjCmd(
if (objc != 5) {
goto wrongNumArgs;
}
- if (Tcl_GetIntForIndex(interp, objv[4], TCL_INDEX_NONE, &length) != TCL_OK) {
+ if (Tcl_GetIntFromObj(interp, objv[4], &length) != TCL_OK) {
return TCL_ERROR;
}
if (varPtr[varIndex] == NULL) {
- SetVarToObj(varPtr, varIndex, Tcl_NewObj());
+ SetVarToObj(varIndex, Tcl_NewObj());
}
/*
@@ -1326,9 +1145,10 @@ TeststringobjCmd(
*/
if (Tcl_IsShared(varPtr[varIndex])) {
- SetVarToObj(varPtr, varIndex, Tcl_DuplicateObj(varPtr[varIndex]));
+ SetVarToObj(varIndex, Tcl_DuplicateObj(varPtr[varIndex]));
}
- Tcl_AppendToObj(varPtr[varIndex], Tcl_GetString(objv[3]), length);
+ string = Tcl_GetString(objv[3]);
+ Tcl_AppendToObj(varPtr[varIndex], string, length);
Tcl_SetObjResult(interp, varPtr[varIndex]);
break;
case 1: /* appendstrings */
@@ -1336,7 +1156,7 @@ TeststringobjCmd(
goto wrongNumArgs;
}
if (varPtr[varIndex] == NULL) {
- SetVarToObj(varPtr, varIndex, Tcl_NewObj());
+ SetVarToObj(varIndex, Tcl_NewObj());
}
/*
@@ -1345,7 +1165,7 @@ TeststringobjCmd(
*/
if (Tcl_IsShared(varPtr[varIndex])) {
- SetVarToObj(varPtr, varIndex, Tcl_DuplicateObj(varPtr[varIndex]));
+ SetVarToObj(varIndex, Tcl_DuplicateObj(varPtr[varIndex]));
}
for (i = 3; i < objc; i++) {
strings[i-3] = Tcl_GetString(objv[i]);
@@ -1356,14 +1176,14 @@ TeststringobjCmd(
Tcl_AppendStringsToObj(varPtr[varIndex], strings[0], strings[1],
strings[2], strings[3], strings[4], strings[5],
strings[6], strings[7], strings[8], strings[9],
- strings[10], strings[11], (void *)NULL);
+ strings[10], strings[11]);
Tcl_SetObjResult(interp, varPtr[varIndex]);
break;
case 2: /* get */
if (objc != 3) {
goto wrongNumArgs;
}
- if (CheckIfVarUnset(interp, varPtr,varIndex)) {
+ if (CheckIfVarUnset(interp, varIndex)) {
return TCL_ERROR;
}
Tcl_SetObjResult(interp, varPtr[varIndex]);
@@ -1372,16 +1192,17 @@ TeststringobjCmd(
if (objc != 3) {
goto wrongNumArgs;
}
- if (CheckIfVarUnset(interp, varPtr, varIndex)) {
+ if (CheckIfVarUnset(interp, varIndex)) {
return TCL_ERROR;
}
- Tcl_AppendToObj(Tcl_GetObjResult(interp), Tcl_GetString(varPtr[varIndex]), -1);
+ string = Tcl_GetString(varPtr[varIndex]);
+ Tcl_AppendToObj(Tcl_GetObjResult(interp), string, -1);
break;
case 4: /* length */
if (objc != 3) {
goto wrongNumArgs;
}
- Tcl_SetWideIntObj(Tcl_GetObjResult(interp), (varPtr[varIndex] != NULL)
+ Tcl_SetIntObj(Tcl_GetObjResult(interp), (varPtr[varIndex] != NULL)
? varPtr[varIndex]->length : -1);
break;
case 5: /* length2 */
@@ -1389,18 +1210,13 @@ TeststringobjCmd(
goto wrongNumArgs;
}
if (varPtr[varIndex] != NULL) {
- const Tcl_ObjType *objType = Tcl_GetObjType("string");
- if (objType != NULL) {
- Tcl_ConvertToType(NULL, varPtr[varIndex], objType);
- strPtr = (String *)varPtr[varIndex]->internalRep.twoPtrValue.ptr1;
- length = (int) strPtr->allocated;
- } else {
- length = TCL_INDEX_NONE;
- }
+ strPtr = (TestString *)
+ (varPtr[varIndex])->internalRep.twoPtrValue.ptr1;
+ length = (int) strPtr->allocated;
} else {
- length = TCL_INDEX_NONE;
+ length = -1;
}
- Tcl_SetWideIntObj(Tcl_GetObjResult(interp), length);
+ Tcl_SetIntObj(Tcl_GetObjResult(interp), length);
break;
case 6: /* set */
if (objc != 4) {
@@ -1416,12 +1232,12 @@ TeststringobjCmd(
* is "copy on write".
*/
- string = Tcl_GetStringFromObj(objv[3], &size);
+ string = Tcl_GetStringFromObj(objv[3], &length);
if ((varPtr[varIndex] != NULL)
&& !Tcl_IsShared(varPtr[varIndex])) {
- Tcl_SetStringObj(varPtr[varIndex], string, size);
+ Tcl_SetStringObj(varPtr[varIndex], string, length);
} else {
- SetVarToObj(varPtr, varIndex, Tcl_NewStringObj(string, size));
+ SetVarToObj(varIndex, Tcl_NewStringObj(string, length));
}
Tcl_SetObjResult(interp, varPtr[varIndex]);
break;
@@ -1429,55 +1245,44 @@ TeststringobjCmd(
if (objc != 4) {
goto wrongNumArgs;
}
- SetVarToObj(varPtr, varIndex, objv[3]);
+ SetVarToObj(varIndex, objv[3]);
break;
case 8: /* setlength */
if (objc != 4) {
goto wrongNumArgs;
}
- if (Tcl_GetIntForIndex(interp, objv[3], TCL_INDEX_NONE, &length) != TCL_OK) {
+ if (Tcl_GetIntFromObj(interp, objv[3], &length) != TCL_OK) {
return TCL_ERROR;
}
if (varPtr[varIndex] != NULL) {
Tcl_SetObjLength(varPtr[varIndex], length);
}
break;
- case 9: /* maxchars */
+ case 9: /* ualloc */
if (objc != 3) {
goto wrongNumArgs;
}
if (varPtr[varIndex] != NULL) {
- const Tcl_ObjType *objType = Tcl_GetObjType("string");
- if (objType != NULL) {
- Tcl_ConvertToType(NULL, varPtr[varIndex],objType);
- strPtr = (String *)varPtr[varIndex]->internalRep.twoPtrValue.ptr1;
- length = strPtr->maxChars;
- } else {
- length = TCL_INDEX_NONE;
- }
+ strPtr = (TestString *)
+ (varPtr[varIndex])->internalRep.twoPtrValue.ptr1;
+ length = (int) strPtr->uallocated;
} else {
- length = TCL_INDEX_NONE;
+ length = -1;
}
- Tcl_SetWideIntObj(Tcl_GetObjResult(interp), length);
+ Tcl_SetIntObj(Tcl_GetObjResult(interp), length);
break;
- case 10: { /* range */
- Tcl_Size first, last;
- if (objc != 5) {
+ case 10: /* getunicode */
+ if (objc != 3) {
goto wrongNumArgs;
}
- if ((Tcl_GetIntForIndex(interp, objv[3], TCL_INDEX_NONE, &first) != TCL_OK)
- || (Tcl_GetIntForIndex(interp, objv[4], TCL_INDEX_NONE, &last) != TCL_OK)) {
- return TCL_ERROR;
- }
- Tcl_SetObjResult(interp, Tcl_GetRange(varPtr[varIndex], first, last));
+ Tcl_GetUnicodeFromObj(varPtr[varIndex], NULL);
break;
- }
case 11: /* appendself */
if (objc != 4) {
goto wrongNumArgs;
}
if (varPtr[varIndex] == NULL) {
- SetVarToObj(varPtr, varIndex, Tcl_NewObj());
+ SetVarToObj(varIndex, Tcl_NewObj());
}
/*
@@ -1486,21 +1291,21 @@ TeststringobjCmd(
*/
if (Tcl_IsShared(varPtr[varIndex])) {
- SetVarToObj(varPtr, varIndex, Tcl_DuplicateObj(varPtr[varIndex]));
+ SetVarToObj(varIndex, Tcl_DuplicateObj(varPtr[varIndex]));
}
- string = Tcl_GetStringFromObj(varPtr[varIndex], &size);
+ string = Tcl_GetStringFromObj(varPtr[varIndex], &length);
- if (Tcl_GetIntForIndex(interp, objv[3], size-1, &length) != TCL_OK) {
+ if (Tcl_GetIntFromObj(interp, objv[3], &i) != TCL_OK) {
return TCL_ERROR;
}
- if (length == TCL_INDEX_NONE) {
+ if ((i < 0) || (i > length)) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"index value out of range", -1));
return TCL_ERROR;
}
- Tcl_AppendToObj(varPtr[varIndex], string + length, size - length);
+ Tcl_AppendToObj(varPtr[varIndex], string + i, length - i);
Tcl_SetObjResult(interp, varPtr[varIndex]);
break;
case 12: /* appendself2 */
@@ -1508,7 +1313,7 @@ TeststringobjCmd(
goto wrongNumArgs;
}
if (varPtr[varIndex] == NULL) {
- SetVarToObj(varPtr, varIndex, Tcl_NewObj());
+ SetVarToObj(varIndex, Tcl_NewObj());
}
/*
@@ -1517,40 +1322,23 @@ TeststringobjCmd(
*/
if (Tcl_IsShared(varPtr[varIndex])) {
- SetVarToObj(varPtr, varIndex, Tcl_DuplicateObj(varPtr[varIndex]));
+ SetVarToObj(varIndex, Tcl_DuplicateObj(varPtr[varIndex]));
}
- unicode = Tcl_GetUnicodeFromObj(varPtr[varIndex], &size);
+ unicode = Tcl_GetUnicodeFromObj(varPtr[varIndex], &length);
- if (Tcl_GetIntForIndex(interp, objv[3], size-1, &length) != TCL_OK) {
+ if (Tcl_GetIntFromObj(interp, objv[3], &i) != TCL_OK) {
return TCL_ERROR;
}
- if (length == TCL_INDEX_NONE) {
+ if ((i < 0) || (i > length)) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"index value out of range", -1));
return TCL_ERROR;
}
- Tcl_AppendUnicodeToObj(varPtr[varIndex], unicode + length, size - length);
+ Tcl_AppendUnicodeToObj(varPtr[varIndex], unicode + i, length - i);
Tcl_SetObjResult(interp, varPtr[varIndex]);
break;
- case 13: /* newunicode*/
- unicode = (unsigned short *)ckalloc(((unsigned)objc - 3) * sizeof(unsigned short));
- for (i = 0; i < (objc - 3); ++i) {
- int val;
- if (Tcl_GetIntFromObj(interp, objv[i + 3], &val) != TCL_OK) {
- break;
- }
- unicode[i] = (unsigned short)val;
- }
- if (i < (objc-3)) {
- ckfree(unicode);
- return TCL_ERROR;
- }
- SetVarToObj(varPtr, varIndex, Tcl_NewUnicodeObj(unicode, objc - 3));
- Tcl_SetObjResult(interp, varPtr[varIndex]);
- ckfree(unicode);
- break;
}
return TCL_OK;
@@ -1577,8 +1365,7 @@ TeststringobjCmd(
static void
SetVarToObj(
- Tcl_Obj **varPtr,
- Tcl_Size varIndex, /* Designates the assignment variable. */
+ int varIndex, /* Designates the assignment variable. */
Tcl_Obj *objPtr) /* Points to object to assign to var. */
{
if (varPtr[varIndex] != NULL) {
@@ -1609,17 +1396,17 @@ SetVarToObj(
static int
GetVariableIndex(
Tcl_Interp *interp, /* Interpreter for error reporting. */
- Tcl_Obj *obj, /* The variable index
+ const char *string, /* String containing a variable index
* specified as a nonnegative number less than
* NUMBER_OF_OBJECT_VARS. */
- Tcl_Size *indexPtr) /* Place to store converted result. */
+ int *indexPtr) /* Place to store converted result. */
{
- Tcl_Size index;
+ int index;
- if (Tcl_GetIntForIndex(interp, obj, NUMBER_OF_OBJECT_VARS - 1, &index) != TCL_OK) {
+ if (Tcl_GetInt(interp, string, &index) != TCL_OK) {
return TCL_ERROR;
}
- if (index == TCL_INDEX_NONE) {
+ if (index < 0 || index >= NUMBER_OF_OBJECT_VARS) {
Tcl_ResetResult(interp);
Tcl_AppendToObj(Tcl_GetObjResult(interp), "bad variable index", -1);
return TCL_ERROR;
@@ -1650,13 +1437,12 @@ GetVariableIndex(
static int
CheckIfVarUnset(
Tcl_Interp *interp, /* Interpreter for error reporting. */
- Tcl_Obj ** varPtr,
- Tcl_Size varIndex) /* Index of the test variable to check. */
+ int varIndex) /* Index of the test variable to check. */
{
- if (varIndex < 0 || varPtr[varIndex] == NULL) {
+ if (varPtr[varIndex] == NULL) {
char buf[32 + TCL_INTEGER_SPACE];
- snprintf(buf, sizeof(buf), "variable %" TCL_SIZE_MODIFIER "d is unset (NULL)", varIndex);
+ sprintf(buf, "variable %d is unset (NULL)", varIndex);
Tcl_ResetResult(interp);
Tcl_AppendToObj(Tcl_GetObjResult(interp), buf, -1);
return 1;
generated by cgit v0.12 at 2025-12-20 09:40:43 (GMT)