Attachment "arraysearch.patch" to
ticket [424851ffff]
added by
dkf
2001-05-17 21:16:27.
Index: ChangeLog
===================================================================
RCS file: /cvsroot/tcl/tcl/ChangeLog,v
retrieving revision 1.442
diff -u -r1.442 ChangeLog
--- ChangeLog 2001/05/17 08:18:56 1.442
+++ ChangeLog 2001/05/17 14:08:49
@@ -1,3 +1,15 @@
+2001-05-17 Donal K. Fellows <[email protected]>
+
+ * generic/tclVar.c (tclArraySearchType,SetArraySearchObj,
+ ParseSearchId): Added code to speed up array searching by reducing
+ the amount of parsing needed for searchIds.
+
+ * generic/tclObj.c (TclInitObjSubsystem):
+ * generic/tclIndexObj.c (Tcl_GetIndexFromObjStruct):
+ * generic/tclNamesp.c (TclInitNamespaceSubsystem):
+ * generic/tclInt.h: Moved some Tcl_ObjType initialisation to
+ TclInitObjSubsystem to be with the bulk of the rest.
+
2001-05-16 Jeff Hobbs <[email protected]>
* library/history.tcl (tcl::HistAdd): prevent empty calls from
Index: generic/tclIndexObj.c
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tclIndexObj.c,v
retrieving revision 1.8
diff -u -r1.8 tclIndexObj.c
--- generic/tclIndexObj.c 2000/11/24 11:27:37 1.8
+++ generic/tclIndexObj.c 2001/05/17 14:08:50
@@ -44,13 +44,6 @@
* 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.
- */
-
-static int indexTypeInitialized = 0;
/*
*----------------------------------------------------------------------
@@ -170,16 +163,6 @@
* Lookup the value of the object in the table. Accept unique
* 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;
Index: generic/tclInt.h
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tclInt.h,v
retrieving revision 1.54
diff -u -r1.54 tclInt.h
--- generic/tclInt.h 2001/05/17 02:13:03 1.54
+++ generic/tclInt.h 2001/05/17 14:08:50
@@ -1592,6 +1592,9 @@
extern Tcl_ObjType tclListType;
extern Tcl_ObjType tclProcBodyType;
extern Tcl_ObjType tclStringType;
+extern Tcl_ObjType tclArraySearchType;
+extern Tcl_ObjType tclIndexType;
+extern Tcl_ObjType tclNsNameType;
/*
* Variables denoting the hash key types defined in the core.
Index: generic/tclNamesp.c
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tclNamesp.c,v
retrieving revision 1.23
diff -u -r1.23 tclNamesp.c
--- generic/tclNamesp.c 2001/05/15 14:19:13 1.23
+++ generic/tclNamesp.c 2001/05/17 14:08:52
@@ -166,7 +166,7 @@
* None.
*
* Side effects:
- * The namespace object type is registered with the Tcl compiler.
+ * None.
*
*----------------------------------------------------------------------
*/
@@ -174,7 +174,9 @@
void
TclInitNamespaceSubsystem()
{
- Tcl_RegisterObjType(&tclNsNameType);
+ /*
+ * Does nothing for now.
+ */
}
/*
Index: generic/tclObj.c
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tclObj.c,v
retrieving revision 1.20
diff -u -r1.20 tclObj.c
--- generic/tclObj.c 2001/04/04 16:07:21 1.20
+++ generic/tclObj.c 2001/05/17 14:08:52
@@ -165,6 +165,9 @@
Tcl_RegisterObjType(&tclListType);
Tcl_RegisterObjType(&tclByteCodeType);
Tcl_RegisterObjType(&tclProcBodyType);
+ Tcl_RegisterObjType(&tclArraySearchType);
+ Tcl_RegisterObjType(&tclIndexType);
+ Tcl_RegisterObjType(&tclNsNameType);
#ifdef TCL_COMPILE_STATS
Tcl_MutexLock(&tclObjMutex);
Index: generic/tclVar.c
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tclVar.c,v
retrieving revision 1.32
diff -u -r1.32 tclVar.c
--- generic/tclVar.c 2001/05/17 02:13:03 1.32
+++ generic/tclVar.c 2001/05/17 14:08:53
@@ -53,10 +53,29 @@
char *myName, int myFlags));
static Var * NewVar _ANSI_ARGS_((void));
static ArraySearch * ParseSearchId _ANSI_ARGS_((Tcl_Interp *interp,
- Var *varPtr, char *varName, char *string));
+ Var *varPtr, char *varName, Tcl_Obj *handleObj));
static void VarErrMsg _ANSI_ARGS_((Tcl_Interp *interp,
char *part1, char *part2, char *operation,
char *reason));
+static int SetArraySearchObj _ANSI_ARGS_((Tcl_Interp *interp,
+ Tcl_Obj *objPtr));
+
+/*
+ * Type of Tcl_Objs used to speed up array searches.
+ *
+ * INTERNALREP DEFINITION:
+ * twoPtrValue.ptr1 = searchIdNumber as offset from (char*)NULL
+ * twoPtrValue.ptr2 = variableNameStartInString as offset from (char*)NULL
+ *
+ * Note that the value stored in ptr2 is the offset into the string of
+ * the start of the variable name and not the address of the variable
+ * name itself, as this can be safely copied.
+ */
+Tcl_ObjType tclArraySearchType = {
+ "array search",
+ NULL, NULL, NULL, SetArraySearchObj
+};
+
/*
*----------------------------------------------------------------------
@@ -3034,7 +3053,6 @@
switch (index) {
case ARRAY_ANYMORE: {
ArraySearch *searchPtr;
- char *searchId;
if (objc != 4) {
Tcl_WrongNumArgs(interp, 2, objv,
@@ -3044,8 +3062,7 @@
if (notArray) {
goto error;
}
- searchId = Tcl_GetString(objv[3]);
- searchPtr = ParseSearchId(interp, varPtr, varName, searchId);
+ searchPtr = ParseSearchId(interp, varPtr, varName, objv[3]);
if (searchPtr == NULL) {
return TCL_ERROR;
}
@@ -3069,7 +3086,6 @@
}
case ARRAY_DONESEARCH: {
ArraySearch *searchPtr, *prevPtr;
- char *searchId;
if (objc != 4) {
Tcl_WrongNumArgs(interp, 2, objv,
@@ -3079,8 +3095,7 @@
if (notArray) {
goto error;
}
- searchId = Tcl_GetString(objv[3]);
- searchPtr = ParseSearchId(interp, varPtr, varName, searchId);
+ searchPtr = ParseSearchId(interp, varPtr, varName, objv[3]);
if (searchPtr == NULL) {
return TCL_ERROR;
}
@@ -3227,7 +3242,6 @@
}
case ARRAY_NEXTELEMENT: {
ArraySearch *searchPtr;
- char *searchId;
Tcl_HashEntry *hPtr;
if (objc != 4) {
@@ -3238,8 +3252,7 @@
if (notArray) {
goto error;
}
- searchId = Tcl_GetString(objv[3]);
- searchPtr = ParseSearchId(interp, varPtr, varName, searchId);
+ searchPtr = ParseSearchId(interp, varPtr, varName, objv[3]);
if (searchPtr == NULL) {
return TCL_ERROR;
}
@@ -4400,9 +4413,75 @@
/*
*----------------------------------------------------------------------
*
+ * SetArraySearchObj --
+ *
+ * This function converts the given tcl object into one that
+ * has the "array search" internal type.
+ *
+ * Results:
+ * TCL_OK if the conversion succeeded, and TCL_ERROR if it failed
+ * (when an error message will be placed in the interpreter's
+ * result.)
+ *
+ * Side effects:
+ * Updates the internal type and representation of the object to
+ * make this an array-search object. See the tclArraySearchType
+ * declaration above for details of the internal representation.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+SetArraySearchObj(interp, objPtr)
+ Tcl_Interp *interp;
+ Tcl_Obj *objPtr;
+{
+ char *string;
+ char *end;
+ int id;
+ size_t offset;
+
+ /*
+ * Get the string representation. Make it up-to-date if necessary.
+ */
+
+ string = Tcl_GetString(objPtr);
+
+ /*
+ * Parse the id into the three parts separated by dashes.
+ */
+ if ((string[0] != 's') || (string[1] != '-')) {
+ syntax:
+ Tcl_AppendResult(interp, "illegal search identifier \"", string,
+ "\"", (char *) NULL);
+ return TCL_ERROR;
+ }
+ id = strtoul(string+2, &end, 10);
+ if ((end == (string+2)) || (*end != '-')) {
+ goto syntax;
+ }
+ /*
+ * Can't perform value check in this context, so place reference
+ * to place in string to use for the check in the object instead.
+ */
+ end++;
+ offset = end - string;
+
+ if (objPtr->typePtr != NULL && objPtr->typePtr->freeIntRepProc != NULL) {
+ objPtr->typePtr->freeIntRepProc(objPtr);
+ }
+ objPtr->typePtr = &tclArraySearchType;
+ objPtr->internalRep.twoPtrValue.ptr1 = (VOID *)(((char *)NULL)+id);
+ objPtr->internalRep.twoPtrValue.ptr2 = (VOID *)(((char *)NULL)+offset);
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
* ParseSearchId --
*
- * This procedure translates from a string to a pointer to an
+ * This procedure translates from a tcl object to a pointer to an
* active array search (if there is one that matches the string).
*
* Results:
@@ -4411,41 +4490,47 @@
* the interp's result contains an error message.
*
* Side effects:
- * None.
+ * The tcl object might have its internal type and representation
+ * modified.
*
*----------------------------------------------------------------------
*/
static ArraySearch *
-ParseSearchId(interp, varPtr, varName, string)
+ParseSearchId(interp, varPtr, varName, handleObj)
Tcl_Interp *interp; /* Interpreter containing variable. */
Var *varPtr; /* Array variable search is for. */
char *varName; /* Name of array variable that search is
* supposed to be for. */
- char *string; /* String containing id of search. Must have
+ Tcl_Obj *handleObj; /* Object containing id of search. Must have
* form "search-num-var" where "num" is a
* decimal number and "var" is a variable
* name. */
{
- char *end;
+ register char *string;
+ register size_t offset;
int id;
ArraySearch *searchPtr;
/*
- * Parse the id into the three parts separated by dashes.
+ * Parse the id.
*/
-
- if ((string[0] != 's') || (string[1] != '-')) {
- syntax:
- Tcl_AppendResult(interp, "illegal search identifier \"", string,
- "\"", (char *) NULL);
+ if (Tcl_ConvertToType(interp, handleObj, &tclArraySearchType) != TCL_OK) {
return NULL;
- }
- id = strtoul(string+2, &end, 10);
- if ((end == (string+2)) || (*end != '-')) {
- goto syntax;
}
- if (strcmp(end+1, varName) != 0) {
+ /*
+ * Cast is safe, since always came from an int in the first place.
+ */
+ id = (int)(((char*)handleObj->internalRep.twoPtrValue.ptr1) -
+ ((char*)NULL));
+ string = Tcl_GetString(handleObj);
+ offset = (((char*)handleObj->internalRep.twoPtrValue.ptr2) -
+ ((char*)NULL));
+ /*
+ * This test cannot be placed inside the Tcl_Obj machinery, since
+ * it is dependent on the variable context.
+ */
+ if (strcmp(string+offset, varName) != 0) {
Tcl_AppendResult(interp, "search identifier \"", string,
"\" isn't for variable \"", varName, "\"", (char *) NULL);
return NULL;
@@ -4454,6 +4539,10 @@
/*
* Search through the list of active searches on the interpreter
* to see if the desired one exists.
+ *
+ * Note that we cannot store the searchPtr directly in the Tcl_Obj
+ * as that would run into trouble when DeleteSearches() was called
+ * so we must scan this list every time.
*/
for (searchPtr = varPtr->searchPtr; searchPtr != NULL;
