Index: doc/Preserve.3 ================================================================== --- doc/Preserve.3 +++ doc/Preserve.3 @@ -48,11 +48,12 @@ performance scaling as the number of blocks managed grows large. The facilities of Itcl encounter these performance scaling issues and require an alternative that does not suffer from them. .PP \fBItcl_Alloc\fR returns an untyped pointer to an allocated block -of memory of at least \fIsize\fR bytes. +of memory of at least \fIsize\fR bytes. All \fIsize\fR bytes are +initialized to zero. .PP A module calls \fBItcl_PreserveData\fR on a pointer \fIptr\fR allocated by \fBItcl_Alloc\fR to prevent deallocation of that memory while the module remains interested in it. .PP Index: doc/class.n ================================================================== --- doc/class.n +++ doc/class.n @@ -379,20 +379,31 @@ command returns a list with the following elements: the protection level, the type (method/proc), the qualified name, the argument list and the body. Flags can be used to request specific elements from this list. .TP -\fIobjName \fBinfo variable\fR ?\fIvarName\fR? ?\fB-protection\fR? ?\fB-type\fR? ?\fB-name\fR? ?\fB-init\fR? ?\fB-value\fR? ?\fB-config\fR? +\fIobjName \fBinfo variable\fR ?\fIvarName\fR? ?\fB-protection\fR? ?\fB-type\fR? ?\fB-name\fR? ?\fB-init\fR? ?\fB-value\fR? ?\fB-config\fR? ?\fB-scope\fR? . With no arguments, this command returns a list of all object-specific variables and common data members. If \fIvarName\fR is specified, it -returns information for a specific data member. If no flags are -specified, this command returns a list with the following elements: the -protection level, the type (variable/common), the qualified name, the -initial value, and the current value. If \fIvarName\fR is a public -variable, the "config" code is included on this list. Flags can be -used to request specific elements from this list. +returns information for a specific data member. +Flags can be specified with \fIvarName\fR in an arbitrary order. +The result is a list of the specific information in exactly the +same order as the flags are specified. + +If no flags are given, this command returns a list +as if the followings flags have been specified: +.IP +\fB-protection\fR \fB-type\fR \fB-name\fR \fB-init\fR \fB-value\fR ?\fB-config\fR? + +The \fB-config\fR result is only present if \fIvarName\fR is a public +variable. It contains the code that is executed at initialization +of \fIvarName\fR. The \fB-scope\fR flag gives the namespace context +of \fIvarName\fR. Herewith the variable can be accessed from outside +the object like any other variable. It is similar to the result of +the \fBitcl::scope\fR command. + .RE .SH "CHAINING METHODS/PROCS" .PP Sometimes a base class has a method or proc that is redefined with the same name in a derived class. This is a way of making the Index: generic/itclBase.c ================================================================== --- generic/itclBase.c +++ generic/itclBase.c @@ -200,11 +200,11 @@ if (nsPtr == NULL) { Itcl_Free(infoPtr); Tcl_Panic("Itcl: cannot create namespace: \"%s\" \n", ITCL_NAMESPACE); } - nsPtr = Tcl_CreateNamespace(interp, ITCL_NAMESPACE"::internal::dicts", + nsPtr = Tcl_CreateNamespace(interp, ITCL_INTDICTS_NAMESPACE, NULL, NULL); if (nsPtr == NULL) { Itcl_Free(infoPtr); Tcl_Panic("Itcl: cannot create namespace: \"%s::internal::dicts\" \n", ITCL_NAMESPACE); Index: generic/itclBuiltin.c ================================================================== --- generic/itclBuiltin.c +++ generic/itclBuiltin.c @@ -687,11 +687,11 @@ NULL); return TCL_ERROR; } vlookup = NULL; - hPtr = Tcl_FindHashEntry(&contextIclsPtr->resolveVars, token+1); + hPtr = ItclResolveVarEntry(contextIclsPtr, token+1); if (hPtr) { vlookup = (ItclVarLookup*)Tcl_GetHashValue(hPtr); if (vlookup->ivPtr->protection != ITCL_PUBLIC) { vlookup = NULL; @@ -728,13 +728,13 @@ goto configureDone; } vlookup = NULL; token = Tcl_GetString(unparsedObjv[i]); if (*token == '-') { - hPtr = Tcl_FindHashEntry(&contextIclsPtr->resolveVars, token+1); + hPtr = ItclResolveVarEntry(contextIclsPtr, token+1); if (hPtr == NULL) { - hPtr = Tcl_FindHashEntry(&contextIclsPtr->resolveVars, token); + hPtr = ItclResolveVarEntry(contextIclsPtr, token); } if (hPtr) { vlookup = (ItclVarLookup*)Tcl_GetHashValue(hPtr); } } @@ -887,11 +887,11 @@ } } name = Tcl_GetString(objv[1]); vlookup = NULL; - hPtr = Tcl_FindHashEntry(&contextIclsPtr->resolveVars, name+1); + hPtr = ItclResolveVarEntry(contextIclsPtr, name+1); if (hPtr) { vlookup = (ItclVarLookup*)Tcl_GetHashValue(hPtr); } if ((vlookup == NULL) || (vlookup->ivPtr->protection != ITCL_PUBLIC)) { @@ -951,11 +951,11 @@ */ Tcl_DStringInit(&optName); Tcl_DStringAppend(&optName, "-", -1); iclsPtr = (ItclClass*)contextIoPtr->iclsPtr; - hPtr = Tcl_FindHashEntry(&iclsPtr->resolveVars, + hPtr = ItclResolveVarEntry(iclsPtr, Tcl_GetString(ivPtr->fullNamePtr)); assert(hPtr != NULL); vlookup = (ItclVarLookup*)Tcl_GetHashValue(hPtr); Tcl_DStringAppend(&optName, vlookup->leastQualName, -1); Index: generic/itclClass.c ================================================================== --- generic/itclClass.c +++ generic/itclClass.c @@ -284,11 +284,11 @@ Tcl_InitObjHashTable(&iclsPtr->methodVariables); Tcl_InitObjHashTable(&iclsPtr->resolveCmds); iclsPtr->numInstanceVars = 0; Tcl_InitHashTable(&iclsPtr->classCommons, TCL_ONE_WORD_KEYS); - Tcl_InitHashTable(&iclsPtr->resolveVars, TCL_ONE_WORD_KEYS); + Tcl_InitHashTable(&iclsPtr->resolveVars, TCL_STRING_KEYS); Tcl_InitHashTable(&iclsPtr->contextCache, TCL_ONE_WORD_KEYS); Itcl_InitList(&iclsPtr->bases); Itcl_InitList(&iclsPtr->derived); @@ -458,82 +458,56 @@ namePtr = Tcl_NewStringObj("type", -1); (void) Itcl_CreateVariable(interp, iclsPtr, namePtr, NULL, NULL, &ivPtr); ivPtr->protection = ITCL_PROTECTED; /* always "protected" */ ivPtr->flags |= ITCL_TYPE_VAR; /* mark as "type" variable */ - hPtr = Tcl_CreateHashEntry(&iclsPtr->variables, (char *)namePtr, - &newEntry); - Tcl_SetHashValue(hPtr, ivPtr); } if (iclsPtr->flags & (ITCL_ECLASS)) { namePtr = Tcl_NewStringObj("win", -1); (void) Itcl_CreateVariable(interp, iclsPtr, namePtr, NULL, NULL, &ivPtr); ivPtr->protection = ITCL_PROTECTED; /* always "protected" */ ivPtr->flags |= ITCL_WIN_VAR; /* mark as "win" variable */ - hPtr = Tcl_CreateHashEntry(&iclsPtr->variables, (char *)namePtr, - &newEntry); - Tcl_SetHashValue(hPtr, ivPtr); } if (iclsPtr->flags & (ITCL_TYPE|ITCL_WIDGET|ITCL_WIDGETADAPTOR)) { namePtr = Tcl_NewStringObj("self", -1); (void) Itcl_CreateVariable(interp, iclsPtr, namePtr, NULL, NULL, &ivPtr); ivPtr->protection = ITCL_PROTECTED; /* always "protected" */ ivPtr->flags |= ITCL_SELF_VAR; /* mark as "self" variable */ - hPtr = Tcl_CreateHashEntry(&iclsPtr->variables, (char *)namePtr, - &newEntry); - Tcl_SetHashValue(hPtr, ivPtr); namePtr = Tcl_NewStringObj("selfns", -1); (void) Itcl_CreateVariable(interp, iclsPtr, namePtr, NULL, NULL, &ivPtr); ivPtr->protection = ITCL_PROTECTED; /* always "protected" */ ivPtr->flags |= ITCL_SELFNS_VAR; /* mark as "selfns" variable */ - hPtr = Tcl_CreateHashEntry(&iclsPtr->variables, (char *)namePtr, - &newEntry); - Tcl_SetHashValue(hPtr, ivPtr); namePtr = Tcl_NewStringObj("win", -1); (void) Itcl_CreateVariable(interp, iclsPtr, namePtr, NULL, NULL, &ivPtr); ivPtr->protection = ITCL_PROTECTED; /* always "protected" */ ivPtr->flags |= ITCL_WIN_VAR; /* mark as "win" variable */ - hPtr = Tcl_CreateHashEntry(&iclsPtr->variables, (char *)namePtr, - &newEntry); - Tcl_SetHashValue(hPtr, ivPtr); } namePtr = Tcl_NewStringObj("this", -1); (void) Itcl_CreateVariable(interp, iclsPtr, namePtr, NULL, NULL, &ivPtr); - ivPtr->protection = ITCL_PROTECTED; /* always "protected" */ ivPtr->flags |= ITCL_THIS_VAR; /* mark as "this" variable */ - hPtr = Tcl_CreateHashEntry(&iclsPtr->variables, (char *)namePtr, - &newEntry); - Tcl_SetHashValue(hPtr, ivPtr); - if (infoPtr->currClassFlags & (ITCL_ECLASS|ITCL_TYPE|ITCL_WIDGETADAPTOR|ITCL_WIDGET)) { /* * Add the built-in "itcl_options" variable to the list of * data members. */ namePtr = Tcl_NewStringObj("itcl_options", -1); (void) Itcl_CreateVariable(interp, iclsPtr, namePtr, NULL, NULL, &ivPtr); - ivPtr->protection = ITCL_PROTECTED; /* always "protected" */ ivPtr->flags |= ITCL_OPTIONS_VAR; /* mark as "itcl_options" * variable */ - - hPtr = Tcl_CreateHashEntry(&iclsPtr->variables, (char *)namePtr, - &newEntry); - Tcl_SetHashValue(hPtr, ivPtr); - } if (infoPtr->currClassFlags & ITCL_ECLASS) { /* * Add the built-in "itcl_option_components" variable to the list of @@ -540,34 +514,23 @@ * data members. */ namePtr = Tcl_NewStringObj("itcl_option_components", -1); (void) Itcl_CreateVariable(interp, iclsPtr, namePtr, NULL, NULL, &ivPtr); - ivPtr->protection = ITCL_PROTECTED; /* always "protected" */ ivPtr->flags |= ITCL_OPTION_COMP_VAR; /* mark as "itcl_option_components" * variable */ - - hPtr = Tcl_CreateHashEntry(&iclsPtr->variables, (char *)namePtr, - &newEntry); - Tcl_SetHashValue(hPtr, ivPtr); - } if (infoPtr->currClassFlags & (ITCL_WIDGET|ITCL_WIDGETADAPTOR)) { /* * Add the built-in "thiswin" variable to the list of data members. */ namePtr = Tcl_NewStringObj("thiswin", -1); (void) Itcl_CreateVariable(interp, iclsPtr, namePtr, NULL, NULL, &ivPtr); - ivPtr->protection = ITCL_PROTECTED; /* always "protected" */ ivPtr->flags |= ITCL_THIS_VAR; /* mark as "thiswin" variable */ - - hPtr = Tcl_CreateHashEntry(&iclsPtr->variables, (char *)namePtr, - &newEntry); - Tcl_SetHashValue(hPtr, ivPtr); } if (infoPtr->currClassFlags & (ITCL_WIDGET|ITCL_WIDGETADAPTOR)) { /* create the itcl_hull component */ ItclComponent *icPtr; namePtr = Tcl_NewStringObj("itcl_hull", 9); @@ -1640,10 +1603,213 @@ Tcl_NRAddCallback(interp, CallCreateObject, objNamePtr, iclsPtr, INT2PTR(objc-4), newObjv); return Itcl_NRRunCallbacks(interp, callbackPtr); } + +/* + * ------------------------------------------------------------------------ + * ItclResolveVarEntry() + * + * Side effect: (re)build part of resolver hash-table on demand. + * ------------------------------------------------------------------------ + */ +Tcl_HashEntry * +ItclResolveVarEntry( + ItclClass* iclsPtr, /* class definition where to resolve variable */ + const char *lookupName) /* name of variable being resolved */ +{ + Tcl_HashEntry *reshPtr, *hPtr; + + /* could be resolved directly */ + if ((reshPtr = Tcl_FindHashEntry(&iclsPtr->resolveVars, lookupName)) != NULL) { + return reshPtr; + } else { + /* try to build virtual table for this var */ + const char *varName, *simpleName; + Tcl_DString buffer, buffer2, *bufferC; + ItclHierIter hier; + ItclClass* iclsPtr2; + ItclVarLookup *vlookup; + ItclVariable *ivPtr; + Tcl_Namespace* nsPtr; + Tcl_Obj *vnObjPtr; + int newEntry, processAncestors; + size_t varLen; + + /* (de)qualify to simple name */ + varName = simpleName = lookupName; + while(*varName) { + if (*varName++ == ':') { + if (*varName++ == ':') { simpleName = varName; } + }; + } + vnObjPtr = Tcl_NewStringObj(simpleName, -1); + + processAncestors = simpleName != lookupName; + + Tcl_DStringInit(&buffer); + Tcl_DStringInit(&buffer2); + + /* + * Scan through all classes in the hierarchy, from most to + * least specific. Add a lookup entry for each variable + * into the table. + */ + Itcl_InitHierIter(&hier, iclsPtr); + iclsPtr2 = Itcl_AdvanceHierIter(&hier); + while (iclsPtr2 != NULL) { + + hPtr = Tcl_FindHashEntry(&iclsPtr2->variables, vnObjPtr); + if (hPtr) { + ivPtr = (ItclVariable*)Tcl_GetHashValue(hPtr); + + vlookup = NULL; + + /* + * Create all possible names for this variable and enter + * them into the variable resolution table: + * var + * class::var + * namesp1::class::var + * namesp2::namesp1::class::var + * ... + */ + varName = simpleName; varLen = -1; + bufferC = &buffer; + nsPtr = iclsPtr2->nsPtr; + + while (1) { + hPtr = Tcl_CreateHashEntry(&iclsPtr->resolveVars, + varName, &newEntry); + + /* check for same name in current class */ + if (!newEntry) { + vlookup = (ItclVarLookup*)Tcl_GetHashValue(hPtr); + if (vlookup->ivPtr != ivPtr && iclsPtr2 == iclsPtr) { + /* if used multiple times - unbind, else - overwrite */ + if (vlookup->usage > 1) { + /* correct leastQualName */ + vlookup->leastQualName = NULL; + processAncestors = 1; /* correction in progress */ + /* should create new lookup */ + --vlookup->usage; + vlookup = NULL; + } else { + /* correct values (overwrite) */ + vlookup->usage = 0; + goto setResVar; + } + newEntry = 1; + } else { + /* var exists and no correction necessary - next var */ + if (!processAncestors) { + break; + } + /* check leastQualName correction needed */ + if (!vlookup->leastQualName) { + vlookup->leastQualName = + Tcl_GetHashKey(&iclsPtr->resolveVars, hPtr); + } + /* reset vlookup for full-qualified names - new lookup */ + if (vlookup->ivPtr != ivPtr) { + vlookup = NULL; + } + } + } + if (newEntry) { + if (!vlookup) { + /* create new (or overwrite) */ + vlookup = (ItclVarLookup *)ckalloc(sizeof(ItclVarLookup)); + vlookup->usage = 0; + + setResVar: + + vlookup->ivPtr = ivPtr; + vlookup->leastQualName = + Tcl_GetHashKey(&iclsPtr->resolveVars, hPtr); + + /* + * If this variable is PRIVATE to another class scope, + * then mark it as "inaccessible". + */ + vlookup->accessible = (ivPtr->protection != ITCL_PRIVATE || + ivPtr->iclsPtr == iclsPtr); + + /* + * Set aside the first object-specific slot for the built-in + * "this" variable. Only allocate one of these, even though + * there is a definition for "this" in each class scope. + * Set aside the second and third object-specific slot for the built-in + * "itcl_options" and "itcl_option_components" variable. + */ + if (!iclsPtr->numInstanceVars) { + iclsPtr->numInstanceVars += 3; + } + /* + * If this is a reference to the built-in "this" + * variable, then its index is "0". Otherwise, + * add another slot to the end of the table. + */ + if ((ivPtr->flags & ITCL_THIS_VAR) != 0) { + vlookup->varNum = 0; + } else { + if ((ivPtr->flags & ITCL_OPTIONS_VAR) != 0) { + vlookup->varNum = 1; + } else { + vlookup->varNum = iclsPtr->numInstanceVars++; + } + } + } + + Tcl_SetHashValue(hPtr, vlookup); + vlookup->usage++; + } + + /* if we have found it */ + if (simpleName == lookupName || strcmp(varName, lookupName) == 0) { + if (!reshPtr) { + reshPtr = hPtr; + } + break; + } + if (nsPtr == NULL) { + break; + } + Tcl_DStringSetLength(bufferC, 0); + Tcl_DStringAppend(bufferC, nsPtr->name, -1); + Tcl_DStringAppend(bufferC, "::", 2); + Tcl_DStringAppend(bufferC, varName, varLen); + varName = Tcl_DStringValue(bufferC); + varLen = Tcl_DStringLength(bufferC); + bufferC = (bufferC == &buffer) ? &buffer2 : &buffer; + + nsPtr = nsPtr->parentPtr; + } + + } + + /* Stop create vars for ancestors (if not needed) */ + if (!processAncestors && reshPtr) { + /* simple name - don't need to check ancestors */ + break; + } + + iclsPtr2 = Itcl_AdvanceHierIter(&hier); + } + Itcl_DeleteHierIter(&hier); + + Tcl_DStringFree(&buffer); + Tcl_DStringFree(&buffer2); + Tcl_DecrRefCount(vnObjPtr); + + if (reshPtr == NULL) { + reshPtr = Tcl_FindHashEntry(&iclsPtr->resolveVars, lookupName); + } + return reshPtr; + } +} /* * ------------------------------------------------------------------------ * Itcl_BuildVirtualTables() * @@ -1653,11 +1819,11 @@ * * METHODS: resolveCmds * Used primarily in Itcl_ClassCmdResolver() to resolve all * command references in a namespace. * - * DATA MEMBERS: resolveVars + * DATA MEMBERS: resolveVars (built on demand, moved to ItclResolveVarEntry) * Used primarily in Itcl_ClassVarResolver() to quickly resolve * variable references in each class scope. * * These tables store every possible name for each command/variable * (member, class::member, namesp::class::member, etc.). Members @@ -1671,14 +1837,12 @@ ItclClass* iclsPtr) /* class definition being updated */ { Tcl_HashEntry *hPtr; Tcl_HashSearch place; Tcl_Namespace* nsPtr; - Tcl_DString buffer, buffer2; + Tcl_DString buffer, buffer2, *bufferC, *bufferC2, *bufferSwp; Tcl_Obj *objPtr; - ItclVarLookup *vlookup; - ItclVariable *ivPtr; ItclMemberFunc *imPtr; ItclDelegatedFunction *idmPtr; ItclHierIter hier; ItclClass *iclsPtr2; ItclCmdLookup *clookupPtr; @@ -1685,137 +1849,19 @@ int newEntry; Tcl_DStringInit(&buffer); Tcl_DStringInit(&buffer2); - /* - * Clear the variable resolution table. - */ - hPtr = Tcl_FirstHashEntry(&iclsPtr->resolveVars, &place); - while (hPtr) { - vlookup = (ItclVarLookup*)Tcl_GetHashValue(hPtr); - if (--vlookup->usage == 0) { - ckfree((char*)vlookup); - } - hPtr = Tcl_NextHashEntry(&place); - } - Tcl_DeleteHashTable(&iclsPtr->resolveVars); - Tcl_InitHashTable(&iclsPtr->resolveVars, TCL_STRING_KEYS); - iclsPtr->numInstanceVars = 0; - - /* - * Set aside the first object-specific slot for the built-in - * "this" variable. Only allocate one of these, even though - * there is a definition for "this" in each class scope. - * Set aside the second and third object-specific slot for the built-in - * "itcl_options" and "itcl_option_components" variable. - */ - iclsPtr->numInstanceVars++; - iclsPtr->numInstanceVars++; - iclsPtr->numInstanceVars++; - - /* - * Scan through all classes in the hierarchy, from most to - * least specific. Add a lookup entry for each variable - * into the table. - */ - Itcl_InitHierIter(&hier, iclsPtr); - iclsPtr2 = Itcl_AdvanceHierIter(&hier); - while (iclsPtr2 != NULL) { - hPtr = Tcl_FirstHashEntry(&iclsPtr2->variables, &place); - while (hPtr) { - ivPtr = (ItclVariable*)Tcl_GetHashValue(hPtr); - - vlookup = (ItclVarLookup *)ckalloc(sizeof(ItclVarLookup)); - vlookup->ivPtr = ivPtr; - vlookup->usage = 0; - vlookup->leastQualName = NULL; - - /* - * If this variable is PRIVATE to another class scope, - * then mark it as "inaccessible". - */ - vlookup->accessible = (ivPtr->protection != ITCL_PRIVATE || - ivPtr->iclsPtr == iclsPtr); - - /* - * If this is a reference to the built-in "this" - * variable, then its index is "0". Otherwise, - * add another slot to the end of the table. - */ - if ((ivPtr->flags & ITCL_THIS_VAR) != 0) { - vlookup->varNum = 0; - } else { - if ((ivPtr->flags & ITCL_OPTIONS_VAR) != 0) { - vlookup->varNum = 1; - } else { - vlookup->varNum = iclsPtr->numInstanceVars++; - } - } -/* FIXME !!! should use for var lookup !! */ - - /* - * Create all possible names for this variable and enter - * them into the variable resolution table: - * var - * class::var - * namesp1::class::var - * namesp2::namesp1::class::var - * ... - */ - Tcl_DStringSetLength(&buffer, 0); - Tcl_DStringAppend(&buffer, Tcl_GetString(ivPtr->namePtr), -1); - nsPtr = iclsPtr2->nsPtr; - - while (1) { - hPtr = Tcl_CreateHashEntry(&iclsPtr->resolveVars, - Tcl_DStringValue(&buffer), &newEntry); - - if (newEntry) { - Tcl_SetHashValue(hPtr, vlookup); - vlookup->usage++; - - if (!vlookup->leastQualName) { - vlookup->leastQualName = (char *) - Tcl_GetHashKey(&iclsPtr->resolveVars, hPtr); - } - } - - if (nsPtr == NULL) { - break; - } - Tcl_DStringSetLength(&buffer2, 0); - Tcl_DStringAppend(&buffer2, Tcl_DStringValue(&buffer), -1); - Tcl_DStringSetLength(&buffer, 0); - Tcl_DStringAppend(&buffer, nsPtr->name, -1); - Tcl_DStringAppend(&buffer, "::", -1); - Tcl_DStringAppend(&buffer, Tcl_DStringValue(&buffer2), -1); - - nsPtr = nsPtr->parentPtr; - } - - /* - * If this record is not needed, free it now. - */ - if (vlookup->usage == 0) { - ckfree((char*)vlookup); - } - hPtr = Tcl_NextHashEntry(&place); - } - iclsPtr2 = Itcl_AdvanceHierIter(&hier); - } - Itcl_DeleteHierIter(&hier); - /* * Clear the command resolution table. */ while (1) { hPtr = Tcl_FirstHashEntry(&iclsPtr->resolveCmds, &place); if (hPtr == NULL) { break; } - clookupPtr = (ItclCmdLookup *)Tcl_GetHashValue(hPtr); + clookupPtr = Tcl_GetHashValue(hPtr); ckfree((char *)clookupPtr); Tcl_DeleteHashEntry(hPtr); } Tcl_DeleteHashTable(&iclsPtr->resolveCmds); Tcl_InitObjHashTable(&iclsPtr->resolveCmds); @@ -1841,14 +1887,16 @@ * namesp2::namesp1::class::func * ... */ Tcl_DStringSetLength(&buffer, 0); Tcl_DStringAppend(&buffer, Tcl_GetString(imPtr->namePtr), -1); + bufferC = &buffer; bufferC2 = &buffer2; nsPtr = iclsPtr2->nsPtr; while (1) { - objPtr = Tcl_NewStringObj(Tcl_DStringValue(&buffer), -1); + objPtr = Tcl_NewStringObj(Tcl_DStringValue(bufferC), + Tcl_DStringLength(bufferC)); hPtr = Tcl_CreateHashEntry(&iclsPtr->resolveCmds, (char *)objPtr, &newEntry); if (newEntry) { clookupPtr = (ItclCmdLookup *)ckalloc(sizeof(ItclCmdLookup)); @@ -1860,16 +1908,17 @@ } if (nsPtr == NULL) { break; } - Tcl_DStringSetLength(&buffer2, 0); - Tcl_DStringAppend(&buffer2, Tcl_DStringValue(&buffer), -1); - Tcl_DStringSetLength(&buffer, 0); - Tcl_DStringAppend(&buffer, nsPtr->name, -1); - Tcl_DStringAppend(&buffer, "::", -1); - Tcl_DStringAppend(&buffer, Tcl_DStringValue(&buffer2), -1); + + Tcl_DStringSetLength(bufferC2, 0); + Tcl_DStringAppend(bufferC2, nsPtr->name, -1); + Tcl_DStringAppend(bufferC2, "::", 2); + Tcl_DStringAppend(bufferC2, Tcl_DStringValue(bufferC), + Tcl_DStringLength(bufferC)); + bufferSwp = bufferC; bufferC = bufferC2; bufferC2 = bufferSwp; nsPtr = nsPtr->parentPtr; } hPtr = Tcl_NextHashEntry(&place); } @@ -2051,11 +2100,11 @@ return TCL_OK; } /* * ------------------------------------------------------------------------ - * Itcl_CreateMethodVariable() + * ItclCreateMethodVariable(), Itcl_CreateMethodVariable() * * Creates a new class methdovariable definition. If this is a public * methodvariable, * * Returns TCL_ERROR along with an error message in the specified @@ -2062,14 +2111,13 @@ * interpreter if anything goes wrong. Otherwise, this returns * TCL_OK and a pointer to the new option definition in "imvPtr". * ------------------------------------------------------------------------ */ int -Itcl_CreateMethodVariable( +ItclCreateMethodVariable( Tcl_Interp *interp, /* interpreter managing this transaction */ - ItclClass* iclsPtr, /* class containing this variable */ - Tcl_Obj* namePtr, /* variable name */ + ItclVariable *ivPtr, /* variable reference (from Itcl_CreateVariable) */ Tcl_Obj* defaultPtr, /* initial value */ Tcl_Obj* callbackPtr, /* code invoked when variable is set */ ItclMethodVariable** imvPtrPtr) /* returns: new methdovariable definition */ { @@ -2079,35 +2127,31 @@ /* * Add this methodvariable to the options table for the class. * Make sure that the methodvariable name does not already exist. */ - hPtr = Tcl_CreateHashEntry(&iclsPtr->methodVariables, - (char *)namePtr, &isNew); + hPtr = Tcl_CreateHashEntry(&ivPtr->iclsPtr->methodVariables, + (char *)ivPtr->namePtr, &isNew); if (!isNew) { Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), - "methdovariable name \"", Tcl_GetString(namePtr), + "methdovariable name \"", Tcl_GetString(ivPtr->namePtr), "\" already defined in class \"", - Tcl_GetString (iclsPtr->fullNamePtr), "\"", + Tcl_GetString (ivPtr->iclsPtr->fullNamePtr), "\"", NULL); return TCL_ERROR; } - Tcl_IncrRefCount(namePtr); /* * If everything looks good, create the option definition. */ imvPtr = (ItclMethodVariable*)ckalloc(sizeof(ItclMethodVariable)); memset(imvPtr, 0, sizeof(ItclMethodVariable)); - imvPtr->iclsPtr = iclsPtr; + imvPtr->iclsPtr = ivPtr->iclsPtr; imvPtr->protection = Itcl_Protection(interp, 0); - imvPtr->namePtr = namePtr; + imvPtr->namePtr = ivPtr->namePtr; Tcl_IncrRefCount(imvPtr->namePtr); - imvPtr->fullNamePtr = Tcl_NewStringObj( - Tcl_GetString(iclsPtr->fullNamePtr), -1); - Tcl_AppendToObj(imvPtr->fullNamePtr, "::", 2); - Tcl_AppendToObj(imvPtr->fullNamePtr, Tcl_GetString(namePtr), -1); + imvPtr->fullNamePtr = ivPtr->fullNamePtr; Tcl_IncrRefCount(imvPtr->fullNamePtr); imvPtr->defaultValuePtr = defaultPtr; if (defaultPtr != NULL) { Tcl_IncrRefCount(imvPtr->defaultValuePtr); } @@ -2124,10 +2168,46 @@ *imvPtrPtr = imvPtr; return TCL_OK; } +/* + * TODO: remove this if unused (seems to be internal API only), + * now superseded by ItclCreateMethodVariable. + */ +int +Itcl_CreateMethodVariable( + Tcl_Interp *interp, /* interpreter managing this transaction */ + ItclClass* iclsPtr, /* class containing this variable */ + Tcl_Obj* namePtr, /* variable name */ + Tcl_Obj* defaultPtr, /* initial value */ + Tcl_Obj* callbackPtr, /* code invoked when variable is set */ + ItclMethodVariable** imvPtrPtr) + /* returns: new methdovariable definition */ +{ + ItclVariable *ivPtr; + Tcl_HashEntry *hPtr; + + /* + * Search variable reference (ivPtr). + */ + hPtr = Tcl_FindHashEntry(&iclsPtr->variables, (char *)namePtr); + if (!hPtr || !(ivPtr = (ItclVariable*)Tcl_GetHashValue(hPtr))) { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "variable name \"", Tcl_GetString(namePtr), + "\" is not declared in class \"", + Tcl_GetString (iclsPtr->fullNamePtr), "\"", + NULL); + return TCL_ERROR; + } + + /* + * Create method variable. + */ + return ItclCreateMethodVariable(interp, ivPtr, defaultPtr, callbackPtr, + imvPtrPtr); +} /* * ------------------------------------------------------------------------ * Itcl_GetCommonVar() Index: generic/itclCmd.c ================================================================== --- generic/itclCmd.c +++ generic/itclCmd.c @@ -745,11 +745,11 @@ contextIclsPtr = (ItclClass *)Tcl_GetHashValue(hPtr); } if (Itcl_IsClassNamespace(contextNsPtr)) { ClientData clientData; - entry = Tcl_FindHashEntry(&contextIclsPtr->resolveVars, token); + entry = ItclResolveVarEntry(contextIclsPtr, token); if (!entry) { Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "variable \"", token, "\" not found in class \"", Tcl_GetString(contextIclsPtr->fullNamePtr), "\"", NULL); Index: generic/itclHelpers.c ================================================================== --- generic/itclHelpers.c +++ generic/itclHelpers.c @@ -1120,11 +1120,11 @@ int newValue1; keyPtr = iclsPtr->fullNamePtr; dictPtr = Tcl_GetVar2Ex(interp, ITCL_NAMESPACE"::internal::dicts::classVariables", - NULL, 0); + NULL, TCL_GLOBAL_ONLY); if (dictPtr == NULL) { Tcl_AppendResult(interp, "cannot get dict ", ITCL_NAMESPACE, "::internal::dicts::classVariables", NULL); return TCL_ERROR; } @@ -1245,11 +1245,11 @@ return TCL_ERROR; } } Tcl_SetVar2Ex(interp, ITCL_NAMESPACE"::internal::dicts::classVariables", - NULL, dictPtr, 0); + NULL, dictPtr, TCL_GLOBAL_ONLY); return TCL_OK; } /* * ------------------------------------------------------------------------ @@ -1271,11 +1271,11 @@ int haveFlags; int newValue1; dictPtr = Tcl_GetVar2Ex(interp, ITCL_NAMESPACE"::internal::dicts::classFunctions", - NULL, 0); + NULL, TCL_GLOBAL_ONLY); if (dictPtr == NULL) { Tcl_AppendResult(interp, "cannot get dict ", ITCL_NAMESPACE, "::internal::dicts::classFunctions", NULL); return TCL_ERROR; } @@ -1405,11 +1405,11 @@ return TCL_ERROR; } } Tcl_SetVar2Ex(interp, ITCL_NAMESPACE"::internal::dicts::classFunctions", - NULL, dictPtr, 0); + NULL, dictPtr, TCL_GLOBAL_ONLY); return TCL_OK; } /* * ------------------------------------------------------------------------ Index: generic/itclInfo.c ================================================================== --- generic/itclInfo.c +++ generic/itclInfo.c @@ -199,11 +199,11 @@ "?pattern?", Itcl_BiInfoTypeVarsCmd, ITCL_TYPE|ITCL_WIDGETADAPTOR|ITCL_WIDGET|ITCL_ECLASS }, { "variable", - "?name? ?-protection? ?-type? ?-name? ?-init? ?-value? ?-config?", + "?name? ?-protection? ?-type? ?-name? ?-init? ?-value? ?-config? ?-scope?", Itcl_BiInfoVariableCmd, ITCL_CLASS|ITCL_TYPE|ITCL_WIDGETADAPTOR|ITCL_WIDGET|ITCL_ECLASS }, { "variables", "?pattern?", @@ -1254,10 +1254,11 @@ * data members is returned. Otherwise, the information for a * specific member is returned. Returns a status TCL_OK/TCL_ERROR * to indicate success/failure. * ------------------------------------------------------------------------ */ +/*&&&1*/ /* ARGSUSED */ int Itcl_BiInfoVariableCmd( ClientData clientData, /* ItclObjectInfo Ptr */ Tcl_Interp *interp, /* current interpreter */ @@ -1276,19 +1277,24 @@ ItclHierIter hier; char *varName; const char *val; int i; int result; + + ClientData cfClientData; + ItclObjectInfo *infoPtr; + Tcl_Object oPtr; + int doAppend; static const char *options[] = { "-config", "-init", "-name", "-protection", "-type", - "-value", NULL + "-value", "-scope", NULL }; enum BIvIdx { BIvConfigIdx, BIvInitIdx, BIvNameIdx, BIvProtectIdx, - BIvTypeIdx, BIvValueIdx - } *ivlist, ivlistStorage[6]; + BIvTypeIdx, BIvValueIdx, BIvScopeIdx + } *ivlist, ivlistStorage[7]; static enum BIvIdx DefInfoVariable[5] = { BIvProtectIdx, BIvTypeIdx, BIvNameIdx, @@ -1302,11 +1308,10 @@ BIvNameIdx, BIvInitIdx, BIvConfigIdx, BIvValueIdx }; - ItclShowArgs(1, "Itcl_BiInfoVariableCmd", objc, objv); resultPtr = NULL; objPtr = NULL; varName = NULL; @@ -1325,11 +1330,11 @@ contextIclsPtr = contextIoPtr->iclsPtr; } /* * Process args: - * ?varName? ?-protection? ?-type? ?-name? ?-init? ?-config? ?-value? + * ?varName? ?-protection? ?-type? ?-name? ?-init? ?-config? ?-value? ?-scope? */ objv++; /* skip over command name */ objc--; if (objc > 0) { @@ -1339,11 +1344,11 @@ /* * Return info for a specific variable. */ if (varName) { - entry = Tcl_FindHashEntry(&contextIclsPtr->resolveVars, varName); + entry = ItclResolveVarEntry(contextIclsPtr, varName); if (entry == NULL) { Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "\"", varName, "\" isn't a variable in class \"", contextIclsPtr->nsPtr->fullName, "\"", NULL); @@ -1463,10 +1468,82 @@ if (val == NULL) { val = ""; } objPtr = Tcl_NewStringObj((const char *)val, -1); break; + + case BIvScopeIdx: + entry = Tcl_FindHashEntry(&contextIclsPtr->resolveVars, varName); + if (!entry) { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "variable \"", varName, "\" not found in class \"", + Tcl_GetString(contextIclsPtr->fullNamePtr), "\"", + (char*)NULL); + return TCL_ERROR; + } + vlookup = (ItclVarLookup*)Tcl_GetHashValue(entry); + + if (vlookup->ivPtr->flags & ITCL_COMMON) { + objPtr = Tcl_NewStringObj("", -1); + + if (vlookup->ivPtr->protection != ITCL_PUBLIC) { + Tcl_AppendToObj(objPtr, ITCL_VARIABLES_NAMESPACE, -1); + } + Tcl_AppendToObj(objPtr, + Tcl_GetString(vlookup->ivPtr->fullNamePtr), -1); + } else { + /* + * If this is not a common variable, then we better have + * an object context. Return the name as a fully qualified name. + */ + infoPtr = contextIclsPtr->infoPtr; + cfClientData = Itcl_GetCallFrameClientData(interp); + if (cfClientData != NULL) { + oPtr = Tcl_ObjectContextObject((Tcl_ObjectContext)cfClientData); + if (oPtr != NULL) { + contextIoPtr = (ItclObject*)Tcl_ObjectGetMetadata( + oPtr, infoPtr->object_meta_type); + } + } + + if (contextIoPtr == NULL) { + if (infoPtr->currIoPtr != NULL) { + contextIoPtr = infoPtr->currIoPtr; + } + } + + if (contextIoPtr == NULL) { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "can't scope variable \"", varName, + "\": missing object context", + (char*)NULL); + return TCL_ERROR; + } + + doAppend = 1; + if (contextIclsPtr->flags & ITCL_ECLASS) { + if (strcmp(varName, "itcl_options") == 0) { + doAppend = 0; + } + } + + objPtr = Tcl_NewStringObj((char*)NULL, 0); + Tcl_IncrRefCount(objPtr); + Tcl_AppendToObj(objPtr, ITCL_VARIABLES_NAMESPACE, -1); + Tcl_AppendToObj(objPtr, + (Tcl_GetObjectNamespace(contextIoPtr->oPtr))->fullName, -1); + + if (doAppend) { + Tcl_AppendToObj(objPtr, + Tcl_GetString(vlookup->ivPtr->fullNamePtr), -1); + } else { + Tcl_AppendToObj(objPtr, "::", -1); + Tcl_AppendToObj(objPtr, + Tcl_GetString(vlookup->ivPtr->namePtr), -1); + } + } + break; } if (objc == 1) { resultPtr = objPtr; } else { @@ -4024,11 +4101,11 @@ /* * Return info for a specific variable. */ if (varName) { - hPtr = Tcl_FindHashEntry(&contextIclsPtr->resolveVars, varName); + hPtr = ItclResolveVarEntry(contextIclsPtr, varName); if (hPtr == NULL) { Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "\"", varName, "\" isn't a typevariable in class \"", contextIclsPtr->nsPtr->fullName, "\"", NULL); Index: generic/itclInt.h ================================================================== --- generic/itclInt.h +++ generic/itclInt.h @@ -65,16 +65,15 @@ * dynamic loading can fail to find the __assert function. * As a workaround, we'll include our own. */ #undef assert -#define DEBUG 1 -#ifndef DEBUG +#if defined(NDEBUG) && !defined(DEBUG) #define assert(EX) ((void)0) -#else +#else /* !NDEBUG || DEBUG */ #define assert(EX) (void)((EX) || (Itcl_Assert(STRINGIFY(EX), __FILE__, __LINE__), 0)) -#endif /* DEBUG */ +#endif #define ITCL_INTERP_DATA "itcl_data" #define ITCL_TK_VERSION "8.6" /* @@ -98,12 +97,14 @@ * What sort of size of things we like to allocate. */ #define ALLOC_CHUNK 8 -#define ITCL_VARIABLES_NAMESPACE "::itcl::internal::variables" -#define ITCL_COMMANDS_NAMESPACE "::itcl::internal::commands" +#define ITCL_INT_NAMESPACE ITCL_NAMESPACE"::internal" +#define ITCL_INTDICTS_NAMESPACE ITCL_INT_NAMESPACE"::dicts" +#define ITCL_VARIABLES_NAMESPACE ITCL_INT_NAMESPACE"::variables" +#define ITCL_COMMANDS_NAMESPACE ITCL_INT_NAMESPACE"::commands" typedef struct ItclFoundation { Itcl_Stack methodCallStack; Tcl_Command dispatchCommand; } ItclFoundation; @@ -691,10 +692,13 @@ ItclObject *ioPtr); MODULE_SCOPE void ItclDeleteClassVariablesNamespace(Tcl_Interp *interp, ItclClass *iclsPtr); MODULE_SCOPE int ItclInfoInit(Tcl_Interp *interp, ItclObjectInfo *infoPtr); +MODULE_SCOPE Tcl_HashEntry *ItclResolveVarEntry( + ItclClass* iclsPtr, const char *varName); + struct Tcl_ResolvedVarInfo; MODULE_SCOPE int Itcl_ClassCmdResolver(Tcl_Interp *interp, const char* name, Tcl_Namespace *nsPtr, int flags, Tcl_Command *rPtr); MODULE_SCOPE int Itcl_ClassVarResolver(Tcl_Interp *interp, const char* name, Tcl_Namespace *nsPtr, int flags, Tcl_Var *rPtr); @@ -710,10 +714,13 @@ struct Tcl_ResolvedVarInfo **rPtr); MODULE_SCOPE int ItclSetParserResolver(Tcl_Namespace *nsPtr); MODULE_SCOPE void ItclProcErrorProc(Tcl_Interp *interp, Tcl_Obj *procNameObj); MODULE_SCOPE int Itcl_CreateOption (Tcl_Interp *interp, ItclClass *iclsPtr, ItclOption *ioptPtr); +MODULE_SCOPE int ItclCreateMethodVariable(Tcl_Interp *interp, + ItclVariable *ivPtr, Tcl_Obj* defaultPtr, Tcl_Obj* callbackPtr, + ItclMethodVariable** imvPtrPtr); MODULE_SCOPE int Itcl_CreateMethodVariable (Tcl_Interp *interp, ItclClass *iclsPtr, Tcl_Obj *name, Tcl_Obj *defaultPtr, Tcl_Obj *callbackPtr, ItclMethodVariable **imvPtr); MODULE_SCOPE int DelegationInstall(Tcl_Interp *interp, ItclObject *ioPtr, ItclClass *iclsPtr); Index: generic/itclMethod.c ================================================================== --- generic/itclMethod.c +++ generic/itclMethod.c @@ -239,11 +239,11 @@ * Note that variable resolution table has *all* variables, * even those in a base class. Make sure that the class * containing the variable definition is the requested class. */ vlookup = NULL; - entry = Tcl_FindHashEntry(&iclsPtr->resolveVars, tail); + entry = ItclResolveVarEntry(iclsPtr, tail); if (entry) { vlookup = (ItclVarLookup*)Tcl_GetHashValue(entry); if (vlookup->ivPtr->iclsPtr != iclsPtr) { vlookup = NULL; } @@ -2218,11 +2218,11 @@ infoPtr = iclsPtr->infoPtr; hPtr = Tcl_FindHashEntry(&infoPtr->namespaceClasses, (char *)nsPtr); if (hPtr != NULL) { iclsPtr = (ItclClass *)Tcl_GetHashValue(hPtr); } - hPtr = Tcl_FindHashEntry(&iclsPtr->resolveVars, varName); + hPtr = ItclResolveVarEntry(iclsPtr, varName); if (hPtr == NULL) { /* no class/object variable */ return NULL; } ivlPtr = (ItclVarLookup *)Tcl_GetHashValue(hPtr); Index: generic/itclObject.c ================================================================== --- generic/itclObject.c +++ generic/itclObject.c @@ -871,11 +871,11 @@ Tcl_AppendResult(interp, "INTERNAL ERROR cannot set", " variable \"", varName, "\"\n", NULL); goto errorCleanup; } } - hPtr2 = Tcl_FindHashEntry(&ivPtr->iclsPtr->resolveVars, varName); + hPtr2 = ItclResolveVarEntry(ivPtr->iclsPtr, varName); if (hPtr2 == NULL) { hPtr = Tcl_NextHashEntry(&place); continue; } if ((ivPtr->flags & ITCL_COMMON) == 0) { @@ -1624,11 +1624,11 @@ iclsPtr = contextIoPtr->iclsPtr; } else { iclsPtr = contextIclsPtr; } ivPtr = NULL; - hPtr = Tcl_FindHashEntry(&iclsPtr->resolveVars, (char *)name1); + hPtr = ItclResolveVarEntry(iclsPtr, (char *)name1); if (hPtr != NULL) { vlookup = (ItclVarLookup *)Tcl_GetHashValue(hPtr); ivPtr = vlookup->ivPtr; /* * Install the object context and access the data member @@ -1639,11 +1639,11 @@ Tcl_Obj *varName = Tcl_NewObj(); Tcl_Var varPtr = (Tcl_Var)Tcl_GetHashValue(hPtr); Tcl_GetVariableFullName(interp, varPtr, varName); val = Tcl_GetVar2(interp, Tcl_GetString(varName), name2, - TCL_LEAVE_ERR_MSG); + TCL_LEAVE_ERR_MSG | TCL_GLOBAL_ONLY); Tcl_DecrRefCount(varName); if (val) { return val; } } @@ -1840,11 +1840,11 @@ if (contextIclsPtr == NULL) { iclsPtr = contextIoPtr->iclsPtr; } else { iclsPtr = contextIclsPtr; } - hPtr = Tcl_FindHashEntry(&iclsPtr->resolveVars, (char *)name1); + hPtr = ItclResolveVarEntry(iclsPtr, (char *)name1); if (hPtr != NULL) { vlookup = (ItclVarLookup *)Tcl_GetHashValue(hPtr); ivPtr = vlookup->ivPtr; } else { return NULL; @@ -3494,11 +3494,11 @@ Tcl_DString buffer; ItclVarLookup *vlookup; ItclVariable *ivPtr; const char *val; - hPtr = Tcl_FindHashEntry(&iclsPtr->resolveVars, (char *)varName); + hPtr = ItclResolveVarEntry(iclsPtr, (char *)varName); if (hPtr == NULL) { /* no such variable */ return NULL; } vlookup = (ItclVarLookup *)Tcl_GetHashValue(hPtr); Index: generic/itclParse.c ================================================================== --- generic/itclParse.c +++ generic/itclParse.c @@ -580,11 +580,10 @@ if (ItclCreateComponent(interp, iclsPtr, namePtr, ITCL_COMMON, &icPtr) != TCL_OK) { return TCL_ERROR; } iclsPtr->numVariables++; - Itcl_BuildVirtualTables(iclsPtr); } Tcl_ResetResult(interp); Tcl_AppendResult(interp, Tcl_GetString(iclsPtr->fullNamePtr), NULL); return result; } @@ -2139,48 +2138,41 @@ result = Itcl_PushCallFrame(interp, &frame, commonNsPtr, /* isProcCallFrame */ 0); Itcl_PopCallFrame(interp); /* - * TRICKY NOTE: Make sure to rebuild the virtual tables for this - * class so that this variable is ready to access. The variable - * resolver for the parser namespace needs this info to find the - * variable if the developer tries to set it within the class - * definition. - * * If an initialization value was specified, then initialize - * the variable now. + * the variable now, otherwise be sure the variable is uninitialized. */ - Itcl_BuildVirtualTables(iclsPtr); if (initStr != NULL) { const char *val; - Tcl_DStringAppend(&buffer, "::", -1); - Tcl_DStringAppend(&buffer, Tcl_GetString(ivPtr->namePtr), -1); - val = Tcl_SetVar2(interp, - Tcl_DStringValue(&buffer), NULL, initStr, - TCL_NAMESPACE_ONLY); - + val = Tcl_SetVar2(interp, Tcl_GetString(ivPtr->fullNamePtr), NULL, + initStr, TCL_NAMESPACE_ONLY); if (!val) { Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "cannot initialize common variable \"", Tcl_GetString(ivPtr->namePtr), "\"", NULL); return TCL_ERROR; } + } else { + /* previous var-lookup in class body (in ::itcl::parser) could obtain + * inherited common vars, so be sure it does not exists after new + * common creation (simply remove this reference). */ + Tcl_UnsetVar2(interp, Tcl_GetString(ivPtr->fullNamePtr), NULL, + TCL_NAMESPACE_ONLY); } if (ivPtr->arrayInitPtr != NULL) { int i; int argc; const char **argv; const char *val; - Tcl_DStringAppend(&buffer, "::", -1); - Tcl_DStringAppend(&buffer, Tcl_GetString(ivPtr->namePtr), -1); result = Tcl_SplitList(interp, Tcl_GetString(ivPtr->arrayInitPtr), &argc, &argv); for (i = 0; i < argc; i++) { - val = Tcl_SetVar2(interp, Tcl_DStringValue(&buffer), argv[i], + val = Tcl_SetVar2(interp, Tcl_GetString(ivPtr->fullNamePtr), argv[i], argv[i + 1], TCL_NAMESPACE_ONLY); if (!val) { Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "cannot initialize common variable \"", Tcl_GetString(ivPtr->namePtr), "\"", @@ -4229,11 +4221,11 @@ if (Itcl_CreateVariable(interp, iclsPtr, namePtr, Tcl_GetString(defaultPtr), NULL, &ivPtr) != TCL_OK) { return TCL_ERROR; } iclsPtr->numVariables++; - result = Itcl_CreateMethodVariable(interp, iclsPtr, namePtr, defaultPtr, + result = ItclCreateMethodVariable(interp, ivPtr, defaultPtr, callbackPtr, &imvPtr); if (result != TCL_OK) { return result; } objPtr = Tcl_NewStringObj("@itcl-builtin-setget ", -1); Index: generic/itclResolve.c ================================================================== --- generic/itclResolve.c +++ generic/itclResolve.c @@ -274,11 +274,11 @@ iclsPtr = (ItclClass *)Tcl_GetHashValue(hPtr); /* * See if the variable is a known data member and accessible. */ - hPtr = Tcl_FindHashEntry(&iclsPtr->resolveVars, name); + hPtr = ItclResolveVarEntry(iclsPtr, name); if (hPtr == NULL) { return TCL_CONTINUE; } vlookup = (ItclVarLookup*)Tcl_GetHashValue(hPtr); @@ -312,11 +312,11 @@ if (hPtr == NULL) { return TCL_CONTINUE; } if (contextIoPtr->iclsPtr != vlookup->ivPtr->iclsPtr) { if (strcmp(Tcl_GetString(vlookup->ivPtr->namePtr), "this") == 0) { - hPtr = Tcl_FindHashEntry(&contextIoPtr->iclsPtr->resolveVars, + hPtr = ItclResolveVarEntry(contextIoPtr->iclsPtr, Tcl_GetString(vlookup->ivPtr->namePtr)); if (hPtr != NULL) { vlookup = (ItclVarLookup*)Tcl_GetHashValue(hPtr); } @@ -443,11 +443,11 @@ buffer = (char*)ckalloc((unsigned)(length+1)); } memcpy((void*)buffer, (void*)name, (size_t)length); buffer[length] = '\0'; - hPtr = Tcl_FindHashEntry(&iclsPtr->resolveVars, buffer); + hPtr = ItclResolveVarEntry(iclsPtr, buffer); if (buffer != storage) { ckfree(buffer); } @@ -526,11 +526,11 @@ if (contextIoPtr->iclsPtr != vlookup->ivPtr->iclsPtr) { if (strcmp(Tcl_GetString(vlookup->ivPtr->namePtr), "this") == 0) { /* only for the this variable we need the one of the * contextIoPtr class */ - hPtr = Tcl_FindHashEntry(&contextIoPtr->iclsPtr->resolveVars, + hPtr = ItclResolveVarEntry(contextIoPtr->iclsPtr, Tcl_GetString(vlookup->ivPtr->namePtr)); if (hPtr != NULL) { vlookup = (ItclVarLookup*)Tcl_GetHashValue(hPtr); } @@ -652,39 +652,34 @@ /* * See if the requested variable is a recognized "common" member. * If it is, make sure that access is allowed. */ - hPtr = Tcl_FindHashEntry(&iclsPtr->resolveVars, name); - if (hPtr) { - vlookup = (ItclVarLookup*)Tcl_GetHashValue(hPtr); - - if ((vlookup->ivPtr->flags & ITCL_COMMON) != 0) { - if (!vlookup->accessible) { - Tcl_AppendResult(interp, - "can't access \"", name, "\": ", - Itcl_ProtectionStr(vlookup->ivPtr->protection), - " variable", - NULL); - return TCL_ERROR; - } - hPtr = Tcl_FindHashEntry(&vlookup->ivPtr->iclsPtr->classCommons, - (char *)vlookup->ivPtr); - if (hPtr != NULL) { - *rPtr = (Tcl_Var)Tcl_GetHashValue(hPtr); - return TCL_OK; - } - } - } - - /* - * If the variable is not recognized, return TCL_CONTINUE and - * let lookup continue via the normal name resolution rules. - * This is important for variables like "errorInfo" - * that might get set while the parser namespace is active. - */ - return TCL_CONTINUE; + hPtr = ItclResolveVarEntry(iclsPtr, name); + if (!hPtr) { + return TCL_CONTINUE; + } + + vlookup = (ItclVarLookup*)Tcl_GetHashValue(hPtr); + + if ((vlookup->ivPtr->flags & ITCL_COMMON) == 0) { + return TCL_CONTINUE; + } + if (!vlookup->accessible) { + Tcl_AppendResult(interp, + "can't access \"", name, "\": ", + Itcl_ProtectionStr(vlookup->ivPtr->protection), + " variable", NULL); + return TCL_ERROR; + } + hPtr = Tcl_FindHashEntry(&vlookup->ivPtr->iclsPtr->classCommons, + (char *)vlookup->ivPtr); + if (!hPtr) { + return TCL_CONTINUE; + } + *rPtr = (Tcl_Var)Tcl_GetHashValue(hPtr); + return TCL_OK; } int Index: pkgIndex.tcl.in ================================================================== --- pkgIndex.tcl.in +++ pkgIndex.tcl.in @@ -1,6 +1,7 @@ # Tcl package index file, version 1.0 +if {![package vsatisfies [package provide Tcl] 8.5]} {return} if {![package vsatisfies [package provide Tcl] 8.6-]} {return} package ifneeded itcl @PACKAGE_VERSION@ [list load [file join $dir "@PKG_LIB_FILE@"] itcl] package ifneeded Itcl @PACKAGE_VERSION@ [list load [file join $dir "@PKG_LIB_FILE@"] itcl] ADDED tests-perf/itcl-basic.perf.tcl Index: tests-perf/itcl-basic.perf.tcl ================================================================== --- /dev/null +++ tests-perf/itcl-basic.perf.tcl @@ -0,0 +1,221 @@ +#!/usr/bin/tclsh + +# ------------------------------------------------------------------------ +# +# itcl-basic.perf.tcl -- +# +# This file provides performance tests for comparison of basic itcl-speed. +# +# ------------------------------------------------------------------------ +# +# Copyright (c) 2019 Serg G. Brester (aka sebres) +# +# See the file "license.terms" for information on usage and redistribution +# of this file. +# + + +if {![namespace exists ::tclTestPerf]} { + source [file join [file dirname [info library]] tests-perf test-performance.tcl] +} + +namespace eval ::itclTestPerf-Basic { + +namespace path {::tclTestPerf} + + +## test cases covering regression on class count (memory preserve/release): +proc test-cls-init {{reptime {3000 1000}}} { + set reptime [_adjust_maxcount $reptime 1000] + _test_run $reptime { + setup {set i 0; set k 0} + ## 1) create up-to 1000 classes (with 100 vars): + {itcl::class timeClass[incr i] { for {set j 0} {$j<100} {incr j} { public variable d$j } }} + ## 2) create up-to 1000 classes (with 100 vars): + {itcl::class finiClass[incr k] { for {set j 0} {$j<100} {incr j} { public variable d$j } }} + ## 2) delete up-to 1000 classes: + {itcl::delete class finiClass$k; if {[incr k -1] <= 0} break} + cleanup {while {$k > 0} {itcl::delete class finiClass$k; incr k -1}} + ## 1) delete up-to 1000 classes: + {itcl::delete class timeClass$i; if {[incr i -1] <= 0} break} + cleanup {while {$i > 0} {itcl::delete class timeClass$i; incr i -1}} + } +} + +## test cases covering run-time dependency to variable count of class with nested +## namespaces and class inheritances... +## original itcl-resolver (due to completely rebuild) has the complexity ca. O(nn**2,2**vn) here, +## so the deeper a class/inheritance and expecially the more variables it has, +## the worse the performance of class creation or modification. + +proc test-var-create {{reptime {3000 10000}}} { + upvar maxv maxv + foreach ns {{} ::test-itcl-ns1 ::test-itcl-ns1::test-itcl-ns2} { + incr n + if {$ns ne {}} { namespace eval $ns {} } + _test_start $reptime + foreach clsi {0 1 2} { + if {$clsi} { + set inh ${ns}::timeClass[expr {$clsi-1}] + } else { + set inh {} + } + set cls ${ns}::timeClass$clsi + puts "== ${n}.$clsi) class : $cls == [expr {$inh ne "" ? "inherite $inh" : ""}]" + if {[info command $cls] ne ""} { + itcl::delete class $cls + } + itcl::class $cls [string map [list \$reptime [list $reptime] \$in_inh [list $inh] \$clsi $clsi] { + set j 0 + set inh $in_inh + if {$inh ne ""} { + puts "% inherit $inh" + ::tclTestPerf::_test_iter 2 [timerate { + inherit $inh + } 1 1] + } + puts "% declare vars ..." + ::tclTestPerf::_test_iter 2 [timerate { + public variable pub[incr j] 0 + protected variable pro$j 1 + private variable pri$j 2 + # 10K commons is too slow in Itcl original edition (time grows on each iter), so 1K enough: + if {$j <= 1000} { + public common com$j "" + } + } {*}$reptime] + public method getv {vn} {set $vn} + public method getpub1 {} {set pro1} + public method getpro1 {} {set pro1} + public method getpri1 {} {set pri1} + public method getunknown {} {catch {set novarinthisclass}} + # Itcl original edition may be too slow (time grows on each inheritance), so save real max-iters (<= 10K): + uplevel [list set j $j] + }] + set maxv($clsi,$ns) $j + } + } + _test_out_total +} + +# access variable: +proc test-access {{reptime 1000}} { + upvar maxv maxv + _test_start $reptime + foreach ns {{} ::test-itcl-ns1 ::test-itcl-ns1::test-itcl-ns2} { + set reptm [_adjust_maxcount $reptime $maxv(0,$ns)] + incr n + set cls ${ns}::timeClass0 + puts "== ${n}) class : $cls ==" + set mp [list \ + \$cls $cls \$n $n \ + \$maxc0 [expr {min(1000,$maxv(0,$ns))}] + ] + _test_run $reptm [string map $mp { + # $n) obj-var resolve/get + setup {$cls o; set j 0} + {o getv pub[incr j]} + # $n) obj-var get (resolved) + setup {set j 0} + {o getv pub[incr j]} + # $n) obj-var resolved + setup {set j 0} + {o getv pub1} + # $n) obj-var in method compiled (public) + {o getpub1} + # $n) obj-var in method compiled (protected) + {o getpro1} + # $n) obj-var in method compiled (private) + {o getpri1} + # $n) obj-var in method unknown + {o getunknown} + cleanup {itcl::delete object o} + + # $n) obj-var resolve/cget + setup {$cls o; set j 0} + {o cget -pub[incr j]} + # $n) obj-var cget (resolved): + setup {set j 0} + {o cget -pub[incr j]} + + # $n) obj-var cfg/cget + {o configure -pub1} + {o cget -pub1} + + # $n) cls-com resolve + setup {set j 0} + {o getv com[incr j]; if {$j >= $maxc0} {set j 0}} + + # $n) cls-com resolved + {o getv com1} + cleanup {itcl::delete object o} + }] + } + _test_out_total +} + +# ------------------------------------------------------------------------ + +# create/delete object: +proc test-obj-instance {{reptime 1000}} { + _test_start $reptime + set n 0 + foreach ns {{} ::test-itcl-ns1 ::test-itcl-ns1::test-itcl-ns2} { + incr n + set cls ${ns}::timeClass0 + puts "== ${n}) class : $cls ==" + _test_run $reptime [string map [list \$cls $cls \$n $n] { + setup {set i 0} + # $n) create : + {$cls o[incr i]} + # $n) delete: + {itcl::delete object o$i; if {[incr i -1] <= 0} break} + cleanup {while {$i > 0} {itcl::delete object o$i; incr i -1}} + # $n) create + delete: + {$cls o; itcl::delete object o} + }] + } + _test_out_total +} + +# ------------------------------------------------------------------------ + +proc test {{reptime 1000}} { + set reptm $reptime + lset reptm 0 [expr {[lindex $reptm 0] * 10}] + if {[llength $reptm] == 1} { + lappend reptm 10000 + } + puts "==== initialization (preserve/release) ====\n" + test-cls-init $reptm + puts "==== class/var creation ====\n" + test-var-create $reptm + puts "==== var access ====\n" + test-access $reptime + puts "==== object instance ====\n" + test-obj-instance $reptime + + puts \n**OK** +} + +}; # end of ::tclTestPerf-Timer-Event + +# ------------------------------------------------------------------------ + +# if calling direct: +if {[info exists ::argv0] && [file tail $::argv0] eq [file tail [info script]]} { + array set in {-time 500 -lib {} -load {}} + array set in $argv + if {$in(-load) ne ""} { + eval $in(-load) + } + if {![namespace exists ::itcl]} { + if {$in(-lib) eq ""} { + set in(-lib) "itcl412" + } + puts "testing with $in(-lib)" + load $in(-lib) itcl + } + + ::itclTestPerf-Basic::test $in(-time) +} Index: tests/basic.test ================================================================== --- tests/basic.test +++ tests/basic.test @@ -536,10 +536,58 @@ test basic-6.8 {common variables can be redefined } -body { test_arrays0 do set undefined "scalar" } -result {scalar} + +proc testVarResolver {{access private} {init 0}} { + eval [string map [list \$access $access \$init $init] { + itcl::class A { + $access common cv "A::cv" + public proc cv {} {set cv} + } + itcl::class B { + inherit A + public common res {} + lappend res [info exists cv] + if {$init} { + $access common cv "" + } else { + $access common cv + } + lappend res [info exists cv] + lappend cv "B::cv-add" + public proc cv {} {set cv} + } + lappend B::res [A::cv] [B::cv] + set B::res + }] +} +test basic-7.1-a {variable lookup before a common creation (bug [777ae99cfb])} -body { + # private uninitialized var: + testVarResolver private 0 +} -result {0 0 A::cv B::cv-add} -cleanup { + itcl::delete class B A +} +test basic-7.1-b {variable lookup before a common creation (bug [777ae99cfb])} -body { + # public uninitialized var: + testVarResolver public 0 +} -result {1 0 A::cv B::cv-add} -cleanup { + itcl::delete class B A +} +test basic-7.2-a {variable lookup before a common creation (bug [777ae99cfb])} -body { + # private initialized var: + testVarResolver private 1 +} -result {0 1 A::cv B::cv-add} -cleanup { + itcl::delete class B A +} +test basic-7.2-b {variable lookup before a common creation (bug [777ae99cfb])} -body { + # public initialized var: + testVarResolver public 1 +} -result {1 1 A::cv B::cv-add} -cleanup { + itcl::delete class B A +} if {[namespace which test_arrays] ne {}} { ::itcl::delete class test_arrays } check_itcl_basic_errors Index: tests/info.test ================================================================== --- tests/info.test +++ tests/info.test @@ -72,11 +72,11 @@ info body procname info class info function ?name? ?-protection? ?-type? ?-name? ?-args? ?-body? info heritage info inherit - info variable ?name? ?-protection? ?-type? ?-name? ?-init? ?-value? ?-config? + info variable ?name? ?-protection? ?-type? ?-name? ?-init? ?-value? ?-config? ?-scope? ...and others described on the man page}} test info-1.3 {info: errors trigger usage info} { test_info ti list [catch {ti info} msg] $msg @@ -85,11 +85,11 @@ info body procname info class info function ?name? ?-protection? ?-type? ?-name? ?-args? ?-body? info heritage info inherit - info variable ?name? ?-protection? ?-type? ?-name? ?-init? ?-value? ?-config? + info variable ?name? ?-protection? ?-type? ?-name? ?-init? ?-value? ?-config? ?-scope? ...and others described on the man page}} test info-1.4 {info: info class works on class itself} { namespace eval test_info { info class } } {::test_info} @@ -103,42 +103,45 @@ test info-2.2a {info: public variables} { ti info variable pubv } {public variable ::test_info::pubv public {set pubv "public: $pubv"} new-public} -test info-2.2b {info: public variables} { +test info-2.2b {info: public variables} -body { list [ti info variable pubv -protection] \ [ti info variable pubv -type] \ [ti info variable pubv -name] \ [ti info variable pubv -init] \ [ti info variable pubv -config] \ [ti info variable pubv -value] \ -} {public variable ::test_info::pubv public {set pubv "public: $pubv"} new-public} + [ti info variable pubv -scope] \ +} -match glob -result {public variable ::test_info::pubv public {set pubv "public: $pubv"} new-public ::itcl::internal::variables::oo::Obj*::test_info::pubv} test info-2.3a {info: protected variables} { ti info variable prov } {protected variable ::test_info::prov protected new-protected} -test info-2.3b {info: protected variables} { +test info-2.3b {info: protected variables} -body { list [ti info variable prov -protection] \ [ti info variable prov -type] \ [ti info variable prov -name] \ [ti info variable prov -init] \ [ti info variable prov -value] \ -} {protected variable ::test_info::prov protected new-protected} + [ti info variable prov -scope] \ +} -match glob -result {protected variable ::test_info::prov protected new-protected ::itcl::internal::variables::oo::Obj*::test_info::prov} test info-2.4a {info: private variables} { ti info variable priv } {private variable ::test_info::priv private new-private} -test info-2.4b {info: private variables} { +test info-2.4b {info: private variables} -body { list [ti info variable priv -protection] \ [ti info variable priv -type] \ [ti info variable priv -name] \ [ti info variable priv -init] \ [ti info variable priv -value] \ -} {private variable ::test_info::priv private new-private} + [ti info variable priv -scope] \ +} -match glob -result {private variable ::test_info::priv private new-private ::itcl::internal::variables::oo::Obj*::test_info::priv} test info-2.5 {"this" variable is built in} { ti info variable this } {protected variable ::test_info::this ::ti ::ti} @@ -162,11 +165,12 @@ list [ti info variable pubc -protection] \ [ti info variable pubc -type] \ [ti info variable pubc -name] \ [ti info variable pubc -init] \ [ti info variable pubc -value] \ -} {public common ::test_info::pubc public new-public} + [ti info variable pubc -scope] \ +} {public common ::test_info::pubc public new-public ::test_info::pubc} test info-2.10a {info: protected common variables} { ti info variable proc } {protected common ::test_info::proc protected new-protected} @@ -174,11 +178,12 @@ list [ti info variable proc -protection] \ [ti info variable proc -type] \ [ti info variable proc -name] \ [ti info variable proc -init] \ [ti info variable proc -value] \ -} {protected common ::test_info::proc protected new-protected} + [ti info variable proc -scope] \ +} {protected common ::test_info::proc protected new-protected ::itcl::internal::variables::test_info::proc} test info-2.11a {info: private common variables} { ti info variable pric } {private common ::test_info::pric private new-private} @@ -186,11 +191,12 @@ list [ti info variable pric -protection] \ [ti info variable pric -type] \ [ti info variable pric -name] \ [ti info variable pric -init] \ [ti info variable pric -value] \ -} {private common ::test_info::pric private new-private} + [ti info variable pric -scope] \ +} {private common ::test_info::pric private new-private ::itcl::internal::variables::test_info::pric} test info-2.12 {info: public/protected/private vars have no "config" code} { list [ti info variable pubc -config] \ [ti info variable proc -config] \ [ti info variable pric -config] @@ -210,11 +216,11 @@ [namespace eval test_info {set uninitc(1)}] } {{0 1} zero one} test info-2.16 {flag syntax errors} { list [catch {ti info variable defv -xyzzy} msg] $msg -} {1 {bad option "-xyzzy": must be -config, -init, -name, -protection, -type, or -value}} +} {1 {bad option "-xyzzy": must be -config, -init, -name, -protection, -type, -value, or -scope}} # ---------------------------------------------------------------------- # Member functions # ---------------------------------------------------------------------- test info-3.1 {info: all functions} { Index: tests/typeinfo.test ================================================================== --- tests/typeinfo.test +++ tests/typeinfo.test @@ -50,11 +50,11 @@ info typemethod ?name? ?-protection? ?-type? ?-name? ?-args? ?-body? info typemethods ?pattern? info types ?pattern? info typevariable ?name? ?-protection? ?-type? ?-name? ?-init? ?-value? info typevars ?pattern? - info variable ?name? ?-protection? ?-type? ?-name? ?-init? ?-value? ?-config? + info variable ?name? ?-protection? ?-type? ?-name? ?-init? ?-value? ?-config? ?-scope? info variables ?pattern? ...and others described on the man page} test iinfo-1.3 {object info too many args} -body { type dog { } @@ -653,11 +653,11 @@ info typemethod ?name? ?-protection? ?-type? ?-name? ?-args? ?-body? info typemethods ?pattern? info types ?pattern? info typevariable ?name? ?-protection? ?-type? ?-name? ?-init? ?-value? info typevars ?pattern? - info variable ?name? ?-protection? ?-type? ?-name? ?-init? ?-value? ?-config? + info variable ?name? ?-protection? ?-type? ?-name? ?-init? ?-value? ?-config? ?-scope? info variables ?pattern? ...and others described on the man page} test tinfo-1.3 {type info too many args} -body { Index: win/makefile.vc ================================================================== --- win/makefile.vc +++ win/makefile.vc @@ -45,13 +45,13 @@ $(TMP_DIR)\dllEntryPoint.obj \ !endif PRJ_STUBOBJS = $(TMP_DIR)\itclStubLib.obj -PRJ_DEFINES = -D_CRT_SECURE_NO_WARNINGS +PRJ_DEFINES = /D_CRT_SECURE_NO_WARNINGS !if $(DEBUG) -PRJ_DEFINES = $(PRJ_DEFINES) -DITCL_DEBUG +PRJ_DEFINES = $(PRJ_DEFINES) /DITCL_DEBUG !endif PRJ_HEADERS_PUBLIC = \ $(GENERICDIR)\itcl.h \ $(GENERICDIR)\itclDecls.h Index: win/rules.vc ================================================================== --- win/rules.vc +++ win/rules.vc @@ -1275,73 +1275,73 @@ # conlflags - complete linker switches for console program (subsumes lflags) # guilflags - complete linker switches for GUI program (subsumes lflags) # baselibs - minimum Windows libraries required. Parent makefile can # define PRJ_LIBS before including rules.rc if additional libs are needed -OPTDEFINES = -DTCL_CFGVAL_ENCODING=$(CFG_ENCODING) -DSTDC_HEADERS +OPTDEFINES = /DTCL_CFGVAL_ENCODING=$(CFG_ENCODING) /DSTDC_HEADERS !if $(TCL_MEM_DEBUG) -OPTDEFINES = $(OPTDEFINES) -DTCL_MEM_DEBUG +OPTDEFINES = $(OPTDEFINES) /DTCL_MEM_DEBUG !endif !if $(TCL_COMPILE_DEBUG) -OPTDEFINES = $(OPTDEFINES) -DTCL_COMPILE_DEBUG -DTCL_COMPILE_STATS +OPTDEFINES = $(OPTDEFINES) /DTCL_COMPILE_DEBUG /DTCL_COMPILE_STATS !endif !if $(TCL_THREADS) && $(TCL_VERSION) < 87 -OPTDEFINES = $(OPTDEFINES) -DTCL_THREADS=1 +OPTDEFINES = $(OPTDEFINES) /DTCL_THREADS=1 !if $(USE_THREAD_ALLOC) && $(TCL_VERSION) < 87 -OPTDEFINES = $(OPTDEFINES) -DUSE_THREAD_ALLOC=1 +OPTDEFINES = $(OPTDEFINES) /DUSE_THREAD_ALLOC=1 !endif !endif !if $(STATIC_BUILD) -OPTDEFINES = $(OPTDEFINES) -DSTATIC_BUILD +OPTDEFINES = $(OPTDEFINES) /DSTATIC_BUILD !endif !if $(TCL_NO_DEPRECATED) -OPTDEFINES = $(OPTDEFINES) -DTCL_NO_DEPRECATED +OPTDEFINES = $(OPTDEFINES) /DTCL_NO_DEPRECATED !endif !if $(USE_STUBS) # Note we do not define USE_TCL_STUBS even when building tk since some # test targets in tk do not use stubs !if ! $(DOING_TCL) -USE_STUBS_DEFS = -DUSE_TCL_STUBS -DUSE_TCLOO_STUBS +USE_STUBS_DEFS = /DUSE_TCL_STUBS /DUSE_TCLOO_STUBS !if $(NEED_TK) -USE_STUBS_DEFS = $(USE_STUBS_DEFS) -DUSE_TK_STUBS +USE_STUBS_DEFS = $(USE_STUBS_DEFS) /DUSE_TK_STUBS !endif !endif !endif # USE_STUBS !if !$(DEBUG) -OPTDEFINES = $(OPTDEFINES) -DNDEBUG +OPTDEFINES = $(OPTDEFINES) /DNDEBUG !if $(OPTIMIZING) -OPTDEFINES = $(OPTDEFINES) -DTCL_CFG_OPTIMIZED +OPTDEFINES = $(OPTDEFINES) /DTCL_CFG_OPTIMIZED !endif !endif !if $(PROFILE) -OPTDEFINES = $(OPTDEFINES) -DTCL_CFG_PROFILED +OPTDEFINES = $(OPTDEFINES) /DTCL_CFG_PROFILED !endif !if "$(MACHINE)" == "AMD64" -OPTDEFINES = $(OPTDEFINES) -DTCL_CFG_DO64BIT +OPTDEFINES = $(OPTDEFINES) /DTCL_CFG_DO64BIT !endif !if $(VCVERSION) < 1300 -OPTDEFINES = $(OPTDEFINES) -DNO_STRTOI64 +OPTDEFINES = $(OPTDEFINES) /DNO_STRTOI64 !endif !if "$(_USE_64BIT_TIME_T)" == "1" -OPTDEFINES = $(OPTDEFINES) -D_USE_64BIT_TIME_T +OPTDEFINES = $(OPTDEFINES) /D_USE_64BIT_TIME_T !endif # _ATL_XP_TARGETING - Newer SDK's need this to build for XP COMPILERFLAGS = /D_ATL_XP_TARGETING # Like the TEA system only set this non empty for non-Tk extensions # Note: some extensions use PACKAGE_NAME and others use PACKAGE_TCLNAME # so we pass both !if !$(DOING_TCL) && !$(DOING_TK) -PKGNAMEFLAGS = -DPACKAGE_NAME="\"$(PRJ_PACKAGE_TCLNAME)\"" \ - -DPACKAGE_TCLNAME="\"$(PRJ_PACKAGE_TCLNAME)\"" \ - -DPACKAGE_VERSION="\"$(DOTVERSION)\"" \ - -DMODULE_SCOPE=extern +PKGNAMEFLAGS = /DPACKAGE_NAME="\"$(PRJ_PACKAGE_TCLNAME)\"" \ + /DPACKAGE_TCLNAME="\"$(PRJ_PACKAGE_TCLNAME)\"" \ + /DPACKAGE_VERSION="\"$(DOTVERSION)\"" \ + /DMODULE_SCOPE=extern !endif # crt picks the C run time based on selected OPTS !if $(MSVCRT) !if $(DEBUG) && !$(UNCHECKED) @@ -1384,11 +1384,11 @@ cwarn = $(cwarn) -wd4311 -wd4312 !endif ### Common compiler options that are architecture specific !if "$(MACHINE)" == "ARM" -carch = -D_ARM_WINAPI_PARTITION_DESKTOP_SDK_AVAILABLE +carch = /D_ARM_WINAPI_PARTITION_DESKTOP_SDK_AVAILABLE !else carch = !endif !if $(DEBUG) @@ -1414,25 +1414,25 @@ # BUILD_$(PROJECT) macro which should be defined only for the shared # library *implementation* and not for its caller interface appcflags_nostubs = $(cflags) $(crt) $(INCLUDES) $(TCL_DEFINES) $(PRJ_DEFINES) $(OPTDEFINES) appcflags = $(appcflags_nostubs) $(USE_STUBS_DEFS) -pkgcflags = $(appcflags) $(PKGNAMEFLAGS) -DBUILD_$(PROJECT) -pkgcflags_nostubs = $(appcflags_nostubs) $(PKGNAMEFLAGS) -DBUILD_$(PROJECT) +pkgcflags = $(appcflags) $(PKGNAMEFLAGS) /DBUILD_$(PROJECT) +pkgcflags_nostubs = $(appcflags_nostubs) $(PKGNAMEFLAGS) /DBUILD_$(PROJECT) # stubscflags contains $(cflags) plus flags used for building a stubs -# library for the package. Note: -DSTATIC_BUILD is defined in +# library for the package. Note: /DSTATIC_BUILD is defined in # $(OPTDEFINES) only if the OPTS configuration indicates a static # library. However the stubs library is ALWAYS static hence included # here irrespective of the OPTS setting. # # TBD - tclvfs has a comment that stubs libs should not be compiled with -GL # without stating why. Tcl itself compiled stubs libs with this flag. # so we do not remove it from cflags. -GL may prevent extensions # compiled with one VC version to fail to link against stubs library # compiled with another VC version. Check for this and fix accordingly. -stubscflags = $(cflags) $(PKGNAMEFLAGS) $(PRJ_DEFINES) $(OPTDEFINES) -Zl -DSTATIC_BUILD $(INCLUDES) $(USE_STUBS_DEFS) +stubscflags = $(cflags) $(PKGNAMEFLAGS) $(PRJ_DEFINES) $(OPTDEFINES) -Zl /DSTATIC_BUILD $(INCLUDES) $(USE_STUBS_DEFS) # Link flags !if $(DEBUG) ldebug = -debug -debugtype:cv @@ -1505,17 +1505,17 @@ CONEXECMD = $(link32) $(conlflags) -out:$@ $(baselibs) $(tcllibs) $(tklibs) GUIEXECMD = $(link32) $(guilflags) -out:$@ $(baselibs) $(tcllibs) $(tklibs) RESCMD = $(rc32) -fo $@ -r -i "$(GENERICDIR)" -i "$(TMP_DIR)" \ $(TCL_INCLUDES) \ - -DDEBUG=$(DEBUG) -d UNCHECKED=$(UNCHECKED) \ - -DCOMMAVERSION=$(DOTVERSION:.=,),0 \ - -DDOTVERSION=\"$(DOTVERSION)\" \ - -DVERSION=\"$(VERSION)\" \ - -DSUFX=\"$(SUFX)\" \ - -DPROJECT=\"$(PROJECT)\" \ - -DPRJLIBNAME=\"$(PRJLIBNAME)\" + /DDEBUG=$(DEBUG) -d UNCHECKED=$(UNCHECKED) \ + /DCOMMAVERSION=$(DOTVERSION:.=,),0 \ + /DDOTVERSION=\"$(DOTVERSION)\" \ + /DVERSION=\"$(VERSION)\" \ + /DSUFX=\"$(SUFX)\" \ + /DPROJECT=\"$(PROJECT)\" \ + /DPRJLIBNAME=\"$(PRJLIBNAME)\" !ifndef DEFAULT_BUILD_TARGET DEFAULT_BUILD_TARGET = $(PROJECT) !endif