Posted to tcl by apw at Mon Jul 23 10:09:50 GMT 2007view raw
- ndex: tclOOInt.h
- ===================================================================
- RCS file: /cvsroot/tcl/oocore/generic/tclOOInt.h,v
- retrieving revision 1.8
- diff -b -u -r1.8 tclOOInt.h
- --- tclOOInt.h 25 Jun 2007 14:20:20 -0000 1.8
- +++ tclOOInt.h 23 Jul 2007 09:55:36 -0000
- @@ -131,6 +131,12 @@
- Tcl_Obj *cachedNameObj; /* Cache of the name of the object. */
- Tcl_HashTable publicContextCache; /* Place to keep unused contexts. */
- Tcl_HashTable privateContextCache; /* Place to keep unused contexts. */
- +#ifdef ARNULF_FOR_ITCL_CODE
- + Tcl_Resolve *resolvePtr;
- + /* Points to a struct for resolving commands
- + * and variables
- + */
- +#endif
- } Object;
- #define OBJECT_DELETED 1 /* Flag to say that an object has been
- @@ -378,7 +384,7 @@
- CallContext *contextPtr);
- MODULE_SCOPE CallContext *TclOOGetCallContext(Foundation *fPtr, Object *oPtr,
- Tcl_Obj *methodNameObj, int flags,
- - Tcl_HashTable *cachePtr);
- + Tcl_HashTable *cachePtr, Class *clsPtr);
- MODULE_SCOPE int TclOOInvokeContext(Tcl_Interp *interp,
- CallContext *contextPtr, int objc,
- Tcl_Obj *const *objv);
- Index: tclOO.c
- ===================================================================
- RCS file: /cvsroot/tcl/oocore/generic/tclOO.c,v
- retrieving revision 1.20
- diff -b -u -r1.20 tclOO.c
- --- tclOO.c 16 Jun 2007 14:53:08 -0000 1.20
- +++ tclOO.c 23 Jul 2007 09:55:50 -0000
- @@ -397,6 +397,9 @@
- oPtr->flags = 0;
- oPtr->creationEpoch = creationEpoch;
- oPtr->metadataPtr = NULL;
- +#ifdef ARNULF_FOR_ITCL_CODE
- + oPtr->resolvePtr = NULL;
- +#endif
- /*
- * Initialize the traces.
- @@ -479,7 +482,7 @@
- if (!Tcl_InterpDeleted(interp)) {
- CallContext *contextPtr =
- TclOOGetCallContext(TclOOGetFoundation(interp), oPtr, NULL,
- - DESTRUCTOR, NULL);
- + DESTRUCTOR, NULL, NULL);
- if (contextPtr != NULL) {
- int result;
- @@ -717,6 +720,11 @@
- ckfree((char *) oPtr->metadataPtr);
- oPtr->metadataPtr = NULL;
- }
- +#ifdef ARNULF_FOR_ITCL_CODE
- + if (oPtr->resolvePtr != NULL) {
- + ckfree((char *) oPtr->resolvePtr);
- + }
- +#endif
- if (clsPtr != NULL && !(oPtr->flags & ROOT_OBJECT)) {
- Class *superPtr, *mixinPtr;
- @@ -1162,7 +1170,7 @@
- if (objc >= 0) {
- contextPtr = TclOOGetCallContext(TclOOGetFoundation(interp), oPtr,
- - NULL, CONSTRUCTOR, NULL);
- + NULL, CONSTRUCTOR, NULL, NULL);
- if (contextPtr != NULL) {
- int result;
- Tcl_InterpState state;
- @@ -1675,6 +1683,7 @@
- int objc,
- Tcl_Obj *const *objv)
- {
- +
- return ObjectCmd(clientData, interp, objc, objv, PUBLIC_METHOD,
- &((Object *)clientData)->publicContextCache);
- }
- @@ -1690,6 +1699,7 @@
- &((Object *)clientData)->privateContextCache);
- }
- +void InitClassHierarchy(Foundation *fPtr, Class *classPtr);
- static int
- ObjectCmd(
- Object *oPtr, /* The object being invoked. */
- @@ -1701,6 +1711,13 @@
- Tcl_HashTable *cachePtr) /* What call chain cache to use. */
- {
- CallContext *contextPtr;
- + Class *clsPtr;
- + Class *superPtr;
- + Tcl_Obj *objName;
- + char *sp;
- + char *cp;
- + Tcl_Obj *className;
- + int i;
- int result;
- if (objc < 2) {
- @@ -1708,8 +1725,34 @@
- return TCL_ERROR;
- }
- + clsPtr = NULL;
- + objName = NULL;
- + className = NULL;
- + if (objv[1] != NULL) {
- + sp = Tcl_GetString(objv[1]);
- + cp = strstr(sp, "::");
- + if (cp != NULL) {
- + objName = Tcl_NewStringObj(cp+2, -1);
- + InitClassHierarchy(TclOOGetFoundation(interp), oPtr->selfCls);
- + className = Tcl_NewStringObj(sp, cp-sp);
- + Tcl_IncrRefCount(className);
- + sp = Tcl_GetString(className);
- + if (strcmp(oPtr->selfCls->thisPtr->namespacePtr->name, sp) != 0) {
- + FOREACH(superPtr, oPtr->selfCls->superclasses) {
- + if (strcmp(superPtr->thisPtr->namespacePtr->name, sp) == 0) {
- + clsPtr = superPtr;
- + break;
- + }
- +
- + }
- + } else {
- + clsPtr = oPtr->selfCls;
- + }
- + Tcl_DecrRefCount(className);
- + }
- + }
- contextPtr = TclOOGetCallContext(TclOOGetFoundation(interp), oPtr,
- - objv[1], flags | (oPtr->flags & FILTER_HANDLING), cachePtr);
- + objName == NULL ? objv[1] : objName, flags | (oPtr->flags & FILTER_HANDLING), cachePtr, clsPtr);
- if (contextPtr == NULL) {
- Tcl_AppendResult(interp, "impossible to invoke method \"",
- TclGetString(objv[1]),
- Index: tclOOMethod.c
- ===================================================================
- RCS file: /cvsroot/tcl/oocore/generic/tclOOMethod.c,v
- retrieving revision 1.4
- diff -b -u -r1.4 tclOOMethod.c
- --- tclOOMethod.c 25 Jun 2007 14:20:21 -0000 1.4
- +++ tclOOMethod.c 23 Jul 2007 09:55:57 -0000
- @@ -583,6 +583,9 @@
- if (pmPtr->flags & USE_DECLARER_NS) {
- register Method *mPtr = contextPtr->callChain[contextPtr->index].mPtr;
- +#ifdef ARNULF_FOR_ITCL_CODE
- + flags |= FRAME_HAS_RESOLVER;
- +#endif
- if (mPtr->declaringClassPtr != NULL) {
- nsPtr = mPtr->declaringClassPtr->thisPtr->namespacePtr;
- } else {
- @@ -615,6 +618,40 @@
- framePtr->objv = objv; /* ref counts for args are incremented below */
- framePtr->procPtr = pmPtr->procPtr;
- +#ifdef ARNULF_FOR_ITCL_CODE
- + if (flags & FRAME_HAS_RESOLVER) {
- + Tcl_DString buffer;
- + Tcl_Resolve *resolvePtr;
- + Tcl_Namespace *varNsPtr;
- +
- + if (flags & FRAME_IS_CONSTRUCTOR) {
- + Tcl_DStringInit(&buffer);
- + Tcl_DStringAppend(&buffer, "::itcl::variables::", -1);
- + Tcl_DStringAppend(&buffer,
- + Tcl_GetCommandName(interp, oPtr->command), -1);
- + varNsPtr = Tcl_FindNamespace(interp, Tcl_DStringValue(&buffer),
- + NULL, 0);
- +//fprintf(stderr, "CONVNS3!%s!%p\n", Tcl_DStringValue(&buffer), varNsPtr);
- + if (varNsPtr != NULL) {
- + SetVarResolver((Tcl_Object)oPtr, varNsPtr);
- + }
- + Tcl_DStringFree(&buffer);
- + }
- + resolvePtr = oPtr->resolvePtr;
- + if ((resolvePtr != NULL) &&
- + (oPtr->resolvePtr->objectVarNsPtr != NULL)) {
- + Tcl_DStringInit(&buffer);
- + Tcl_DStringAppend(&buffer,
- + oPtr->resolvePtr->objectVarNsPtr->fullName, -1);
- + Tcl_DStringAppend(&buffer, nsPtr->fullName, -1);
- + oPtr->resolvePtr->varNsPtr = Tcl_FindNamespace(interp,
- + Tcl_DStringValue(&buffer), NULL, 0);
- +//fprintf(stderr, "FN!%s!%p\n", Tcl_DStringValue(&buffer), oPtr->resolvePtr->varNsPtr);
- + Tcl_DStringFree(&buffer);
- + }
- + framePtr->resolvePtr = oPtr->resolvePtr;
- + }
- +#endif
- /*
- * Finish filling out the extra frame info.
- */
- @@ -1148,6 +1185,22 @@
- return (((Method *)method)->flags & PUBLIC_METHOD) ? 1 : 0;
- }
- +#ifdef ARNULF_FOR_ITCL_CODE
- +void
- +SetVarResolver(
- + Tcl_Object oPtr,
- + Tcl_Namespace *nsPtr)
- +{
- + if (oPtr != NULL) {
- + Tcl_Resolve *resolvePtr;
- + resolvePtr = (Tcl_Resolve *) ckalloc(sizeof(Tcl_Resolve));
- + resolvePtr->objectVarNsPtr = nsPtr;
- + resolvePtr->varNsPtr = NULL;
- + ((Object*)oPtr)->resolvePtr = resolvePtr;
- + }
- +}
- +#endif
- +
- /*
- * Local Variables:
- * mode: c
- Index: tclOODefineCmds.c
- ===================================================================
- RCS file: /cvsroot/tcl/oocore/generic/tclOODefineCmds.c,v
- retrieving revision 1.1
- diff -b -u -r1.1 tclOODefineCmds.c
- --- tclOODefineCmds.c 18 May 2007 13:17:15 -0000 1.1
- +++ tclOODefineCmds.c 23 Jul 2007 09:56:06 -0000
- @@ -154,12 +154,16 @@
- Object *oPtr;
- Class *clsPtr;
- int bodyLength;
- + int use_declarer_ns_flag = 0;
- - if (objc != 3) {
- + if ((objc != 3) && (objc != 4)) {
- Tcl_WrongNumArgs(interp, 1, objv, "arguments body");
- return TCL_ERROR;
- }
- + if (objc > 3) {
- + use_declarer_ns_flag = USE_DECLARER_NS;
- + }
- /*
- * Extract and validate the context, which is the class that we wish to
- * modify.
- @@ -184,7 +188,7 @@
- Method *mPtr;
- - mPtr = TclOONewProcClassMethod(interp, clsPtr, PUBLIC_METHOD, NULL,
- + mPtr = TclOONewProcClassMethod(interp, clsPtr, PUBLIC_METHOD|use_declarer_ns_flag, NULL,
- objv[1], objv[2]);
- if (mPtr == NULL) {
- return TCL_ERROR;
- @@ -221,12 +225,16 @@
- Object *oPtr;
- Class *clsPtr;
- int bodyLength;
- + int use_declarer_ns_flag = 0;
- - if (objc != 2) {
- + if ((objc != 2) && (objc != 3)) {
- Tcl_WrongNumArgs(interp, 1, objv, "body");
- return TCL_ERROR;
- }
- + if (objc > 2) {
- + use_declarer_ns_flag = USE_DECLARER_NS;
- + }
- oPtr = (Object *) TclOOGetDefineCmdContext(interp);
- if (oPtr == NULL) {
- return TCL_ERROR;
- @@ -246,7 +254,7 @@
- Method *mPtr;
- - mPtr = TclOONewProcClassMethod(interp, clsPtr, PUBLIC_METHOD, NULL,
- + mPtr = TclOONewProcClassMethod(interp, clsPtr, PUBLIC_METHOD|use_declarer_ns_flag, NULL,
- NULL, objv[1]);
- if (mPtr == NULL) {
- return TCL_ERROR;
- @@ -482,12 +490,16 @@
- int isSelfMethod = (clientData != NULL);
- Object *oPtr;
- int bodyLength;
- + int use_declarer_ns_flag = 0;
- - if (objc != 4) {
- - Tcl_WrongNumArgs(interp, 1, objv, "name args body");
- + if (objc != 4 && objc != 5) {
- + Tcl_WrongNumArgs(interp, 1, objv, "name args body ?flag?");
- return TCL_ERROR;
- }
- + if (objc > 4) {
- + use_declarer_ns_flag = USE_DECLARER_NS;
- + }
- oPtr = (Object *) TclOOGetDefineCmdContext(interp);
- if (oPtr == NULL) {
- return TCL_ERROR;
- @@ -504,6 +516,7 @@
- int isPublic = Tcl_StringMatch(TclGetString(objv[1]), "[a-z]*")
- ? PUBLIC_METHOD : 0;
- +isPublic |= use_declarer_ns_flag;
- if (isSelfMethod) {
- mPtr = TclOONewProcMethod(interp, oPtr, isPublic, objv[1],
- objv[2], objv[3]);
- Index: tclOOCall.c
- ===================================================================
- RCS file: /cvsroot/tcl/oocore/generic/tclOOCall.c,v
- retrieving revision 1.2
- diff -b -u -r1.2 tclOOCall.c
- --- tclOOCall.c 15 Jun 2007 14:26:03 -0000 1.2
- +++ tclOOCall.c 23 Jul 2007 09:56:11 -0000
- @@ -51,13 +51,13 @@
- static void AddSimpleChainToCallContext(Object *oPtr,
- Tcl_Obj *methodNameObj, struct ChainBuilder *cbPtr,
- Tcl_HashTable *doneFilters, int isPublic,
- - Class *filterDecl);
- + Class *filterDecl, Class *clsPtr);
- static void AddSimpleClassChainToCallContext(Class *classPtr,
- Tcl_Obj *methodNameObj, struct ChainBuilder *cbPtr,
- Tcl_HashTable *doneFilters, int isPublic,
- Class *filterDecl);
- static int CmpStr(const void *ptr1, const void *ptr2);
- -static void InitClassHierarchy(Foundation *fPtr, Class *classPtr);
- +void InitClassHierarchy(Foundation *fPtr, Class *classPtr);
- static void DupMethodNameRep(Tcl_Obj *srcPtr, Tcl_Obj *dstPtr);
- static void FreeMethodNameRep(Tcl_Obj *objPtr);
- @@ -244,7 +244,7 @@
- * ----------------------------------------------------------------------
- */
- -static void
- +void
- InitClassHierarchy(
- Foundation *fPtr,
- Class *classPtr)
- @@ -532,8 +532,9 @@
- * Only the bits PUBLIC_METHOD, CONSTRUCTOR,
- * PRIVATE_METHOD, DESTRUCTOR and
- * FILTER_HANDLING are useful. */
- - Tcl_HashTable *cachePtr) /* Where to cache the chain. Ignored for both
- + Tcl_HashTable *cachePtr, /* Where to cache the chain. Ignored for both
- * constructors and destructors. */
- + Class *clsPtr) /* class if direct call with classname in front */
- {
- struct ChainBuilder cb;
- int i, count, doFilters;
- @@ -608,7 +609,7 @@
- }
- FOREACH(filterObj, oPtr->filters) {
- AddSimpleChainToCallContext(oPtr, filterObj, &cb, &doneFilters, 0,
- - NULL);
- + NULL, NULL);
- }
- AddClassFiltersToCallContext(oPtr, oPtr->selfCls, &cb, &doneFilters);
- Tcl_DeleteHashTable(&doneFilters);
- @@ -619,7 +620,7 @@
- * Add the actual method implementations.
- */
- - AddSimpleChainToCallContext(oPtr, methodNameObj, &cb, NULL, flags, NULL);
- + AddSimpleChainToCallContext(oPtr, methodNameObj, &cb, NULL, flags, NULL, clsPtr);
- /*
- * Check to see if the method has no implementation. If so, we probably
- @@ -638,7 +639,7 @@
- return NULL;
- }
- AddSimpleChainToCallContext(oPtr, fPtr->unknownMethodNameObj, &cb,
- - NULL, 0, NULL);
- + NULL, 0, NULL, NULL);
- cb.contextPtr->flags |= OO_UNKNOWN_METHOD;
- cb.contextPtr->globalEpoch = -1;
- if (count == cb.contextPtr->numCallChain) {
- @@ -697,7 +698,7 @@
- (void) Tcl_CreateHashEntry(doneFilters, (char *) filterObj, &isNew);
- if (isNew) {
- AddSimpleChainToCallContext(oPtr, filterObj, cbPtr, doneFilters,
- - 0, clsPtr);
- + 0, clsPtr, NULL);
- }
- }
- @@ -740,9 +741,10 @@
- Tcl_HashTable *doneFilters, /* Where to record what call chain entries
- * have been processed. */
- int flags, /* What sort of call chain are we building. */
- - Class *filterDecl) /* The class that declared the filter. If
- + Class *filterDecl, /* The class that declared the filter. If
- * NULL, either the filter was declared by the
- * object or this isn't a filter. */
- + Class *clsPtr) /* class for direct call */
- {
- int i;
- @@ -776,7 +778,7 @@
- AddSimpleClassChainToCallContext(mixinPtr, methodNameObj, cbPtr,
- doneFilters, flags, filterDecl);
- }
- - FOREACH(superPtr, oPtr->selfCls->classHierarchy) {
- + FOREACH(superPtr, clsPtr == NULL ? oPtr->selfCls->classHierarchy : clsPtr->classHierarchy) {
- int j=i; /* HACK: save index so can nest FOREACHes. */
- FOREACH(mixinPtr, superPtr->mixins) {
- AddSimpleClassChainToCallContext(mixinPtr, methodNameObj,
- @@ -790,8 +792,8 @@
- filterDecl);
- }
- }
- - AddSimpleClassChainToCallContext(oPtr->selfCls, methodNameObj, cbPtr,
- - doneFilters, flags, filterDecl);
- + AddSimpleClassChainToCallContext(clsPtr == NULL ? oPtr->selfCls : clsPtr,
- + methodNameObj, cbPtr, doneFilters, flags, filterDecl);
- }
- /*