summaryrefslogtreecommitdiffstats
path: root/generic/tclIndexObj.c
diff options
context:
space:
mode:
Diffstat (limited to 'generic/tclIndexObj.c')
-rw-r--r--generic/tclIndexObj.c227
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);