diff options
Diffstat (limited to 'generic')
| -rw-r--r-- | generic/tclIndexObj.c | 19 | ||||
| -rw-r--r-- | generic/tclInt.h | 5 | ||||
| -rw-r--r-- | generic/tclNamesp.c | 8 | ||||
| -rw-r--r-- | generic/tclObj.c | 5 | ||||
| -rw-r--r-- | generic/tclVar.c | 143 |
5 files changed, 130 insertions, 50 deletions
diff --git a/generic/tclIndexObj.c b/generic/tclIndexObj.c index 1ae0d8c..3c491dd 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.8 2000/11/24 11:27:37 dkf Exp $ + * RCS: @(#) $Id: tclIndexObj.c,v 1.9 2001/05/26 01:25:59 msofer Exp $ */ #include "tclInt.h" @@ -44,13 +44,6 @@ Tcl_ObjType tclIndexType = { * 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; /* *---------------------------------------------------------------------- @@ -171,16 +164,6 @@ Tcl_GetIndexFromObjStruct(interp, objPtr, tablePtr, offset, msg, flags, * 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; diff --git a/generic/tclInt.h b/generic/tclInt.h index cb7646b..e0ded8b 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -11,7 +11,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclInt.h,v 1.54 2001/05/17 02:13:03 hobbs Exp $ + * RCS: @(#) $Id: tclInt.h,v 1.55 2001/05/26 01:25:59 msofer Exp $ */ #ifndef _TCLINT @@ -1592,6 +1592,9 @@ extern Tcl_ObjType tclIntType; 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. diff --git a/generic/tclNamesp.c b/generic/tclNamesp.c index 577a139..e570c24 100644 --- a/generic/tclNamesp.c +++ b/generic/tclNamesp.c @@ -19,7 +19,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclNamesp.c,v 1.23 2001/05/15 14:19:13 msofer Exp $ + * RCS: @(#) $Id: tclNamesp.c,v 1.24 2001/05/26 01:25:59 msofer Exp $ */ #include "tclInt.h" @@ -166,7 +166,7 @@ Tcl_ObjType tclNsNameType = { * None. * * Side effects: - * The namespace object type is registered with the Tcl compiler. + * None. * *---------------------------------------------------------------------- */ @@ -174,7 +174,9 @@ Tcl_ObjType tclNsNameType = { void TclInitNamespaceSubsystem() { - Tcl_RegisterObjType(&tclNsNameType); + /* + * Does nothing for now. + */ } /* diff --git a/generic/tclObj.c b/generic/tclObj.c index cd2cd7a..21a4caf 100644 --- a/generic/tclObj.c +++ b/generic/tclObj.c @@ -11,7 +11,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclObj.c,v 1.21 2001/05/23 06:05:44 hobbs Exp $ + * RCS: @(#) $Id: tclObj.c,v 1.22 2001/05/26 01:25:59 msofer Exp $ */ #include "tclInt.h" @@ -155,6 +155,9 @@ TclInitObjSubsystem() 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); diff --git a/generic/tclVar.c b/generic/tclVar.c index 4f31613..f206224 100644 --- a/generic/tclVar.c +++ b/generic/tclVar.c @@ -14,7 +14,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclVar.c,v 1.32 2001/05/17 02:13:03 hobbs Exp $ + * RCS: @(#) $Id: tclVar.c,v 1.33 2001/05/26 01:25:59 msofer Exp $ */ #include "tclInt.h" @@ -53,10 +53,29 @@ static int MakeUpvar _ANSI_ARGS_(( 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 @@ Tcl_ArrayObjCmd(dummy, interp, objc, objv) switch (index) { case ARRAY_ANYMORE: { ArraySearch *searchPtr; - char *searchId; if (objc != 4) { Tcl_WrongNumArgs(interp, 2, objv, @@ -3044,8 +3062,7 @@ Tcl_ArrayObjCmd(dummy, interp, objc, objv) 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 @@ Tcl_ArrayObjCmd(dummy, interp, objc, objv) } case ARRAY_DONESEARCH: { ArraySearch *searchPtr, *prevPtr; - char *searchId; if (objc != 4) { Tcl_WrongNumArgs(interp, 2, objv, @@ -3079,8 +3095,7 @@ Tcl_ArrayObjCmd(dummy, interp, objc, objv) 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 @@ Tcl_ArrayObjCmd(dummy, interp, objc, objv) } case ARRAY_NEXTELEMENT: { ArraySearch *searchPtr; - char *searchId; Tcl_HashEntry *hPtr; if (objc != 4) { @@ -3238,8 +3252,7 @@ Tcl_ArrayObjCmd(dummy, interp, objc, objv) 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 @@ NewVar() /* *---------------------------------------------------------------------- * + * 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 @@ NewVar() * 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 @@ ParseSearchId(interp, varPtr, varName, string) /* * 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; |