diff options
| -rw-r--r-- | generic/tclIndexObj.c | 25 | ||||
| -rw-r--r-- | generic/tclTest.c | 58 | ||||
| -rw-r--r-- | generic/tclTestObj.c | 5 | ||||
| -rw-r--r-- | tests/indexObj.test | 21 |
4 files changed, 98 insertions, 11 deletions
diff --git a/generic/tclIndexObj.c b/generic/tclIndexObj.c index d304b84..1ae0d8c 100644 --- a/generic/tclIndexObj.c +++ b/generic/tclIndexObj.c @@ -10,7 +10,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclIndexObj.c,v 1.7 2000/11/02 09:20:44 hobbs Exp $ + * RCS: @(#) $Id: tclIndexObj.c,v 1.8 2000/11/24 11:27:37 dkf Exp $ */ #include "tclInt.h" @@ -36,6 +36,16 @@ Tcl_ObjType tclIndexType = { }; /* + * DKF - Just noting that the data format used in objects with the + * above type is that the ptr1 field will contain a pointer to the + * table that the last lookup was performed in, and the ptr2 field + * will contain the sizeof(char) offset of the string within that + * table. Note that we assume that each table is only ever called + * with a single offset, but this is a pretty safe assumption in + * practise... + */ + +/* * Boolean flag indicating whether or not the tclIndexType object * type has been registered with the Tcl compiler. */ @@ -90,7 +100,8 @@ Tcl_GetIndexFromObj(interp, objPtr, tablePtr, msg, flags, indexPtr) if ((objPtr->typePtr == &tclIndexType) && (objPtr->internalRep.twoPtrValue.ptr1 == (VOID *) tablePtr)) { - *indexPtr = (int) objPtr->internalRep.twoPtrValue.ptr2; + *indexPtr = ((int) objPtr->internalRep.twoPtrValue.ptr2) + / sizeof(char *); return TCL_OK; } return Tcl_GetIndexFromObjStruct(interp, objPtr, tablePtr, sizeof(char *), @@ -151,7 +162,7 @@ Tcl_GetIndexFromObjStruct(interp, objPtr, tablePtr, offset, msg, flags, if ((objPtr->typePtr == &tclIndexType) && (objPtr->internalRep.twoPtrValue.ptr1 == (VOID *) tablePtr)) { - *indexPtr = (int) objPtr->internalRep.twoPtrValue.ptr2; + *indexPtr = ((int) objPtr->internalRep.twoPtrValue.ptr2) / offset; return TCL_OK; } @@ -216,8 +227,7 @@ Tcl_GetIndexFromObjStruct(interp, objPtr, tablePtr, offset, msg, flags, /* * Make sure to account for offsets != sizeof(char *). [Bug 5153] */ - objPtr->internalRep.twoPtrValue.ptr2 = - (VOID *) (index * (offset / sizeof(char *))); + objPtr->internalRep.twoPtrValue.ptr2 = (VOID *) (index * offset); objPtr->typePtr = &tclIndexType; *indexPtr = index; return TCL_OK; @@ -314,7 +324,7 @@ Tcl_WrongNumArgs(interp, objc, objv, message) { Tcl_Obj *objPtr; char **tablePtr; - int i; + int i, offset; objPtr = Tcl_GetObjResult(interp); Tcl_AppendToObj(objPtr, "wrong # args: should be \"", -1); @@ -327,8 +337,9 @@ Tcl_WrongNumArgs(interp, objc, objv, message) if (objv[i]->typePtr == &tclIndexType) { tablePtr = ((char **) objv[i]->internalRep.twoPtrValue.ptr1); + offset = ((int) objv[i]->internalRep.twoPtrValue.ptr2); Tcl_AppendStringsToObj(objPtr, - tablePtr[(int) objv[i]->internalRep.twoPtrValue.ptr2], + *((char **)(((char *)tablePtr)+offset)), (char *) NULL); } else { Tcl_AppendStringsToObj(objPtr, Tcl_GetString(objv[i]), diff --git a/generic/tclTest.c b/generic/tclTest.c index b76b978..c27e7e2 100644 --- a/generic/tclTest.c +++ b/generic/tclTest.c @@ -13,7 +13,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclTest.c,v 1.21 2000/09/28 06:38:22 hobbs Exp $ + * RCS: @(#) $Id: tclTest.c,v 1.22 2000/11/24 11:27:37 dkf Exp $ */ #define TCL_TEST @@ -292,6 +292,9 @@ static int TestupvarCmd _ANSI_ARGS_((ClientData dummy, static int TestWrongNumArgsObjCmd _ANSI_ARGS_(( ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); +static int TestGetIndexFromObjStructObjCmd _ANSI_ARGS_(( + ClientData clientData, Tcl_Interp *interp, + int objc, Tcl_Obj *CONST objv[])); static int TestChannelCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int argc, char **argv)); static int TestChannelEventCmd _ANSI_ARGS_((ClientData clientData, @@ -347,6 +350,9 @@ Tcltest_Init(interp) (Tcl_CmdDeleteProc *) NULL); Tcl_CreateObjCommand(interp, "testwrongnumargs", TestWrongNumArgsObjCmd, (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); + Tcl_CreateObjCommand(interp, "testgetindexfromobjstruct", + TestGetIndexFromObjStructObjCmd, (ClientData) 0, + (Tcl_CmdDeleteProc *) NULL); Tcl_CreateCommand(interp, "testaccessproc", TestaccessprocCmd, (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); Tcl_CreateCommand(interp, "testasync", TestasyncCmd, (ClientData) 0, @@ -4947,3 +4953,53 @@ TestWrongNumArgsObjCmd(dummy, interp, objc, objv) Tcl_WrongNumArgs(interp, i, &(objv[3]), msg); return TCL_OK; } + +/* + *---------------------------------------------------------------------- + * + * TestGetIndexFromObjStructObjCmd -- + * + * Test the Tcl_GetIndexFromObjStruct function. + * + * Results: + * Standard Tcl result. + * + * Side effects: + * Sets interpreter result. + * + *---------------------------------------------------------------------- + */ + +static int +TestGetIndexFromObjStructObjCmd(dummy, interp, objc, objv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int objc; /* Number of arguments. */ + Tcl_Obj *CONST objv[]; /* Argument objects. */ +{ + char *ary[] = { "a", "b", "c", "d", "e", "f", (char *)NULL,(char *)NULL }; + int idx,target; + + if (objc != 3) { + Tcl_WrongNumArgs(interp, 1, objv, "argument targetvalue"); + return TCL_ERROR; + } + if (Tcl_GetIndexFromObjStruct(interp, objv[1], ary, 2*sizeof(char *), + "dummy", 0, &idx) != TCL_OK) { + return TCL_ERROR; + } + if (Tcl_GetIntFromObj(interp, objv[2], &target) != TCL_OK) { + return TCL_ERROR; + } + if (idx != target) { + char buffer[64]; + sprintf(buffer, "%d", idx); + Tcl_AppendResult(interp, "index value comparison failed: got ", + buffer, NULL); + sprintf(buffer, "%d", target); + Tcl_AppendResult(interp, " when ", buffer, " expected", NULL); + return TCL_ERROR; + } + Tcl_WrongNumArgs(interp, 3, objv, NULL); + return TCL_OK; +} diff --git a/generic/tclTestObj.c b/generic/tclTestObj.c index 2733a8c..8232175 100644 --- a/generic/tclTestObj.c +++ b/generic/tclTestObj.c @@ -12,7 +12,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclTestObj.c,v 1.6 1999/06/15 22:06:17 hershey Exp $ + * RCS: @(#) $Id: tclTestObj.c,v 1.7 2000/11/24 11:27:37 dkf Exp $ */ #include "tclInt.h" @@ -420,7 +420,8 @@ TestindexobjCmd(clientData, interp, objc, objv) if (Tcl_GetIntFromObj(interp, objv[2], &index2) != TCL_OK) { return TCL_ERROR; } - objv[1]->internalRep.twoPtrValue.ptr2 = (VOID *) index2; + objv[1]->internalRep.twoPtrValue.ptr2 = + (VOID *) (index2 * sizeof(char *)); result = Tcl_GetIndexFromObj((Tcl_Interp *) NULL, objv[1], tablePtr, "token", 0, &index); if (result == TCL_OK) { diff --git a/tests/indexObj.test b/tests/indexObj.test index 4dd83f5..9a8a582 100644 --- a/tests/indexObj.test +++ b/tests/indexObj.test @@ -8,7 +8,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: indexObj.test,v 1.6 2000/08/07 22:42:32 ericm Exp $ +# RCS: @(#) $Id: indexObj.test,v 1.7 2000/11/24 11:27:38 dkf Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest @@ -89,6 +89,25 @@ test indexObj-5.6 {Tcl_WrongNumArgs} { testwrongnumargs 2 "" mycmd foo } "wrong # args: should be \"mycmd foo\"" +test indexObj-6.1 {Tcl_GetIndexFromObjStruct} { + set x a + testgetindexfromobjstruct $x 0 +} "wrong # args: should be \"testgetindexfromobjstruct a 0\"" +test indexObj-6.2 {Tcl_GetIndexFromObjStruct} { + set x a + testgetindexfromobjstruct $x 0 + testgetindexfromobjstruct $x 0 +} "wrong # args: should be \"testgetindexfromobjstruct a 0\"" +test indexObj-6.3 {Tcl_GetIndexFromObjStruct} { + set x c + testgetindexfromobjstruct $x 1 +} "wrong # args: should be \"testgetindexfromobjstruct c 1\"" +test indexObj-6.4 {Tcl_GetIndexFromObjStruct} { + set x c + testgetindexfromobjstruct $x 1 + testgetindexfromobjstruct $x 1 +} "wrong # args: should be \"testgetindexfromobjstruct c 1\"" + # cleanup ::tcltest::cleanupTests return |