summaryrefslogtreecommitdiffstats
path: root/generic/tclTestObj.c
diff options
context:
space:
mode:
Diffstat (limited to 'generic/tclTestObj.c')
-rw-r--r--generic/tclTestObj.c615
1 files changed, 405 insertions, 210 deletions
diff --git a/generic/tclTestObj.c b/generic/tclTestObj.c
index 8e9dc93..8597bbc 100644
--- a/generic/tclTestObj.c
+++ b/generic/tclTestObj.c
@@ -1,61 +1,57 @@
-/*
+/*
* tclTestObj.c --
*
- * This file contains C command procedures for the additional Tcl
- * commands that are used for testing implementations of the Tcl object
- * types. These commands are not normally included in Tcl
- * applications; they're only used for testing.
+ * This file contains C command functions for the additional Tcl commands
+ * that are used for testing implementations of the Tcl object types.
+ * These commands are not normally included in Tcl applications; they're
+ * only used for testing.
*
* 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.
+ * See the file "license.terms" for information on usage and redistribution of
+ * this file, and for a DISCLAIMER OF ALL WARRANTIES.
*/
#include "tclInt.h"
+#include "tommath.h"
/*
* 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 *.
+ * the values of Tcl object-valued variables. varPtr[i] is the i-th variable's
+ * Tcl_Obj *.
*/
#define NUMBER_OF_OBJECT_VARS 20
static Tcl_Obj *varPtr[NUMBER_OF_OBJECT_VARS];
/*
- * Forward declarations for procedures defined later in this file:
+ * Forward declarations for functions defined later in this file:
*/
-static int CheckIfVarUnset _ANSI_ARGS_((Tcl_Interp *interp,
- int varIndex));
-static int GetVariableIndex _ANSI_ARGS_((Tcl_Interp *interp,
- char *string, int *indexPtr));
-static void SetVarToObj _ANSI_ARGS_((int varIndex,
- Tcl_Obj *objPtr));
-int TclObjTest_Init _ANSI_ARGS_((Tcl_Interp *interp));
-static int TestbooleanobjCmd _ANSI_ARGS_((ClientData dummy,
- Tcl_Interp *interp, int objc,
- Tcl_Obj *CONST objv[]));
-static int TestconvertobjCmd _ANSI_ARGS_((ClientData dummy,
- Tcl_Interp *interp, int objc,
- Tcl_Obj *CONST objv[]));
-static int TestdoubleobjCmd _ANSI_ARGS_((ClientData dummy,
- Tcl_Interp *interp, int objc,
- Tcl_Obj *CONST objv[]));
-static int TestindexobjCmd _ANSI_ARGS_((ClientData dummy,
- Tcl_Interp *interp, int objc,
- Tcl_Obj *CONST objv[]));
-static int TestintobjCmd _ANSI_ARGS_((ClientData dummy,
- Tcl_Interp *interp, int objc,
- Tcl_Obj *CONST objv[]));
-static int TestobjCmd _ANSI_ARGS_((ClientData dummy,
- Tcl_Interp *interp, int objc,
- Tcl_Obj *CONST objv[]));
-static int TeststringobjCmd _ANSI_ARGS_((ClientData dummy,
+static int CheckIfVarUnset(Tcl_Interp *interp, int varIndex);
+static int GetVariableIndex(Tcl_Interp *interp,
+ 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[]));
+ 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;
@@ -63,14 +59,13 @@ typedef struct TestString {
size_t uallocated;
Tcl_UniChar unicode[2];
} TestString;
-
/*
*----------------------------------------------------------------------
*
* TclObjTest_Init --
*
- * This procedure creates additional commands that are used to test the
+ * This function creates additional commands that are used to test the
* Tcl object support.
*
* Results:
@@ -84,154 +79,213 @@ typedef struct TestString {
*/
int
-TclObjTest_Init(interp)
- Tcl_Interp *interp;
+TclObjTest_Init(
+ Tcl_Interp *interp)
{
register int i;
-
+
for (i = 0; i < NUMBER_OF_OBJECT_VARS; i++) {
varPtr[i] = NULL;
}
-
+
+ Tcl_CreateObjCommand(interp, "testbignumobj", TestbignumobjCmd,
+ (ClientData) 0, NULL);
Tcl_CreateObjCommand(interp, "testbooleanobj", TestbooleanobjCmd,
- (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
- Tcl_CreateObjCommand(interp, "testconvertobj", TestconvertobjCmd,
- (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
+ (ClientData) 0, NULL);
Tcl_CreateObjCommand(interp, "testdoubleobj", TestdoubleobjCmd,
- (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
+ (ClientData) 0, NULL);
Tcl_CreateObjCommand(interp, "testintobj", TestintobjCmd,
- (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
+ (ClientData) 0, NULL);
Tcl_CreateObjCommand(interp, "testindexobj", TestindexobjCmd,
- (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
- Tcl_CreateObjCommand(interp, "testobj", TestobjCmd,
- (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
+ (ClientData) 0, NULL);
+ Tcl_CreateObjCommand(interp, "testlistobj", TestlistobjCmd,
+ (ClientData) 0, NULL);
+ Tcl_CreateObjCommand(interp, "testobj", TestobjCmd, (ClientData) 0, NULL);
Tcl_CreateObjCommand(interp, "teststringobj", TeststringobjCmd,
- (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
+ (ClientData) 0, NULL);
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
- * TestbooleanobjCmd --
+ * TestbignumobjCmd --
*
- * This procedure implements the "testbooleanobj" command. It is used
- * to test the boolean Tcl object type implementation.
+ * This function implmenets the "testbignumobj" command. It is used
+ * to exercise the bignum Tcl object type implementation.
*
* Results:
- * A standard Tcl object result.
+ * Returns a standard Tcl object result.
*
* Side effects:
- * Creates and frees boolean objects, and also converts objects to
- * have boolean type.
+ * Creates and frees bignum objects; converts objects to have bignum
+ * type.
*
*----------------------------------------------------------------------
*/
static int
-TestbooleanobjCmd(clientData, interp, objc, objv)
- ClientData clientData; /* Not used. */
- Tcl_Interp *interp; /* Current interpreter. */
- int objc; /* Number of arguments. */
- Tcl_Obj *CONST objv[]; /* Argument objects. */
+TestbignumobjCmd(
+ ClientData clientData, /* unused */
+ Tcl_Interp *interp, /* Tcl interpreter */
+ int objc, /* Argument count */
+ Tcl_Obj *const objv[]) /* Argument vector */
{
- int varIndex, boolValue;
- char *index, *subCmd;
+ const char * subcmds[] = {
+ "set", "get", "mult10", "div10", NULL
+ };
+ enum options {
+ BIGNUM_SET, BIGNUM_GET, BIGNUM_MULT10, BIGNUM_DIV10
+ };
+
+ int index, varIndex;
+ char* string;
+ mp_int bignumValue, newValue;
if (objc < 3) {
- wrongNumArgs:
- Tcl_WrongNumArgs(interp, 1, objv, "option arg ?arg ...?");
+ Tcl_WrongNumArgs(interp, 1, objv, "option ?arg?...");
return TCL_ERROR;
}
-
- index = Tcl_GetString(objv[2]);
- if (GetVariableIndex(interp, index, &varIndex) != TCL_OK) {
+ if (Tcl_GetIndexFromObj(interp, objv[1], subcmds, "option", 0,
+ &index) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ string = Tcl_GetString(objv[2]);
+ if (GetVariableIndex(interp, string, &varIndex) != TCL_OK) {
return TCL_ERROR;
}
- subCmd = Tcl_GetString(objv[1]);
- if (strcmp(subCmd, "set") == 0) {
+ switch (index) {
+ case BIGNUM_SET:
if (objc != 4) {
- goto wrongNumArgs;
+ Tcl_WrongNumArgs(interp, 2, objv, "var value");
+ return TCL_ERROR;
}
- if (Tcl_GetBooleanFromObj(interp, objv[3], &boolValue) != TCL_OK) {
+ string = Tcl_GetString(objv[3]);
+ if (mp_init(&bignumValue) != MP_OKAY) {
+ Tcl_SetObjResult(interp,
+ Tcl_NewStringObj("error in mp_init", -1));
+ return TCL_ERROR;
+ }
+ if (mp_read_radix(&bignumValue, string, 10) != MP_OKAY) {
+ mp_clear(&bignumValue);
+ Tcl_SetObjResult(interp,
+ Tcl_NewStringObj("error in mp_read_radix", -1));
return TCL_ERROR;
}
/*
* If the object currently bound to the variable with index varIndex
* has ref count 1 (i.e. the object is unshared) we can modify that
- * object directly. Otherwise, if RC>1 (i.e. the object is shared),
+ * object directly. Otherwise, if RC>1 (i.e. the object is shared),
* we must create a new object to modify/set and decrement the old
* formerly-shared object's ref count. This is "copy on write".
*/
if ((varPtr[varIndex] != NULL) && !Tcl_IsShared(varPtr[varIndex])) {
- Tcl_SetBooleanObj(varPtr[varIndex], boolValue);
+ Tcl_SetBignumObj(varPtr[varIndex], &bignumValue);
} else {
- SetVarToObj(varIndex, Tcl_NewBooleanObj(boolValue));
+ SetVarToObj(varIndex, Tcl_NewBignumObj(&bignumValue));
}
- Tcl_SetObjResult(interp, varPtr[varIndex]);
- } else if (strcmp(subCmd, "get") == 0) {
+ break;
+
+ case BIGNUM_GET:
if (objc != 3) {
- goto wrongNumArgs;
+ Tcl_WrongNumArgs(interp, 2, objv, "varIndex");
+ return TCL_ERROR;
}
if (CheckIfVarUnset(interp, varIndex)) {
return TCL_ERROR;
}
- Tcl_SetObjResult(interp, varPtr[varIndex]);
- } else if (strcmp(subCmd, "not") == 0) {
+ break;
+
+ case BIGNUM_MULT10:
if (objc != 3) {
- goto wrongNumArgs;
+ Tcl_WrongNumArgs(interp, 2, objv, "varIndex");
+ return TCL_ERROR;
}
if (CheckIfVarUnset(interp, varIndex)) {
return TCL_ERROR;
}
- if (Tcl_GetBooleanFromObj(interp, varPtr[varIndex],
- &boolValue) != TCL_OK) {
+ if (Tcl_GetBignumFromObj(interp, varPtr[varIndex],
+ &bignumValue) != TCL_OK) {
return TCL_ERROR;
}
+ 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_SetBooleanObj(varPtr[varIndex], !boolValue);
+ Tcl_SetBignumObj(varPtr[varIndex], &newValue);
} else {
- SetVarToObj(varIndex, Tcl_NewBooleanObj(!boolValue));
+ SetVarToObj(varIndex, Tcl_NewBignumObj(&newValue));
+ }
+ break;
+
+ case BIGNUM_DIV10:
+ if (objc != 3) {
+ Tcl_WrongNumArgs(interp, 2, objv, "varIndex");
+ return TCL_ERROR;
+ }
+ if (CheckIfVarUnset(interp, varIndex)) {
+ return TCL_ERROR;
+ }
+ if (Tcl_GetBignumFromObj(interp, varPtr[varIndex],
+ &bignumValue) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ 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;
+ }
+ mp_clear(&bignumValue);
+ if (!Tcl_IsShared(varPtr[varIndex])) {
+ Tcl_SetBignumObj(varPtr[varIndex], &newValue);
+ } else {
+ SetVarToObj(varIndex, Tcl_NewBignumObj(&newValue));
}
- Tcl_SetObjResult(interp, varPtr[varIndex]);
- } else {
- Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
- "bad option \"", Tcl_GetString(objv[1]),
- "\": must be set, get, or not", (char *) NULL);
- return TCL_ERROR;
}
+
+ Tcl_SetObjResult(interp, varPtr[varIndex]);
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
- * TestconvertobjCmd --
+ * TestbooleanobjCmd --
*
- * This procedure implements the "testconvertobj" command. It is used
- * to test converting objects to new types.
+ * This function implements the "testbooleanobj" command. It is used to
+ * test the boolean Tcl object type implementation.
*
* Results:
* A standard Tcl object result.
*
* Side effects:
- * Converts objects to new types.
+ * Creates and frees boolean objects, and also converts objects to
+ * have boolean type.
*
*----------------------------------------------------------------------
*/
static int
-TestconvertobjCmd(clientData, interp, objc, objv)
- ClientData clientData; /* Not used. */
- Tcl_Interp *interp; /* Current interpreter. */
- int objc; /* Number of arguments. */
- Tcl_Obj *CONST objv[]; /* Argument objects. */
+TestbooleanobjCmd(
+ ClientData clientData, /* Not used. */
+ Tcl_Interp *interp, /* Current interpreter. */
+ int objc, /* Number of arguments. */
+ Tcl_Obj *const objv[]) /* Argument objects. */
{
- char *subCmd;
- char buf[20];
+ int varIndex, boolValue;
+ char *index, *subCmd;
if (objc < 3) {
wrongNumArgs:
@@ -239,22 +293,63 @@ TestconvertobjCmd(clientData, interp, objc, objv)
return TCL_ERROR;
}
+ index = Tcl_GetString(objv[2]);
+ if (GetVariableIndex(interp, index, &varIndex) != TCL_OK) {
+ return TCL_ERROR;
+ }
+
subCmd = Tcl_GetString(objv[1]);
- if (strcmp(subCmd, "double") == 0) {
- double d;
+ if (strcmp(subCmd, "set") == 0) {
+ if (objc != 4) {
+ goto wrongNumArgs;
+ }
+ if (Tcl_GetBooleanFromObj(interp, objv[3], &boolValue) != TCL_OK) {
+ return TCL_ERROR;
+ }
+
+ /*
+ * If the object currently bound to the variable with index varIndex
+ * has ref count 1 (i.e. the object is unshared) we can modify that
+ * object directly. Otherwise, if RC>1 (i.e. the object is shared),
+ * we must create a new object to modify/set and decrement the old
+ * formerly-shared object's ref count. This is "copy on write".
+ */
+ if ((varPtr[varIndex] != NULL) && !Tcl_IsShared(varPtr[varIndex])) {
+ Tcl_SetBooleanObj(varPtr[varIndex], boolValue);
+ } else {
+ SetVarToObj(varIndex, Tcl_NewBooleanObj(boolValue));
+ }
+ Tcl_SetObjResult(interp, varPtr[varIndex]);
+ } else if (strcmp(subCmd, "get") == 0) {
if (objc != 3) {
goto wrongNumArgs;
}
- if (Tcl_GetDoubleFromObj(interp, objv[2], &d) != TCL_OK) {
+ if (CheckIfVarUnset(interp, varIndex)) {
return TCL_ERROR;
}
- sprintf(buf, "%f", d);
- Tcl_AppendToObj(Tcl_GetObjResult(interp), buf, -1);
+ Tcl_SetObjResult(interp, varPtr[varIndex]);
+ } else if (strcmp(subCmd, "not") == 0) {
+ if (objc != 3) {
+ goto wrongNumArgs;
+ }
+ if (CheckIfVarUnset(interp, varIndex)) {
+ return TCL_ERROR;
+ }
+ if (Tcl_GetBooleanFromObj(interp, varPtr[varIndex],
+ &boolValue) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ if (!Tcl_IsShared(varPtr[varIndex])) {
+ Tcl_SetBooleanObj(varPtr[varIndex], !boolValue);
+ } else {
+ SetVarToObj(varIndex, Tcl_NewBooleanObj(!boolValue));
+ }
+ Tcl_SetObjResult(interp, varPtr[varIndex]);
} else {
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
"bad option \"", Tcl_GetString(objv[1]),
- "\": must be double", (char *) NULL);
+ "\": must be set, get, or not", NULL);
return TCL_ERROR;
}
return TCL_OK;
@@ -265,8 +360,8 @@ TestconvertobjCmd(clientData, interp, objc, objv)
*
* TestdoubleobjCmd --
*
- * This procedure implements the "testdoubleobj" command. It is used
- * to test the double-precision floating point Tcl object type
+ * This function implements the "testdoubleobj" command. It is used to
+ * test the double-precision floating point Tcl object type
* implementation.
*
* Results:
@@ -280,16 +375,16 @@ TestconvertobjCmd(clientData, interp, objc, objv)
*/
static int
-TestdoubleobjCmd(clientData, interp, objc, objv)
- ClientData clientData; /* Not used. */
- Tcl_Interp *interp; /* Current interpreter. */
- int objc; /* Number of arguments. */
- Tcl_Obj *CONST objv[]; /* Argument objects. */
+TestdoubleobjCmd(
+ ClientData clientData, /* Not used. */
+ Tcl_Interp *interp, /* Current interpreter. */
+ int objc, /* Number of arguments. */
+ Tcl_Obj *const objv[]) /* Argument objects. */
{
int varIndex;
double doubleValue;
char *index, *subCmd, *string;
-
+
if (objc < 3) {
wrongNumArgs:
Tcl_WrongNumArgs(interp, 1, objv, "option arg ?arg ...?");
@@ -314,8 +409,8 @@ TestdoubleobjCmd(clientData, interp, objc, objv)
/*
* If the object currently bound to the variable with index varIndex
* has ref count 1 (i.e. the object is unshared) we can modify that
- * object directly. Otherwise, if RC>1 (i.e. the object is shared),
- * we must create a new object to modify/set and decrement the old
+ * object directly. Otherwise, if RC>1 (i.e. the object is shared), we
+ * must create a new object to modify/set and decrement the old
* formerly-shared object's ref count. This is "copy on write".
*/
@@ -370,7 +465,7 @@ TestdoubleobjCmd(clientData, interp, objc, objv)
} else {
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
"bad option \"", Tcl_GetString(objv[1]),
- "\": must be set, get, mult10, or div10", (char *) NULL);
+ "\": must be set, get, mult10, or div10", NULL);
return TCL_ERROR;
}
return TCL_OK;
@@ -381,7 +476,7 @@ TestdoubleobjCmd(clientData, interp, objc, objv)
*
* TestindexobjCmd --
*
- * This procedure implements the "testindexobj" command. It is used to
+ * This function implements the "testindexobj" command. It is used to
* test the index Tcl object type implementation.
*
* Results:
@@ -395,15 +490,15 @@ TestdoubleobjCmd(clientData, interp, objc, objv)
*/
static int
-TestindexobjCmd(clientData, interp, objc, objv)
- ClientData clientData; /* Not used. */
- Tcl_Interp *interp; /* Current interpreter. */
- int objc; /* Number of arguments. */
- Tcl_Obj *CONST objv[]; /* Argument objects. */
+TestindexobjCmd(
+ ClientData clientData, /* Not used. */
+ Tcl_Interp *interp, /* Current interpreter. */
+ int objc, /* Number of arguments. */
+ Tcl_Obj *const objv[]) /* Argument objects. */
{
int allowAbbrev, index, index2, setError, i, result;
- CONST char **argv;
- static CONST char *tablePtr[] = {"a", "b", "check", (char *) NULL};
+ const char **argv;
+ static const char *tablePtr[] = {"a", "b", "check", NULL};
/*
* Keep this structure declaration in sync with tclIndexObj.c
*/
@@ -417,20 +512,19 @@ TestindexobjCmd(clientData, interp, objc, objv)
if ((objc == 3) && (strcmp(Tcl_GetString(objv[1]),
"check") == 0)) {
/*
- * This code checks to be sure that the results of
- * Tcl_GetIndexFromObj are properly cached in the object and
- * returned on subsequent lookups.
+ * This code checks to be sure that the results of Tcl_GetIndexFromObj
+ * are properly cached in the object and returned on subsequent
+ * lookups.
*/
if (Tcl_GetIntFromObj(interp, objv[2], &index2) != TCL_OK) {
return TCL_ERROR;
}
- Tcl_GetIndexFromObj((Tcl_Interp *) NULL, objv[1], tablePtr,
- "token", 0, &index);
+ Tcl_GetIndexFromObj(NULL, objv[1], tablePtr, "token", 0, &index);
indexRep = (struct IndexRep *) objv[1]->internalRep.otherValuePtr;
indexRep->index = index2;
- result = Tcl_GetIndexFromObj((Tcl_Interp *) NULL, objv[1],
+ result = Tcl_GetIndexFromObj(NULL, objv[1],
tablePtr, "token", 0, &index);
if (result == TCL_OK) {
Tcl_SetIntObj(Tcl_GetObjResult(interp), index);
@@ -450,17 +544,17 @@ TestindexobjCmd(clientData, interp, objc, objv)
return TCL_ERROR;
}
- argv = (CONST char **) ckalloc((unsigned) ((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.
+ * 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
@@ -486,7 +580,7 @@ TestindexobjCmd(clientData, interp, objc, objv)
*
* TestintobjCmd --
*
- * This procedure implements the "testintobj" command. It is used to
+ * This function implements the "testintobj" command. It is used to
* test the int Tcl object type implementation.
*
* Results:
@@ -500,16 +594,16 @@ TestindexobjCmd(clientData, interp, objc, objv)
*/
static int
-TestintobjCmd(clientData, interp, objc, objv)
- ClientData clientData; /* Not used. */
- Tcl_Interp *interp; /* Current interpreter. */
- int objc; /* Number of arguments. */
- Tcl_Obj *CONST objv[]; /* Argument objects. */
+TestintobjCmd(
+ ClientData clientData, /* Not used. */
+ Tcl_Interp *interp, /* Current interpreter. */
+ int objc, /* Number of arguments. */
+ Tcl_Obj *const objv[]) /* Argument objects. */
{
int intValue, varIndex, i;
long longValue;
char *index, *subCmd, *string;
-
+
if (objc < 3) {
wrongNumArgs:
Tcl_WrongNumArgs(interp, 1, objv, "option arg ?arg ...?");
@@ -535,8 +629,8 @@ TestintobjCmd(clientData, interp, objc, objv)
/*
* If the object currently bound to the variable with index varIndex
* has ref count 1 (i.e. the object is unshared) we can modify that
- * object directly. Otherwise, if RC>1 (i.e. the object is shared),
- * we must create a new object to modify/set and decrement the old
+ * object directly. Otherwise, if RC>1 (i.e. the object is shared), we
+ * must create a new object to modify/set and decrement the old
* formerly-shared object's ref count. This is "copy on write".
*/
@@ -616,18 +710,18 @@ TestintobjCmd(clientData, interp, objc, objv)
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 Tcl_GetIntFromObj returns an error if the long int held
- * in an integer object's internal representation is too large
- * to fit in an int.
+ * If long ints have more bits than ints on this platform, verify that
+ * Tcl_GetIntFromObj returns an error if the long int held in an
+ * integer object's internal representation is too large to fit in an
+ * int.
*/
-
+
if (objc != 3) {
goto wrongNumArgs;
}
#if (INT_MAX == LONG_MAX) /* int is same size as long int */
Tcl_AppendToObj(Tcl_GetObjResult(interp), "1", -1);
-#else
+#else
if ((varPtr[varIndex] != NULL) && !Tcl_IsShared(varPtr[varIndex])) {
Tcl_SetLongObj(varPtr[varIndex], LONG_MAX);
} else {
@@ -677,19 +771,114 @@ TestintobjCmd(clientData, interp, objc, objv)
} else {
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
"bad option \"", Tcl_GetString(objv[1]),
- "\": must be set, get, get2, mult10, or div10",
- (char *) NULL);
+ "\": must be set, get, get2, mult10, or div10", NULL);
return TCL_ERROR;
}
return TCL_OK;
}
/*
+ *-----------------------------------------------------------------------------
+ *
+ * TestlistobjCmd --
+ *
+ * This function implements the 'testlistobj' command. It is used to
+ * test a few possible corner cases in list object manipulation from
+ * C code that cannot occur at the Tcl level.
+ *
+ * Results:
+ * A standard Tcl object result.
+ *
+ * Side effects:
+ * Creates, manipulates and frees list objects.
+ *
+ *-----------------------------------------------------------------------------
+ */
+
+static int
+TestlistobjCmd(
+ 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 */
+ const char* subcommands[] = {
+ "set",
+ "get",
+ "replace"
+ };
+ enum listobjCmdIndex {
+ LISTOBJ_SET,
+ LISTOBJ_GET,
+ 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;
+ }
+ index = Tcl_GetString(objv[2]);
+ if (GetVariableIndex(interp, index, &varIndex) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ if (Tcl_GetIndexFromObj(interp, objv[1], subcommands, "command",
+ 0, &cmdIndex) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ switch(cmdIndex) {
+ case LISTOBJ_SET:
+ if ((varPtr[varIndex] != NULL) && !Tcl_IsShared(varPtr[varIndex])) {
+ Tcl_SetListObj(varPtr[varIndex], objc-3, objv+3);
+ } else {
+ SetVarToObj(varIndex, Tcl_NewListObj(objc-3, objv+3));
+ }
+ Tcl_SetObjResult(interp, varPtr[varIndex]);
+ break;
+
+ case LISTOBJ_GET:
+ if (objc != 3) {
+ Tcl_WrongNumArgs(interp, 2, objv, "varIndex");
+ return TCL_ERROR;
+ }
+ if (CheckIfVarUnset(interp, varIndex)) {
+ return TCL_ERROR;
+ }
+ Tcl_SetObjResult(interp, varPtr[varIndex]);
+ break;
+
+ case LISTOBJ_REPLACE:
+ if (objc < 5) {
+ Tcl_WrongNumArgs(interp, 2, objv,
+ "varIndex start count ?element...?");
+ return TCL_ERROR;
+ }
+ 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(varIndex, Tcl_DuplicateObj(varPtr[varIndex]));
+ }
+ Tcl_ResetResult(interp);
+ return Tcl_ListObjReplace(interp, varPtr[varIndex], first, count,
+ objc-5, objv+5);
+ }
+ return TCL_OK;
+}
+
+/*
*----------------------------------------------------------------------
*
* TestobjCmd --
*
- * This procedure implements the "testobj" command. It is used to test
+ * This function implements the "testobj" command. It is used to test
* the type-independent portions of the Tcl object type implementation.
*
* Results:
@@ -702,16 +891,16 @@ TestintobjCmd(clientData, interp, objc, objv)
*/
static int
-TestobjCmd(clientData, interp, objc, objv)
- ClientData clientData; /* Not used. */
- Tcl_Interp *interp; /* Current interpreter. */
- int objc; /* Number of arguments. */
- Tcl_Obj *CONST objv[]; /* Argument objects. */
+TestobjCmd(
+ ClientData clientData, /* Not used. */
+ Tcl_Interp *interp, /* Current interpreter. */
+ int objc, /* Number of arguments. */
+ Tcl_Obj *const objv[]) /* Argument objects. */
{
int varIndex, destIndex, i;
char *index, *subCmd, *string;
Tcl_ObjType *targetType;
-
+
if (objc < 2) {
wrongNumArgs:
Tcl_WrongNumArgs(interp, 1, objv, "option arg ?arg ...?");
@@ -762,7 +951,7 @@ TestobjCmd(clientData, interp, objc, objv)
typeName = Tcl_GetString(objv[3]);
if ((targetType = Tcl_GetObjType(typeName)) == NULL) {
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
- "no type ", typeName, " found", (char *) NULL);
+ "no type ", typeName, " found", NULL);
return TCL_ERROR;
}
if (Tcl_ConvertToType(interp, varPtr[varIndex], targetType)
@@ -821,13 +1010,13 @@ TestobjCmd(clientData, interp, objc, objv)
SetVarToObj(varIndex, Tcl_NewObj());
Tcl_SetObjResult(interp, varPtr[varIndex]);
} else if (strcmp(subCmd, "objtype") == 0) {
- char *typeName;
+ 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;
}
@@ -879,11 +1068,9 @@ TestobjCmd(clientData, interp, objc, objv)
}
} 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",
- (char *) NULL);
+ "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;
@@ -894,7 +1081,7 @@ TestobjCmd(clientData, interp, objc, objv)
*
* TeststringobjCmd --
*
- * This procedure implements the "teststringobj" command. It is used to
+ * This function implements the "teststringobj" command. It is used to
* test the string Tcl object type implementation.
*
* Results:
@@ -908,21 +1095,21 @@ TestobjCmd(clientData, interp, objc, objv)
*/
static int
-TeststringobjCmd(clientData, interp, objc, objv)
- ClientData clientData; /* Not used. */
- Tcl_Interp *interp; /* Current interpreter. */
- int objc; /* Number of arguments. */
- Tcl_Obj *CONST objv[]; /* Argument objects. */
+TeststringobjCmd(
+ ClientData clientData, /* Not used. */
+ Tcl_Interp *interp, /* Current interpreter. */
+ int objc, /* Number of arguments. */
+ Tcl_Obj *const objv[]) /* Argument objects. */
{
int varIndex, option, i, length;
Tcl_UniChar *unicode;
#define MAX_STRINGS 11
char *index, *string, *strings[MAX_STRINGS+1];
TestString *strPtr;
- static CONST char *options[] = {
+ static const char *options[] = {
"append", "appendstrings", "get", "get2", "length", "length2",
- "set", "set2", "setlength", "ualloc", "getunicode",
- "appendself", "appendself2", (char *) NULL
+ "set", "set2", "setlength", "ualloc", "getunicode",
+ "appendself", "appendself2", NULL
};
if (objc < 3) {
@@ -951,12 +1138,12 @@ TeststringobjCmd(clientData, interp, objc, objv)
if (varPtr[varIndex] == NULL) {
SetVarToObj(varIndex, Tcl_NewObj());
}
-
+
/*
* If the object bound to variable "varIndex" is shared, we must
- * "copy on write" and append to a copy of the object.
+ * "copy on write" and append to a copy of the object.
*/
-
+
if (Tcl_IsShared(varPtr[varIndex])) {
SetVarToObj(varIndex, Tcl_DuplicateObj(varPtr[varIndex]));
}
@@ -974,7 +1161,7 @@ TeststringobjCmd(clientData, interp, objc, objv)
/*
* If the object bound to variable "varIndex" is shared, we must
- * "copy on write" and append to a copy of the object.
+ * "copy on write" and append to a copy of the object.
*/
if (Tcl_IsShared(varPtr[varIndex])) {
@@ -1038,13 +1225,13 @@ TeststringobjCmd(clientData, interp, objc, objv)
/*
* If the object currently bound to the variable with index
- * varIndex has ref count 1 (i.e. the object is unshared) we
- * can modify that object directly. Otherwise, if RC>1 (i.e.
- * the object is shared), we must create a new object to
- * modify/set and decrement the old formerly-shared object's
- * ref count. This is "copy on write".
+ * varIndex has ref count 1 (i.e. the object is unshared) we can
+ * modify that object directly. Otherwise, if RC>1 (i.e. the
+ * object is shared), we must create a new object to modify/set
+ * and decrement the old formerly-shared object's ref count. This
+ * is "copy on write".
*/
-
+
string = Tcl_GetStringFromObj(objv[3], &length);
if ((varPtr[varIndex] != NULL)
&& !Tcl_IsShared(varPtr[varIndex])) {
@@ -1169,17 +1356,17 @@ TeststringobjCmd(clientData, interp, objc, objv)
* None.
*
* Side effects:
- * This routine handles ref counting details for assignment:
- * i.e. the old value's ref count must be decremented (if not NULL) and
- * the new one incremented (also if not NULL).
+ * This routine handles ref counting details for assignment: i.e. the old
+ * value's ref count must be decremented (if not NULL) and the new one
+ * incremented (also if not NULL).
*
*----------------------------------------------------------------------
*/
static void
-SetVarToObj(varIndex, objPtr)
- int varIndex; /* Designates the assignment variable. */
- Tcl_Obj *objPtr; /* Points to object to assign to var. */
+SetVarToObj(
+ int varIndex, /* Designates the assignment variable. */
+ Tcl_Obj *objPtr) /* Points to object to assign to var. */
{
if (varPtr[varIndex] != NULL) {
Tcl_DecrRefCount(varPtr[varIndex]);
@@ -1207,15 +1394,15 @@ SetVarToObj(varIndex, objPtr)
*/
static int
-GetVariableIndex(interp, string, indexPtr)
- Tcl_Interp *interp; /* Interpreter for error reporting. */
- char *string; /* String containing a variable index
- * specified as a nonnegative number less
- * than NUMBER_OF_OBJECT_VARS. */
- int *indexPtr; /* Place to store converted result. */
+GetVariableIndex(
+ Tcl_Interp *interp, /* Interpreter for error reporting. */
+ const char *string, /* String containing a variable index
+ * specified as a nonnegative number less than
+ * NUMBER_OF_OBJECT_VARS. */
+ int *indexPtr) /* Place to store converted result. */
{
int index;
-
+
if (Tcl_GetInt(interp, string, &index) != TCL_OK) {
return TCL_ERROR;
}
@@ -1234,7 +1421,7 @@ GetVariableIndex(interp, string, indexPtr)
*
* CheckIfVarUnset --
*
- * Utility procedure that checks whether a test variable is readable:
+ * Utility function that checks whether a test variable is readable:
* i.e., that varPtr[varIndex] is non-NULL.
*
* Results:
@@ -1248,13 +1435,13 @@ GetVariableIndex(interp, string, indexPtr)
*/
static int
-CheckIfVarUnset(interp, varIndex)
- Tcl_Interp *interp; /* Interpreter for error reporting. */
- int varIndex; /* Index of the test variable to check. */
+CheckIfVarUnset(
+ Tcl_Interp *interp, /* Interpreter for error reporting. */
+ int varIndex) /* Index of the test variable to check. */
{
if (varPtr[varIndex] == NULL) {
char buf[32 + TCL_INTEGER_SPACE];
-
+
sprintf(buf, "variable %d is unset (NULL)", varIndex);
Tcl_ResetResult(interp);
Tcl_AppendToObj(Tcl_GetObjResult(interp), buf, -1);
@@ -1262,3 +1449,11 @@ CheckIfVarUnset(interp, varIndex)
}
return 0;
}
+
+/*
+ * Local Variables:
+ * mode: c
+ * c-basic-offset: 4
+ * fill-column: 78
+ * End:
+ */