diff options
Diffstat (limited to 'generic/tclTestObj.c')
| -rw-r--r-- | generic/tclTestObj.c | 615 |
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: + */ |