summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
-rw-r--r--generic/tclIndexObj.c25
-rw-r--r--generic/tclTest.c58
-rw-r--r--generic/tclTestObj.c5
-rw-r--r--tests/indexObj.test21
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