TIP#72 implementation. See ChangeLog for details.

This version builds clean on Solaris/SPARC, with GCC and CC, both with and
without threads and both in 32-bit and 64-bit mode.

1 files changed, 185 insertions, 42 deletions

diff --git a/generic/tclIndexObj.c b/generic/tclIndexObj.c
index c9baf3c..4b5dfe4 100644
--- a/generic/tclIndexObj.c
+++ b/generic/tclIndexObj.c
@@ -10,10 +10,11 @@
  * 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.12 2002/01/17 04:37:33 dgp Exp $
+ * RCS: @(#) $Id: tclIndexObj.c,v 1.13 2002/02/15 14:28:49 dkf Exp $
  */
 
 #include "tclInt.h"
+#include "tclPort.h"
 
 /*
  * Prototypes for procedures defined later in this file:
@@ -21,6 +22,10 @@
 
 static int		SetIndexFromAny _ANSI_ARGS_((Tcl_Interp *interp,
 			    Tcl_Obj *objPtr));
+static void		UpdateStringOfIndex _ANSI_ARGS_((Tcl_Obj *objPtr));
+static void		DupIndex _ANSI_ARGS_((Tcl_Obj *srcPtr,
+			    Tcl_Obj *dupPtr));
+static void		FreeIndex _ANSI_ARGS_((Tcl_Obj *objPtr));
 
 /*
  * The structure below defines the index Tcl object type by means of
@@ -29,21 +34,44 @@ static int		SetIndexFromAny _ANSI_ARGS_((Tcl_Interp *interp,
 
 Tcl_ObjType tclIndexType = {
     "index",				/* name */
-    (Tcl_FreeInternalRepProc *) NULL,	/* freeIntRepProc */
-    (Tcl_DupInternalRepProc *) NULL,	/* dupIntRepProc */
-    (Tcl_UpdateStringProc *) NULL,	/* updateStringProc */
+    FreeIndex,				/* freeIntRepProc */
+    DupIndex,				/* dupIntRepProc */
+    UpdateStringOfIndex,		/* updateStringProc */
     SetIndexFromAny			/* setFromAnyProc */
 };
 
 /*
- * 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...
+ * The definition of the internal representation of the "index"
+ * object; The internalRep.otherValuePtr field of an object of "index"
+ * type will be a pointer to one of these structures.
+ *
+ * Keep this structure declaration in sync with tclTestObj.c
+ */
+
+typedef struct {
+    VOID *tablePtr;			/* Pointer to the table of strings */
+    int offset;				/* Offset between table entries */
+    int index;				/* Selected index into table. */
+} IndexRep;
+
+/*
+ * The following macros greatly simplify moving through a table...
+ *
+ * SunPro CC prohibits address arithmetic on (void *) values, so
+ * use (char *) on that platform/build-environment instead.
  */
+#ifdef __sparc
+#   define STRING_AT(table, offset, index) \
+	(*((CONST char * CONST *)(((char *)(table)) + ((offset) * (index)))))
+#else
+#   define STRING_AT(table, offset, index) \
+	(*((CONST char * CONST *)(((VOID *)(table)) + (ptrdiff_t)((offset) * (index)))))
+#endif
+#define NEXT_ENTRY(table, offset) \
+	(&(STRING_AT(table, offset, 1)))
+#define EXPAND_OF(indexRep) \
+	STRING_AT((indexRep)->tablePtr, (indexRep)->offset, (indexRep)->index)
+
 
 /*
  *----------------------------------------------------------------------
@@ -91,11 +119,17 @@ Tcl_GetIndexFromObj(interp, objPtr, tablePtr, msg, flags, indexPtr)
      * is cached).
      */
 
-    if ((objPtr->typePtr == &tclIndexType)
-	    && (objPtr->internalRep.twoPtrValue.ptr1 == (VOID *) tablePtr)) {
-	*indexPtr = ((int) objPtr->internalRep.twoPtrValue.ptr2)
-	                   / sizeof(char *);
-	return TCL_OK;
+    if (objPtr->typePtr == &tclIndexType) {
+	IndexRep *indexRep = (IndexRep *) objPtr->internalRep.otherValuePtr;
+	/*
+	 * Here's hoping we don't get hit by unfortunate packing
+	 * constraints on odd platforms like a Cray PVP...
+	 */
+	if (indexRep->tablePtr == (VOID *)tablePtr &&
+		indexRep->offset == sizeof(char *)) {
+	    *indexPtr = indexRep->index;
+	    return TCL_OK;
+	}
     }
     return Tcl_GetIndexFromObjStruct(interp, objPtr, tablePtr, sizeof(char *),
 	    msg, flags, indexPtr);
@@ -150,15 +184,18 @@ Tcl_GetIndexFromObjStruct(interp, objPtr, tablePtr, offset, msg, flags,
     CONST char *p2;
     CONST char * CONST *entryPtr;
     Tcl_Obj *resultPtr;
+    IndexRep *indexRep;
 
     /*
      * See if there is a valid cached result from a previous lookup.
      */
 
-    if ((objPtr->typePtr == &tclIndexType)
-	    && (objPtr->internalRep.twoPtrValue.ptr1 == (VOID *) tablePtr)) {
-	*indexPtr = ((int) objPtr->internalRep.twoPtrValue.ptr2) / offset;
-	return TCL_OK;
+    if (objPtr->typePtr == &tclIndexType) {
+	indexRep = (IndexRep *) objPtr->internalRep.otherValuePtr;
+	if (indexRep->tablePtr==tablePtr && indexRep->offset==offset) {
+	    *indexPtr = indexRep->index;
+	    return TCL_OK;
+	}
     }
 
     /*
@@ -178,15 +215,21 @@ Tcl_GetIndexFromObjStruct(interp, objPtr, tablePtr, offset, msg, flags,
 	goto error;
     }
     
+    /*
+     * Scan the table looking for one of:
+     *  - An exact match (always preferred)
+     *  - A single abbreviation (allowed depending on flags)
+     *  - Several abbreviations (never allowed, but overridden by exact match)
+     */
     for (entryPtr = tablePtr, i = 0; *entryPtr != NULL; 
-	    entryPtr = (CONST char **) ((char *)entryPtr + offset), i++) {
+	    entryPtr = NEXT_ENTRY(entryPtr, offset), i++) {
 	for (p1 = key, p2 = *entryPtr; *p1 == *p2; p1++, p2++) {
-	    if (*p1 == 0) {
+	    if (*p1 == '\0') {
 		index = i;
 		goto done;
 	    }
 	}
-	if (*p1 == 0) {
+	if (*p1 == '\0') {
 	    /*
 	     * The value is an abbreviation for this entry.  Continue
 	     * checking other entries to make sure it's unique.  If we
@@ -199,36 +242,51 @@ Tcl_GetIndexFromObjStruct(interp, objPtr, tablePtr, offset, msg, flags,
 	    index = i;
 	}
     }
+    /*
+     * Check if we were instructed to disallow abbreviations.
+     */
     if ((flags & TCL_EXACT) || (numAbbrev != 1)) {
 	goto error;
     }
 
     done:
-    if ((objPtr->typePtr != NULL)
-	    && (objPtr->typePtr->freeIntRepProc != NULL)) {
-	objPtr->typePtr->freeIntRepProc(objPtr);
-    }
-    objPtr->internalRep.twoPtrValue.ptr1 = (VOID *) tablePtr;
     /*
-     * Make sure to account for offsets != sizeof(char *).  [Bug 5153]
+     * Cache the found representation.  Note that we want to avoid
+     * allocating a new internal-rep if at all possible since that is
+     * potentially a slow operation.
      */
-    objPtr->internalRep.twoPtrValue.ptr2 = (VOID *) (index * offset);
-    objPtr->typePtr = &tclIndexType;
+    if (objPtr->typePtr == &tclIndexType) {
+ 	indexRep = (IndexRep *) objPtr->internalRep.otherValuePtr;
+    } else {
+ 	if ((objPtr->typePtr != NULL)
+		&& (objPtr->typePtr->freeIntRepProc != NULL)) {
+ 	    objPtr->typePtr->freeIntRepProc(objPtr);
+ 	}
+ 	indexRep = (IndexRep *) ckalloc(sizeof(IndexRep));
+ 	objPtr->internalRep.otherValuePtr = (VOID *) indexRep;
+ 	objPtr->typePtr = &tclIndexType;
+    }
+    indexRep->tablePtr = tablePtr;
+    indexRep->offset = offset;
+    indexRep->index = index;
+
     *indexPtr = index;
     return TCL_OK;
 
     error:
     if (interp != NULL) {
+	/*
+	 * Produce a fancy error message.
+	 */
 	int count;
 	resultPtr = Tcl_GetObjResult(interp);
 	Tcl_AppendStringsToObj(resultPtr,
 		(numAbbrev > 1) ? "ambiguous " : "bad ", msg, " \"",
 		key, "\": must be ", *tablePtr, (char *) NULL);
-	for (entryPtr = (CONST char **)((char *)tablePtr + offset), count = 0;
+	for (entryPtr = NEXT_ENTRY(tablePtr, offset), count = 0;
 		*entryPtr != NULL;
-		entryPtr = (CONST char **)((char *)entryPtr + offset),
-		count++) {
-	    if ((*((char **) ((char *) entryPtr + offset))) == NULL) {
+		entryPtr = NEXT_ENTRY(entryPtr, offset), count++) {
+	    if (*NEXT_ENTRY(entryPtr, offset) == NULL) {
 		Tcl_AppendStringsToObj(resultPtr,
 			(count > 0) ? ", or " : " or ", *entryPtr,
 			(char *) NULL);
@@ -275,6 +333,94 @@ SetIndexFromAny(interp, objPtr)
 /*
  *----------------------------------------------------------------------
  *
+ * UpdateStringOfIndex --
+ *
+ *	This procedure is called to convert a Tcl object from index
+ *	internal form to its string form.  No abbreviation is ever
+ *	generated.
+ *
+ * Results:
+ *	None.
+ *
+ * Side effects:
+ *	The string representation of the object is updated.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static void
+UpdateStringOfIndex(objPtr)
+    Tcl_Obj *objPtr;
+{
+    IndexRep *indexRep = (IndexRep *) objPtr->internalRep.otherValuePtr;
+    register char *buf;
+    register unsigned len;
+    register CONST char *indexStr = EXPAND_OF(indexRep);
+
+    len = strlen(indexStr);
+    buf = (char *) ckalloc(len + 1);
+    memcpy(buf, indexStr, len+1);
+    objPtr->bytes = buf;
+    objPtr->length = len;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * DupIndex --
+ *
+ *	This procedure is called to copy the internal rep of an index
+ *	Tcl object from to another object.
+ *
+ * Results:
+ *	None.
+ *
+ * Side effects:
+ *	The internal representation of the target object is updated
+ *	and the type is set.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static void
+DupIndex(srcPtr, dupPtr)
+    Tcl_Obj *srcPtr, *dupPtr;
+{
+    IndexRep *srcIndexRep = (IndexRep *) srcPtr->internalRep.otherValuePtr;
+    IndexRep *dupIndexRep = (IndexRep *) ckalloc(sizeof(IndexRep));
+
+    memcpy(dupIndexRep, srcIndexRep, sizeof(IndexRep));
+    dupPtr->internalRep.otherValuePtr = (VOID *) dupIndexRep;
+    dupPtr->typePtr = &tclIndexType;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * FreeIndex --
+ *
+ *	This procedure is called to delete the internal rep of an index
+ *	Tcl object.
+ *
+ * Results:
+ *	None.
+ *
+ * Side effects:
+ *	The internal representation of the target object is deleted.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static void
+FreeIndex(objPtr)
+    Tcl_Obj *objPtr;
+{
+    ckfree((char *) objPtr->internalRep.otherValuePtr);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
  * Tcl_WrongNumArgs --
  *
  *	This procedure generates a "wrong # args" error message in an
@@ -309,8 +455,8 @@ Tcl_WrongNumArgs(interp, objc, objv, message)
 					 * message may be NULL. */
 {
     Tcl_Obj *objPtr;
-    char **tablePtr;
-    int i, offset;
+    int i;
+    register IndexRep *indexRep;
 
     objPtr = Tcl_GetObjResult(interp);
     Tcl_AppendToObj(objPtr, "wrong # args: should be \"", -1);
@@ -322,11 +468,8 @@ 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,
-		    *((char **)(((char *)tablePtr)+offset)),
-		    (char *) NULL);
+	    indexRep = (IndexRep *) objv[i]->internalRep.otherValuePtr;
+	    Tcl_AppendStringsToObj(objPtr, EXPAND_OF(indexRep), (char *) NULL);
 	} else {
 	    Tcl_AppendStringsToObj(objPtr, Tcl_GetString(objv[i]),
 		    (char *) NULL);