diff options
Diffstat (limited to 'generic/tclIndexObj.c')
| -rw-r--r-- | generic/tclIndexObj.c | 160 |
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)) { |