merged tcl 8.1 branch back into the main trunk

1 files changed, 92 insertions, 68 deletions

diff --git a/generic/tclIndexObj.c b/generic/tclIndexObj.c
index 2dc0d85..5acb6c5 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.2 1998/09/14 18:40:00 stanton Exp $
+ * RCS: @(#) $Id: tclIndexObj.c,v 1.3 1999/04/16 00:46:47 stanton Exp $
  */
 
 #include "tclInt.h"
@@ -19,11 +19,8 @@
  * Prototypes for procedures defined later in this file:
  */
 
-static void		DupIndexInternalRep _ANSI_ARGS_((Tcl_Obj *srcPtr,
-			    Tcl_Obj *copyPtr));
 static int		SetIndexFromAny _ANSI_ARGS_((Tcl_Interp *interp,
 			    Tcl_Obj *objPtr));
-static void		UpdateStringOfIndex _ANSI_ARGS_((Tcl_Obj *listPtr));
 
 /*
  * The structure below defines the index Tcl object type by means of
@@ -33,10 +30,17 @@ static void		UpdateStringOfIndex _ANSI_ARGS_((Tcl_Obj *listPtr));
 Tcl_ObjType tclIndexType = {
     "index",				/* name */
     (Tcl_FreeInternalRepProc *) NULL,	/* freeIntRepProc */
-    DupIndexInternalRep,	        /* dupIntRepProc */
-    UpdateStringOfIndex,		/* updateStringProc */
+    (Tcl_DupInternalRepProc *) NULL,	/* dupIntRepProc */
+    (Tcl_UpdateStringProc *) NULL,	/* updateStringProc */
     SetIndexFromAny			/* setFromAnyProc */
 };
+
+/*
+ * Boolean flag indicating whether or not the tclIndexType object
+ * type has been registered with the Tcl compiler.
+ */
+
+static int indexTypeInitialized = 0;
 
 /*
  *----------------------------------------------------------------------
@@ -47,7 +51,7 @@ Tcl_ObjType tclIndexType = {
  *	and returns the index of the matching string, if any.
  *
  * Results:
-
+ *
  *	If the value of objPtr is identical to or a unique abbreviation
  *	for one of the entries in objPtr, then the return value is
  *	TCL_OK and the index of the matching entry is stored at
@@ -76,6 +80,67 @@ Tcl_GetIndexFromObj(interp, objPtr, tablePtr, msg, flags, indexPtr)
     int flags;			/* 0 or TCL_EXACT */
     int *indexPtr;		/* Place to store resulting integer index. */
 {
+
+    /*
+     * See if there is a valid cached result from a previous lookup
+     * (doing the check here saves the overhead of calling
+     * Tcl_GetIndexFromObjStruct in the common case where the result
+     * is cached).
+     */
+
+    if ((objPtr->typePtr == &tclIndexType)
+	    && (objPtr->internalRep.twoPtrValue.ptr1 == (VOID *) tablePtr)) {
+	*indexPtr = (int) objPtr->internalRep.twoPtrValue.ptr2;
+	return TCL_OK;
+    }
+    return Tcl_GetIndexFromObjStruct(interp, objPtr, tablePtr, sizeof(char *),
+	    msg, flags, indexPtr);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_GetIndexFromObjStruct --
+ *
+ *	This procedure looks up an object's value given a starting
+ *	string and an offset for the amount of space between strings.
+ *	This is useful when the strings are embedded in some other
+ *	kind of array.
+ *
+ * Results:
+ *
+ *	If the value of objPtr is identical to or a unique abbreviation
+ *	for one of the entries in objPtr, then the return value is
+ *	TCL_OK and the index of the matching entry is stored at
+ *	*indexPtr.  If there isn't a proper match, then TCL_ERROR is
+ *	returned and an error message is left in interp's result (unless
+ *	interp is NULL).  The msg argument is used in the error
+ *	message; for example, if msg has the value "option" then the
+ *	error message will say something flag 'bad option "foo": must be
+ *	...'
+ *
+ * Side effects:
+ *	The result of the lookup is cached as the internal rep of
+ *	objPtr, so that repeated lookups can be done quickly.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+Tcl_GetIndexFromObjStruct(interp, objPtr, tablePtr, offset, msg, flags, 
+	indexPtr)
+    Tcl_Interp *interp; 	/* Used for error reporting if not NULL. */
+    Tcl_Obj *objPtr;		/* Object containing the string to lookup. */
+    char **tablePtr;		/* The first string in the table. The second
+				 * string will be at this address plus the
+				 * offset, the third plus the offset again,
+				 * etc. The last entry must be NULL
+				 * and there must not be duplicate entries. */
+    int offset;			/* The number of bytes between entries */
+    char *msg;			/* Identifying word to use in error messages. */
+    int flags;			/* 0 or TCL_EXACT */
+    int *indexPtr;		/* Place to store resulting integer index. */
+{
     int index, length, i, numAbbrev;
     char *key, *p1, *p2, **entryPtr;
     Tcl_Obj *resultPtr;
@@ -95,10 +160,21 @@ Tcl_GetIndexFromObj(interp, objPtr, tablePtr, msg, flags, indexPtr)
      * abbreviations unless TCL_EXACT is set in flags.
      */
 
+    if (!indexTypeInitialized) {
+	/*
+	 * This is the first time we've done a lookup.  Register the
+	 * tclIndexType.
+	 */
+
+        Tcl_RegisterObjType(&tclIndexType);
+        indexTypeInitialized = 1;
+    }
+
     key = Tcl_GetStringFromObj(objPtr, &length);
     index = -1;
     numAbbrev = 0;
-    for (entryPtr = tablePtr, i = 0; *entryPtr != NULL; entryPtr++, i++) {
+    for (entryPtr = tablePtr, i = 0; *entryPtr != NULL; 
+	    entryPtr = (char **) ((long) entryPtr + offset), i++) {
 	for (p1 = key, p2 = *entryPtr; *p1 == *p2; p1++, p2++) {
 	    if (*p1 == 0) {
 		index = i;
@@ -135,13 +211,17 @@ Tcl_GetIndexFromObj(interp, objPtr, tablePtr, msg, flags, indexPtr)
 
     error:
     if (interp != NULL) {
+	int count;
 	resultPtr = Tcl_GetObjResult(interp);
 	Tcl_AppendStringsToObj(resultPtr,
 		(numAbbrev > 1) ? "ambiguous " : "bad ", msg, " \"",
 		key, "\": must be ", *tablePtr, (char *) NULL);
-	for (entryPtr = tablePtr+1; *entryPtr != NULL; entryPtr++) {
-	    if (entryPtr[1] == NULL) {
-		Tcl_AppendStringsToObj(resultPtr, ", or ", *entryPtr,
+	for (entryPtr = (char **) ((long) tablePtr + offset), count = 0;
+		*entryPtr != NULL;
+		entryPtr = (char **) ((long) entryPtr + offset), count++) {
+	    if ((*((char **) ((long) entryPtr + offset))) == NULL) {
+		Tcl_AppendStringsToObj(resultPtr,
+			(count > 0) ? ", or " : " or ", *entryPtr,
 			(char *) NULL);
 	    } else {
 		Tcl_AppendStringsToObj(resultPtr, ", ", *entryPtr,
@@ -155,36 +235,6 @@ Tcl_GetIndexFromObj(interp, objPtr, tablePtr, msg, flags, indexPtr)
 /*
  *----------------------------------------------------------------------
  *
- * DupIndexInternalRep --
- *
- *	Copy the internal representation of an index Tcl_Obj from one
- *	object to another.
- *
- * Results:
- *	None.
- *
- * Side effects:
- *	"copyPtr"s internal rep is set to same value as "srcPtr"s
- *	internal rep.
- *
- *----------------------------------------------------------------------
- */
-
-static void
-DupIndexInternalRep(srcPtr, copyPtr)
-    register Tcl_Obj *srcPtr;	/* Object with internal rep to copy. */
-    register Tcl_Obj *copyPtr;	/* Object with internal rep to set. */
-{
-    copyPtr->internalRep.twoPtrValue.ptr1
-	    = srcPtr->internalRep.twoPtrValue.ptr1;
-    copyPtr->internalRep.twoPtrValue.ptr2
-	    = srcPtr->internalRep.twoPtrValue.ptr2;
-    copyPtr->typePtr = &tclIndexType;
-}
-
-/*
- *----------------------------------------------------------------------
- *
  * SetIndexFromAny --
  *
  *	This procedure is called to convert a Tcl object to index
@@ -216,31 +266,6 @@ SetIndexFromAny(interp, objPtr)
 /*
  *----------------------------------------------------------------------
  *
- * UpdateStringOfIndex --
- *
- *	This procedure is called to update the string representation for
- *	an index object.  It should never be called, because we never
- *	invalidate the string representation for an index object.
- *
- * Results:
- *	None.
- *
- * Side effects:
- *	A panic is added
- *
- *----------------------------------------------------------------------
- */
-
-static void
-UpdateStringOfIndex(objPtr)
-    register Tcl_Obj *objPtr;	/* Int object whose string rep to update. */
-{
-    panic("UpdateStringOfIndex should never be invoked");
-}
-
-/*
- *----------------------------------------------------------------------
- *
  * Tcl_WrongNumArgs --
  *
  *	This procedure generates a "wrong # args" error message in an
@@ -293,8 +318,7 @@ Tcl_WrongNumArgs(interp, objc, objv, message)
 		    tablePtr[(int) objv[i]->internalRep.twoPtrValue.ptr2],
 		    (char *) NULL);
 	} else {
-	    Tcl_AppendStringsToObj(objPtr,
-		    Tcl_GetStringFromObj(objv[i], (int *) NULL),
+	    Tcl_AppendStringsToObj(objPtr, Tcl_GetString(objv[i]),
 		    (char *) NULL);
 	}
 	if (i < (objc - 1)) {