Index: ChangeLog =================================================================== diff -u -r072e1c7c091c1370fc2fe26f66acf7a7cbd4a66f -r91e9b1a3b1c3e60a8538156b4aa37d5a664d5133 --- ChangeLog (.../ChangeLog) (revision 072e1c7c091c1370fc2fe26f66acf7a7cbd4a66f) +++ ChangeLog (.../ChangeLog) (revision 91e9b1a3b1c3e60a8538156b4aa37d5a664d5133) @@ -63,6 +63,27 @@ C c1 ;# c1 has no no default value for "a", before it had ====== +2009-06-25 + - new command: + + ::xotcl::createobjectsystem + + This command creates a basic object system with the specified + as most general root class and the specified + metaclass as most general meta class. + + Example: + ::xotcl::createobjectsystem ::oo::object ::oo::class + + In general, it would be possible to remove an objects system at + runtime, but there is so far no tcl interface for this. + + - extended framework to work with multiple root classes + + - the basic root class of XOTcl is now ::xotcl::Object again + (instead of ::oo::object) as before. The old setup can be + achieved on the Tcl-layer. + 2009-06-22 - define default meta-class for ::xotcl::Class - use default meta-class, when a the topmost meta-class of an Index: generic/predefined.h =================================================================== diff -u -rfd82d80829200a3928e29cdfc0d19df6222a9267 -r91e9b1a3b1c3e60a8538156b4aa37d5a664d5133 --- generic/predefined.h (.../predefined.h) (revision fd82d80829200a3928e29cdfc0d19df6222a9267) +++ generic/predefined.h (.../predefined.h) (revision 91e9b1a3b1c3e60a8538156b4aa37d5a664d5133) @@ -4,20 +4,12 @@ "proc ::xotcl::setrelation args {\n" "puts stderr \"::xotcl::setrelation is deprecated, use '::xotcl::relation $args' instead\"\n" "uplevel ::xotcl::relation $args}\n" +"namespace eval ::oo {}\n" +"::xotcl::createobjectsystem ::oo::object ::oo::class\n" "if {[info command ::oo::object] ne \"\"} {\n" "::xotcl::alias ::oo::object destroy ::xotcl::cmd::Object::destroy\n" "::xotcl::alias ::oo::class instdestroy ::xotcl::cmd::Class::instdestroy\n" -"::xotcl::alias ::oo::class alloc ::xotcl::cmd::Class::alloc\n" -"::oo::class alloc ::xotcl::Object\n" -"::oo::class alloc ::xotcl::Class\n" -"::xotcl::relation ::xotcl::Class superclass ::xotcl::Object\n" -"::xotcl::relation ::xotcl::Class metaclass\n" -"puts \"Now class should be a metaclass\"\n" -"foreach o {::xotcl::Class} {\n" -"foreach r {object class metaclass} {\n" -"puts stderr \"$o $r=[::xotcl::is $o $r]\"}}\n" -"::xotcl::relation ::xotcl::Object class ::xotcl::Class\n" -"::xotcl::relation ::xotcl::Class class ::xotcl::Class}\n" +"::xotcl::createobjectsystem ::xotcl::Object ::xotcl::Class}\n" "set bootstrap 1\n" "foreach cmd [info command ::xotcl::cmd::Object::*] {\n" "::xotcl::alias ::xotcl::Object [namespace tail $cmd] $cmd}\n" Index: generic/predefined.xotcl =================================================================== diff -u -rfd82d80829200a3928e29cdfc0d19df6222a9267 -r91e9b1a3b1c3e60a8538156b4aa37d5a664d5133 --- generic/predefined.xotcl (.../predefined.xotcl) (revision fd82d80829200a3928e29cdfc0d19df6222a9267) +++ generic/predefined.xotcl (.../predefined.xotcl) (revision 91e9b1a3b1c3e60a8538156b4aa37d5a664d5133) @@ -4,6 +4,11 @@ puts stderr "::xotcl::setrelation is deprecated, use '::xotcl::relation $args' instead" uplevel ::xotcl::relation $args } + + # first we create the ::oo:: object system. Actually, we do not need it. + namespace eval ::oo {} + ::xotcl::createobjectsystem ::oo::object ::oo::class + if {[info command ::oo::object] ne ""} { # When the system shuts down, destroy is called for every # available object. When ::xotcl::Object and ::xotcl::Class are @@ -14,38 +19,42 @@ # ::xotcl::alias ::oo::object destroy ::xotcl::cmd::Object::destroy ::xotcl::alias ::oo::class instdestroy ::xotcl::cmd::Class::instdestroy + # - # Perform the basic setup of XOTcl. First, let us allocate objects - # and classed via the method named "alloc". + # Perform the basic setup of XOTcl. First, let us allocate the + # basic classes of XOTcl. This call creates the classes + # ::xotcl::Object and ::xotcl::Class and defines these as root + # class of the object system and as root meta class. # - ::xotcl::alias ::oo::class alloc ::xotcl::cmd::Class::alloc + ::xotcl::createobjectsystem ::xotcl::Object ::xotcl::Class + +# foreach o {::xotcl::Object ::xotcl::Class} { +# foreach r {object class metaclass} { +# puts stderr "$o $r=[::xotcl::is $o $r]" +# } +# } + # - # Create the basic Classes of XOTcl ... + # createobjectsystem creates already the relation that Class has Object as + # superclass. We could define this here as well. # - ::oo::class alloc ::xotcl::Object - ::oo::class alloc ::xotcl::Class - #foreach o {::xotcl::Object ::xotcl::Class} { - # foreach r {object class metaclass} { -# puts stderr "$o $r=[::xotcl::is $o $r]" -# } -# } +# puts stderr sc(class)=[::xotcl::relation ::xotcl::Class superclass] +# ::xotcl::relation ::xotcl::Class superclass ::xotcl::Object + # - # ... and define the superclass and class relations on these. + # createobjectsystem creates already the relation that Object and + # Class are instances of Class. We could define this here as well. # - ::xotcl::relation ::xotcl::Class superclass ::xotcl::Object - ::xotcl::relation ::xotcl::Class metaclass - - # puts "Now class should be a metaclass" - # foreach o {::xotcl::Class} { - # foreach r {object class metaclass} { -# puts stderr "$o $r=[::xotcl::is $o $r]" - # } - #} - ::xotcl::relation ::xotcl::Object class ::xotcl::Class - ::xotcl::relation ::xotcl::Class class ::xotcl::Class +# puts stderr cl(object)=[::xotcl::relation ::xotcl::Object class] +# puts stderr cl(class)=[::xotcl::relation ::xotcl::Class class] +# ::xotcl::relation ::xotcl::Object class ::xotcl::Class +# ::xotcl::relation ::xotcl::Class class ::xotcl::Class } - # by setting this variable, we can check later, whether we are in - # bootstrapping mode + + # + # By setting the variable bootstrap, we can check later, whether we + # are in bootstrapping mode + # set bootstrap 1 # provide the standard command set for ::xotcl::Object @@ -67,11 +76,9 @@ # # create class and object for nonpositional argument processing ::xotcl::Class create ::xotcl::NonposArgs - foreach cmd [info command ::xotcl::cmd::NonposArgs::*] { ::xotcl::alias ::xotcl::NonposArgs [namespace tail $cmd] $cmd } - ::xotcl::NonposArgs create ::xotcl::nonposArgs ######################## Index: generic/xotcl.c =================================================================== diff -u -rfd82d80829200a3928e29cdfc0d19df6222a9267 -r91e9b1a3b1c3e60a8538156b4aa37d5a664d5133 --- generic/xotcl.c (.../xotcl.c) (revision fd82d80829200a3928e29cdfc0d19df6222a9267) +++ generic/xotcl.c (.../xotcl.c) (revision 91e9b1a3b1c3e60a8538156b4aa37d5a664d5133) @@ -102,7 +102,9 @@ static int isSubType(XOTclClass *subcl, XOTclClass *cl); static int setInstVar(Tcl_Interp *interp, XOTclObject *obj, Tcl_Obj *name, Tcl_Obj *value); static void MixinComputeDefined(Tcl_Interp *interp, XOTclObject *obj); +static XOTclClass *DefaultSuperClass(Tcl_Interp *interp, XOTclClass *cl, XOTclClass *mcl, int isMeta); + static Tcl_ObjType XOTclObjectType = { "XOTclObject", FreeXOTclObjectInternalRep, @@ -2064,7 +2066,7 @@ * check for parent namespace existance (used before commands are created) */ XOTCLINLINE static int -NSCheckForParent(Tcl_Interp *interp, char *name, unsigned l) { +NSCheckForParent(Tcl_Interp *interp, char *name, unsigned l, XOTclClass *cl) { register char *n = name+l; int result = 1; @@ -2089,7 +2091,7 @@ /* call unknown and try again */ Tcl_Obj *ov[3]; int rc; - ov[0] = RUNTIME_STATE(interp)->theClass->object.cmdName; + ov[0] = DefaultSuperClass(interp, cl, cl->object.cl, 0)->object.cmdName; ov[1] = XOTclGlobalObjects[XOTE___UNKNOWN]; ov[2] = Tcl_NewStringObj(parentName,-1); INCR_REF_COUNT(ov[2]); @@ -3209,7 +3211,7 @@ if (mCl) { for (pl = ComputeOrder(mCl, mCl->order, Super); pl; pl = pl->nextPtr) { /*fprintf(stderr, " %s, ", ObjStr(pl->cl->object.cmdName));*/ - if (pl->cl != RUNTIME_STATE(interp)->theObject) { + if ((pl->cl->object.flags & XOTCL_IS_ROOT_CLASS) == 0) { XOTclClassOpt *opt = pl->cl->opt; if (opt && opt->instmixins) { /* compute transitively the instmixin classes of this added @@ -4983,8 +4985,10 @@ /* if there are no more super classes add the Object class as superclasses */ - if (cl->super == NULL) - AddSuper(cl, RUNTIME_STATE(interp)->theObject); + if (cl->super == NULL) { + fprintf(stderr, "SuperClassAdd super of '%s' is NULL\n", className(cl)); + /*AddSuper(cl, RUNTIME_STATE(interp)->theObject);*/ + } Tcl_ResetResult(interp); return TCL_OK; @@ -7755,12 +7759,10 @@ */ static void CleanupDestroyObject(Tcl_Interp *interp, XOTclObject *obj, int softrecreate) { - XOTclClass *thecls, *theobj; - thecls = RUNTIME_STATE(interp)->theClass; - theobj = RUNTIME_STATE(interp)->theObject; /* remove the instance, but not for ::Class/::Object */ - if (obj != &(thecls->object) && obj != &(theobj->object)) { + if ((obj->flags & XOTCL_IS_ROOT_CLASS) == 0 && + (obj->flags & XOTCL_IS_ROOT_META_CLASS) == 0 ) { if (!softrecreate) { (void)RemoveInstance(obj, obj->cl); @@ -7988,7 +7990,7 @@ assert(isAbsolutePath(name)); length = strlen(name); - if (!NSCheckForParent(interp, name, length)) { + if (!NSCheckForParent(interp, name, length, cl)) { ckfree((char *) obj); return 0; } @@ -8013,15 +8015,15 @@ } static XOTclClass * -DefaultSuperClass(Tcl_Interp *interp, XOTclClass *cl, XOTclClass *mcl, XOTclClass *topcl, int isMeta) { - XOTclClass *defaultClass = topcl; - - /* - fprintf(stderr, "DefaultSuperClass cl %s, mcl %s\n", +DefaultSuperClass(Tcl_Interp *interp, XOTclClass *cl, XOTclClass *mcl, int isMeta) { + XOTclClass *defaultClass = NULL; + + /*fprintf(stderr, "DefaultSuperClass cl %s, mcl %s, isMeta %d\n", className(cl), - className(mcl) - ); - */ + className(mcl), + isMeta + );*/ + if (mcl) { int result; @@ -8038,8 +8040,12 @@ } else { Tcl_Obj *bootstrap = Tcl_GetVar2Ex(interp, "::xotcl::bootstrap", NULL, TCL_GLOBAL_ONLY); - if (bootstrap) { + /* the bootstrap test seems not necessary anymore. + * TODO: remove me + */ + if (bootstrap && 0) { Tcl_Obj *nameObj = Tcl_NewStringObj("::xotcl::Object", -1); + fprintf(stderr,"use ::xotcl::Object\n"); INCR_REF_COUNT(nameObj); if (GetXOTclClassFromObj(interp, nameObj, &defaultClass, 0) != TCL_OK) { XOTclErrMsg(interp, "default superclass is not a class", TCL_STATIC); @@ -8051,17 +8057,34 @@ /* check superclasses of metaclass */ /*fprintf(stderr,"DefaultSuperClass: search in superclasses starting with %p\n",cl->super);*/ for (sc = mcl->super; sc && sc->cl != cl; sc = sc->nextPtr) { - /*fprintf(stderr, " ... check %s\n",className(sc->cl));*/ - result = DefaultSuperClass(interp, cl, sc->cl, topcl, isMeta); - if (result != topcl) { + /*fprintf(stderr, " ... check ismeta %d %s root mcl %d root cl %d\n", + isMeta, className(sc->cl), + sc->cl->object.flags & XOTCL_IS_ROOT_META_CLASS, + sc->cl->object.flags & XOTCL_IS_ROOT_CLASS);*/ + if (isMeta) { + if (sc->cl->object.flags & XOTCL_IS_ROOT_META_CLASS) { + return sc->cl; + } + } else { + if (sc->cl->object.flags & XOTCL_IS_ROOT_CLASS) { + return sc->cl; + } + } + result = DefaultSuperClass(interp, cl, sc->cl, isMeta); + if (result) { return result; } } } } } else { /* during bootstrapping, there might be no meta class defined yet */ - /*fprintf(stderr, "no meta class\n");*/ + /*fprintf(stderr, "no meta class ismeta %d %s root mcl %d root cl %d\n", + isMeta, className(cl), + cl->object.flags & XOTCL_IS_ROOT_META_CLASS, + cl->object.flags & XOTCL_IS_ROOT_CLASS + );*/ + return NULL; } return defaultClass; } @@ -8074,7 +8097,6 @@ CleanupDestroyClass(Tcl_Interp *interp, XOTclClass *cl, int softrecreate, int recreate) { Tcl_HashSearch hSrch; Tcl_HashEntry *hPtr; - XOTclClass *theobj = RUNTIME_STATE(interp)->theObject; XOTclClassOpt *clopt = cl->opt; XOTclClass *defaultClass = NULL; @@ -8131,7 +8153,7 @@ if (!softrecreate) { /* maybe todo: do we need an defaultclass for the metaclass as well ? */ - defaultClass = DefaultSuperClass(interp, cl, cl->object.cl, RUNTIME_STATE(interp)->theObject, 0); + defaultClass = DefaultSuperClass(interp, cl, cl->object.cl, 0); /* Reclass all instances of the current class the the appropriate most general class ("baseClass"). The most general class of a @@ -8143,18 +8165,23 @@ We do not have to reclassing in case, cl == ::xotcl::Object */ - if (cl != theobj) { + if ((cl->object.flags & XOTCL_IS_ROOT_CLASS) == 0) { XOTclClass *baseClass = IsMetaClass(interp, cl, 1) ? - DefaultSuperClass(interp, cl, cl->object.cl, RUNTIME_STATE(interp)->theClass, 1) + DefaultSuperClass(interp, cl, cl->object.cl, 1) : defaultClass; +#if 0 if (baseClass == cl) { + XOTclClass *theobj = RUNTIME_STATE(interp)->theObject; + /* During final cleanup, we delete ::xotcl::Class; there are no more Classes or user objects available at that time, so we reclass to ::xotcl::Object. */ baseClass = theobj; } +#endif + /* fprintf(stderr,"baseclass = %s\n",className(baseClass));*/ hPtr = &cl->instances ? Tcl_FirstHashEntry(&cl->instances, &hSrch) : 0; @@ -8211,7 +8238,7 @@ * class as superclasses * -> don't do that for Object itself! */ - if (subClass->super == 0 && cl != theobj) + if (subClass->super == 0 && (cl->object.flags & XOTCL_IS_ROOT_CLASS) == 0) AddSuper(subClass, defaultClass); } /*(void)RemoveSuper(cl, cl->super->cl);*/ @@ -8256,7 +8283,7 @@ cl->super = NULL; /* Look for a configured default superclass */ - defaultSuperclass = DefaultSuperClass(interp, cl, cl->object.cl, RUNTIME_STATE(interp)->theObject, 0); + defaultSuperclass = DefaultSuperClass(interp, cl, cl->object.cl, 0); /* if (defaultSuperclass) { fprintf(stderr, "default superclass= %s\n", className(defaultSuperclass)); @@ -8382,7 +8409,7 @@ */ /* check whether Object parent NS already exists, otherwise: error */ - if (!NSCheckForParent(interp, name, length)) { + if (!NSCheckForParent(interp, name, length, class)) { ckfree((char *) cl); return 0; } @@ -8718,7 +8745,7 @@ static int hasMetaProperty(Tcl_Interp *interp, XOTclClass *cl) { - return (cl->object.flags & XOTCL_IS_METACLASS) || (cl == RUNTIME_STATE(interp)->theClass); + return cl->object.flags & XOTCL_IS_ROOT_META_CLASS; } static int @@ -10661,19 +10688,25 @@ char *method; XOTclObject *obj; register char *n; - ClientData cp; - /* xxx */ if (objc < 3) { return XOTclObjErrArgCnt(interp, objv[0], NULL, " ?args?"); } + XOTclObjConvertObject(interp, objv[2], &obj); if (!obj) return XOTclObjErrType(interp, objv[2], "Class|Object"); method = ObjStr(objv[1]); n = method + strlen(method); + /*fprintf(stderr, "Dispatch obj=%s, o=%p cmd m='%s'\n",ObjStr(objv[2]),obj,method);*/ + + /* if the specified method is a fully qualified cmd name like e.g. + ::xotcl::cmd::Class::alloc, this method is called on the + specified , no matter whether it was registered on + it */ + /*search for last '::'*/ while ((*n != ':' || *(n-1) != ':') && n-1 > method) {n--; } if (*n == ':' && n > method && *(n-1) == ':') {n--;} @@ -10697,7 +10730,7 @@ return XOTclVarErrMsg(interp, "cannot lookup parent namespace '", method, "'", (char *) NULL); } - + fprintf(stderr, " .... findmethod '%s' in %s\n",tail, ns->fullName); cmd = FindMethod(tail, ns); if (cmd && (importedCmd = TclGetOriginalCommand(cmd))) { cmd = importedCmd; @@ -10708,9 +10741,8 @@ tail, "'", (char *) NULL); } - cp = Tcl_Command_objClientData(cmd); result = DoCallProcCheck((ClientData)obj, interp, - objc-1, objv+1, cmd, obj, + objc-2, objv+2, cmd, obj, NULL /*XOTclClass *cl*/, tail, XOTCL_CSC_TYPE_PLAIN); } else { @@ -10848,17 +10880,17 @@ static CONST char *opts[] = { "mixin", "instmixin", "object-mixin", "class-mixin", "filter", "instfilter", "object-filter", "class-filter", - "class", "superclass", "metaclass", + "class", "superclass", "rootclass", NULL }; enum subCmdIdx { mixinIdx, instmixinIdx, pomIdx, pcmIdx, filterIdx, instfilterIdx, pofIdx, pcfIdx, - classIdx, superclassIdx, metaclassIdx + classIdx, superclassIdx, rootclassIdx }; if (objc < 3 || objc > 4) - return XOTclObjErrArgCnt(interp, objv[0], NULL, "obj reltype values"); + return XOTclObjErrArgCnt(interp, objv[0], NULL, "obj reltype value"); if (Tcl_GetIndexFromObj(interp, objv[2], opts, "relation type", 0, &opt) != TCL_OK) { return TCL_ERROR; @@ -10928,14 +10960,28 @@ if (!cl) return XOTclErrBadVal(interp, "class", "a class", ObjStr(objv[1])); return changeClass(interp, obj, cl); - case metaclassIdx: + case rootclassIdx: + { + XOTclClass *metaClass; + if (objc != 4) + return XOTclObjErrArgCnt(interp, objv[0], NULL, " rootclass "); + GetXOTclClassFromObj(interp, objv[1], &cl, 0); if (!cl) return XOTclObjErrType(interp, objv[1], "Class"); - cl->object.flags |= XOTCL_IS_METACLASS; + GetXOTclClassFromObj(interp, objv[3], &metaClass, 0); + if (!metaClass) return XOTclObjErrType(interp, objv[3], "Class"); + + cl->object.flags |= XOTCL_IS_ROOT_CLASS; + metaClass->object.flags |= XOTCL_IS_ROOT_META_CLASS; + + XOTclClassListAdd(&RUNTIME_STATE(interp)->rootClasses, cl, (ClientData)metaClass); + + return TCL_OK; /* todo: - how to remove metaclass property? - problems with deletion order? + need to remove these properties? + allow to delete a classystem at runtime? */ + } } switch (opt) { @@ -11507,11 +11553,12 @@ static int XOTclCAllocMethod(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { - XOTclClass *cl = XOTclObjectToClass(clientData); + XOTclClass *cl; XOTclClass *newcl; XOTclObject *newobj; int result; + cl = XOTclObjectToClass(clientData); if (!cl) return XOTclObjErrType(interp, objv[0], "Class"); if (objc < 2) return XOTclObjErrArgCnt(interp, cl->object.cmdName, objv[0], " ?args?"); @@ -12633,11 +12680,11 @@ bdyStr = ObjStr(objv[3 + incr]); name = ObjStr(objv[1 + incr]); - if ((cl == RUNTIME_STATE(interp)->theObject && isDestroyString(name)) || - (cl == RUNTIME_STATE(interp)->theClass && isInstDestroyString(name)) || - (cl == RUNTIME_STATE(interp)->theClass && isDeallocString(name)) || - (cl == RUNTIME_STATE(interp)->theClass && isAllocString(name)) || - (cl == RUNTIME_STATE(interp)->theClass && isCreateString(name))) + if ((cl->object.flags & XOTCL_IS_ROOT_CLASS && isDestroyString(name)) || + (cl->object.flags & XOTCL_IS_ROOT_META_CLASS && isInstDestroyString(name)) || + (cl->object.flags & XOTCL_IS_ROOT_META_CLASS && isDeallocString(name)) || + (cl->object.flags & XOTCL_IS_ROOT_META_CLASS && isAllocString(name)) || + (cl->object.flags & XOTCL_IS_ROOT_META_CLASS && isCreateString(name))) return XOTclVarErrMsg(interp, className(cl), " method '", name, "' of ", className(cl), " can not be overwritten. Derive a ", "sub-class", (char *) NULL); @@ -13709,16 +13756,15 @@ } static void -freeAllXOTclObjectsAndClasses(Tcl_Interp *interp, Tcl_HashTable *commandTable) { +freeAllXOTclObjectsAndClasses(Tcl_Interp *interp, Tcl_HashTable *commandTable, + XOTclClass *rootClass, XOTclClass *rootMetaClass) { Tcl_HashEntry *hPtr; Tcl_HashSearch hSrch; XOTclObject *obj; - XOTclClass *thecls, *theobj, *cl; + XOTclClass *cl; /* fprintf(stderr,"??? freeAllXOTclObjectsAndClasses in %p\n", interp); */ - thecls = RUNTIME_STATE(interp)->theClass; - theobj = RUNTIME_STATE(interp)->theObject; /***** PHYSICAL DESTROY *****/ RUNTIME_STATE(interp)->exitHandlerDestroyRound = XOTCL_EXITHANDLER_ON_PHYSICAL_DESTROY; while (1) { @@ -13748,8 +13794,7 @@ && !ObjectHasChildren(interp, (XOTclObject*)cl) && !ClassHasInstances(cl) && !ClassHasSubclasses(cl) - && cl != RUNTIME_STATE(interp)->theClass - && cl != RUNTIME_STATE(interp)->theObject + && (cl->object.flags & (XOTCL_IS_ROOT_META_CLASS|XOTCL_IS_ROOT_CLASS)) == 0 ) { /* fprintf(stderr," ... delete class %s %p\n", key, cl); */ freeUnsetTraceVariable(interp, &cl->object); @@ -13769,51 +13814,26 @@ #endif RUNTIME_STATE(interp)->callDestroy = 0; - RemoveSuper(thecls, theobj); - RemoveInstance((XOTclObject*)thecls, thecls); - RemoveInstance((XOTclObject*)theobj, thecls); + RemoveSuper(rootMetaClass, rootClass); + RemoveInstance((XOTclObject*)rootMetaClass, rootMetaClass); + RemoveInstance((XOTclObject*)rootClass, rootMetaClass); - Tcl_DeleteCommandFromToken(interp, theobj->object.id); - RUNTIME_STATE(interp)->theObject = NULL; + Tcl_DeleteCommandFromToken(interp, rootClass->object.id); + Tcl_DeleteCommandFromToken(interp, rootMetaClass->object.id); - Tcl_DeleteCommandFromToken(interp, thecls->object.id); - RUNTIME_STATE(interp)->theClass = NULL; - XOTcl_DeleteNamespace(interp, RUNTIME_STATE(interp)->fakeNS); - XOTcl_DeleteNamespace(interp, RUNTIME_STATE(interp)->XOTclClassesNS); - XOTcl_DeleteNamespace(interp, RUNTIME_STATE(interp)->XOTclNS); } #endif /* DO_CLEANUP */ -/* - * ::xotcl::finalize command - */ static int -XOTclFinalizeObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { +destroyObjectSystem(Tcl_Interp *interp, XOTclClass *rootClass, XOTclClass *rootMetaClass) { XOTclObject *obj; XOTclClass *cl; - int result; Tcl_HashSearch hSrch; Tcl_HashEntry *hPtr; Tcl_HashTable objTable, *commandTable = &objTable; - /* fprintf(stderr,"+++ call EXIT handler\n"); */ - -#if defined(PROFILE) - XOTclProfilePrintData(interp); -#endif - /* - * evaluate user-defined exit handler - */ - result = Tcl_Eval(interp, "::xotcl::__exitHandler"); - - if (result != TCL_OK) { - fprintf(stderr,"User defined exit handler contains errors!\n" - "Error in line %d: %s\nExecution interrupted.\n", - interp->errorLine, ObjStr(Tcl_GetObjResult(interp))); - } - /* deleting in two rounds: * (a) SOFT DESTROY: call all user-defined destroys * (b) PHYSICAL DESTROY: delete the commands, user-defined @@ -13826,7 +13846,8 @@ Tcl_InitHashTable(commandTable, TCL_STRING_KEYS); MEM_COUNT_ALLOC("Tcl_InitHashTable", commandTable); - getAllInstances(interp, commandTable, RUNTIME_STATE(interp)->theObject); + getAllInstances(interp, commandTable, rootClass); + /***** SOFT DESTROY *****/ RUNTIME_STATE(interp)->exitHandlerDestroyRound = XOTCL_EXITHANDLER_ON_SOFT_DESTROY; @@ -13850,7 +13871,7 @@ } #ifdef DO_CLEANUP - freeAllXOTclObjectsAndClasses(interp, commandTable); + freeAllXOTclObjectsAndClasses(interp, commandTable, rootClass, rootMetaClass); #endif MEM_COUNT_FREE("Tcl_InitHashTable", commandTable); @@ -13859,7 +13880,45 @@ return TCL_OK; } +/* + * ::xotcl::finalize command + */ +static int +XOTclFinalizeObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { + XOTclClasses *os; + int result; + /* fprintf(stderr,"+++ call EXIT handler\n"); */ + +#if defined(PROFILE) + XOTclProfilePrintData(interp); +#endif + /* + * evaluate user-defined exit handler + */ + result = Tcl_Eval(interp, "::xotcl::__exitHandler"); + + if (result != TCL_OK) { + fprintf(stderr,"User defined exit handler contains errors!\n" + "Error in line %d: %s\nExecution interrupted.\n", + interp->errorLine, ObjStr(Tcl_GetObjResult(interp))); + } + + for (os = RUNTIME_STATE(interp)->rootClasses; os; os = os->nextPtr) { + destroyObjectSystem(interp, os->cl, (XOTclClass *)os->clientData); + } + + XOTclClassListFree(RUNTIME_STATE(interp)->rootClasses); + +#ifdef DO_CLEANUP + XOTcl_DeleteNamespace(interp, RUNTIME_STATE(interp)->fakeNS); + XOTcl_DeleteNamespace(interp, RUNTIME_STATE(interp)->XOTclClassesNS); + XOTcl_DeleteNamespace(interp, RUNTIME_STATE(interp)->XOTclNS); +#endif + + return TCL_OK; +} + /* * Exit Handler */ @@ -13980,25 +14039,20 @@ Tcl_CreateExitHandler(XOTcl_ExitProc, clientData); } + int XOTclCreateObjectSystem(Tcl_Interp *interp, char *Object, char *Class) { XOTclClass *theobj = 0; XOTclClass *thecls = 0; - /* create Object and Class, and store them in the RUNTIME STATE */ - theobj = PrimitiveCCreate(interp, Object, 0); - RUNTIME_STATE(interp)->theObject = theobj; - if (!theobj) panic("Cannot create base Object class", 0); + /* Create a basic object system with the basic root class Object and + the basic metaclass Class, and store them in the RUNTIME STATE if + successful */ + theobj = PrimitiveCCreate(interp, Object, 0); thecls = PrimitiveCCreate(interp, Class, 0); - RUNTIME_STATE(interp)->theClass = thecls; - if (!thecls) panic("Cannot create base Class", 0); + /* fprintf(stderr, "CreateObjectSystem created base classes \n"); */ - /*theobj->parent = 0; - thecls->parent = theobj;*/ - - /*Tcl_AddInterpResolvers(interp, "XOTcl", XOTclResolveCmd, 0, 0);*/ - #if defined(PROFILE) XOTclProfileInit(interp); #endif @@ -14017,18 +14071,29 @@ FREE(Tcl_Obj **, XOTclGlobalObjects); FREE(XOTclRuntimeState, RUNTIME_STATE(interp)); - return XOTclErrMsg(interp, "Object/Class failed", TCL_STATIC); + return XOTclErrMsg(interp, "Creation of object system failed", TCL_STATIC); } + theobj->object.flags |= XOTCL_IS_ROOT_CLASS; + thecls->object.flags |= XOTCL_IS_ROOT_META_CLASS; + XOTclClassListAdd(&RUNTIME_STATE(interp)->rootClasses, theobj, (ClientData)thecls); + AddInstance((XOTclObject*)theobj, thecls); AddInstance((XOTclObject*)thecls, thecls); AddSuper(thecls, theobj); - + return TCL_OK; } +static int +XOTclCreateObjectSystemCmd(ClientData clientData, Tcl_Interp *interp, + int objc, Tcl_Obj *CONST objv[]) { + if (objc < 3) { + return XOTclObjErrArgCnt(interp, objv[0], NULL, "rootClass rootMetaClass"); + } + return XOTclCreateObjectSystem(interp, ObjStr(objv[1]), ObjStr(objv[2])); +} - /* * Tcl extension initialization routine */ @@ -14165,12 +14230,14 @@ INCR_REF_COUNT(XOTclGlobalObjects[i]); } + /* #if defined(OO) Tcl_CreateNamespace(interp, "::oo", (ClientData)NULL, (Tcl_NamespaceDeleteProc*)NULL); XOTclCreateObjectSystem(interp, "::oo::object", "::oo::class"); #else XOTclCreateObjectSystem(interp, "::xotcl::Object", "::xotcl::Class"); #endif + */ { typedef struct methodDefinition { char *methodName; @@ -14351,6 +14418,7 @@ /*Tcl_CreateObjCommand(interp, "::xotcl::K", XOTclKObjCmd, 0, 0);*/ Tcl_CreateObjCommand(interp, "::xotcl::alias", XOTclAliasCmd, 0, 0); + Tcl_CreateObjCommand(interp, "::xotcl::createobjectsystem", XOTclCreateObjectSystemCmd, 0, 0); Tcl_CreateObjCommand(interp, "::xotcl::dispatch", XOTclDispatchCmd, 0, 0); Tcl_CreateObjCommand(interp, "::xotcl::methodproperty", XOTclMethodPropertyCmd, 0, 0); Tcl_CreateObjCommand(interp, "::xotcl::configure", XOTclConfigureCmd, 0, 0); Index: generic/xotclInt.h =================================================================== diff -u -rfd82d80829200a3928e29cdfc0d19df6222a9267 -r91e9b1a3b1c3e60a8538156b4aa37d5a664d5133 --- generic/xotclInt.h (.../xotclInt.h) (revision fd82d80829200a3928e29cdfc0d19df6222a9267) +++ generic/xotclInt.h (.../xotclInt.h) (revision 91e9b1a3b1c3e60a8538156b4aa37d5a664d5133) @@ -362,26 +362,26 @@ */ typedef struct XOTclFilterStack { Tcl_Command currentCmdPtr; - Tcl_Obj* calledProc; - struct XOTclFilterStack* nextPtr; + Tcl_Obj *calledProc; + struct XOTclFilterStack *nextPtr; } XOTclFilterStack; typedef struct XOTclTclObjList { - Tcl_Obj* content; - struct XOTclTclObjList* nextPtr; + Tcl_Obj *content; + struct XOTclTclObjList *nextPtr; } XOTclTclObjList; /* * Assertion structures */ typedef struct XOTclProcAssertion { - XOTclTclObjList* pre; - XOTclTclObjList* post; + XOTclTclObjList *pre; + XOTclTclObjList *post; } XOTclProcAssertion; typedef struct XOTclAssertionStore { - XOTclTclObjList* invariants; + XOTclTclObjList *invariants; Tcl_HashTable procs; } XOTclAssertionStore; @@ -392,15 +392,15 @@ CHECK_ALL = CHECK_INVAR + CHECK_PRE + CHECK_POST } CheckOptions; -void XOTclAssertionRename(Tcl_Interp* interp, Tcl_Command cmd, +void XOTclAssertionRename(Tcl_Interp *interp, Tcl_Command cmd, XOTclAssertionStore *as, char *oldSimpleCmdName, char *newName); /* * mixins */ typedef struct XOTclMixinStack { Tcl_Command currentCmdPtr; - struct XOTclMixinStack* nextPtr; + struct XOTclMixinStack *nextPtr; } XOTclMixinStack; /* @@ -410,7 +410,7 @@ Tcl_Command cmdPtr; ClientData clientData; struct XOTclClass *clorobj; - struct XOTclCmdList* nextPtr; + struct XOTclCmdList *nextPtr; } XOTclCmdList; typedef void (XOTclFreeCmdListClientData) _ANSI_ARGS_((XOTclCmdList*)); @@ -441,14 +441,15 @@ /* FILTER_ORDER_DEFINED set, when filters are defined for obj */ #define XOTCL_FILTER_ORDER_DEFINED 0x0020 #define XOTCL_FILTER_ORDER_DEFINED_AND_VALID 0x0030 -/* IS_CLASS set, when object is a class */ +/* CLASS properties for objects */ #define XOTCL_IS_CLASS 0x0040 -#define XOTCL_IS_METACLASS 0x0080 +#define XOTCL_IS_ROOT_META_CLASS 0x0080 +#define XOTCL_IS_ROOT_CLASS 0x0100 /* DESTROYED set, when object is physically destroyed with PrimitiveODestroy */ -#define XOTCL_DESTROYED 0x0100 -#define XOTCL_REFCOUNTED 0x0200 -#define XOTCL_RECREATE 0x0400 -#define XOTCL_NS_DESTROYED 0x0800 +#define XOTCL_DESTROYED 0x1000 +#define XOTCL_REFCOUNTED 0x2000 +#define XOTCL_RECREATE 0x4000 +#define XOTCL_NS_DESTROYED 0x8000 #define XOTclObjectSetClass(obj) \ (obj)->flags |= XOTCL_IS_CLASS @@ -465,15 +466,15 @@ */ typedef struct XOTclNonposArgs { - Tcl_Obj* nonposArgs; - Tcl_Obj* ordinaryArgs; - Tcl_Obj* slotObj; + Tcl_Obj *nonposArgs; + Tcl_Obj *ordinaryArgs; + Tcl_Obj *slotObj; } XOTclNonposArgs; typedef struct XOTclObjectOpt { XOTclAssertionStore *assertions; - XOTclCmdList* filters; - XOTclCmdList* mixins; + XOTclCmdList *filters; + XOTclCmdList *mixins; #ifdef XOTCL_METADATA Tcl_HashTable metaData; #endif @@ -500,42 +501,42 @@ } XOTclObject; typedef struct XOTclObjects { - struct XOTclObject* obj; - struct XOTclObjects* nextPtr; + struct XOTclObject *obj; + struct XOTclObjects *nextPtr; } XOTclObjects; typedef struct XOTclClassOpt { - XOTclCmdList* instfilters; - XOTclCmdList* instmixins; - XOTclCmdList* isObjectMixinOf; - XOTclCmdList* isClassMixinOf; + XOTclCmdList *instfilters; + XOTclCmdList *instmixins; + XOTclCmdList *isObjectMixinOf; + XOTclCmdList *isClassMixinOf; XOTclAssertionStore *assertions; - Tcl_Obj* parameterClass; + Tcl_Obj *parameterClass; #ifdef XOTCL_OBJECTDATA - Tcl_HashTable* objectdata; + Tcl_HashTable *objectdata; #endif Tcl_Command id; ClientData clientData; } XOTclClassOpt; typedef struct XOTclClass { struct XOTclObject object; - struct XOTclClasses* super; - struct XOTclClasses* sub; + struct XOTclClasses *super; + struct XOTclClasses *sub; short color; - struct XOTclClasses* order; - /*struct XOTclClass* parent;*/ + struct XOTclClasses *order; + /*struct XOTclClass *parent;*/ Tcl_HashTable instances; Tcl_Namespace *nsPtr; - Tcl_Obj* parameters; - XOTclClassOpt* opt; + Tcl_Obj *parameters; + XOTclClassOpt *opt; Tcl_HashTable *nonposArgsTable; } XOTclClass; typedef struct XOTclClasses { - struct XOTclClass* cl; + struct XOTclClass *cl; ClientData clientData; - struct XOTclClasses* nextPtr; + struct XOTclClasses *nextPtr; } XOTclClasses; /* XOTcl global names and strings */ @@ -588,9 +589,9 @@ } XOTclShadowTclCommandInfo; typedef enum {SHADOW_LOAD=1, SHADOW_UNLOAD=0, SHADOW_REFETCH=2} XOTclShadowOperations; -int XOTclCallCommand(Tcl_Interp* interp, XOTclGlobalNames name, +int XOTclCallCommand(Tcl_Interp *interp, XOTclGlobalNames name, int objc, Tcl_Obj *CONST objv[]); -int XOTclShadowTclCommands(Tcl_Interp* interp, XOTclShadowOperations load); +int XOTclShadowTclCommands(Tcl_Interp *interp, XOTclShadowOperations load); /* @@ -640,8 +641,7 @@ /* * definitions of the main xotcl objects */ - XOTclClass *theObject; - XOTclClass *theClass; + struct XOTclClasses *rootClasses; #if USE_INTERP_PROC Tcl_CmdProc *interpProc; #endif @@ -677,15 +677,15 @@ #ifdef XOTCL_OBJECTDATA extern void -XOTclSetObjectData(struct XOTclObject* obj, struct XOTclClass* cl, +XOTclSetObjectData(struct XOTclObject *obj, struct XOTclClass *cl, ClientData data); extern int -XOTclGetObjectData(struct XOTclObject* obj, struct XOTclClass* cl, - ClientData* data); +XOTclGetObjectData(struct XOTclObject *obj, struct XOTclClass *cl, + ClientData *data); extern int -XOTclUnsetObjectData(struct XOTclObject* obj, struct XOTclClass* cl); +XOTclUnsetObjectData(struct XOTclObject *obj, struct XOTclClass *cl); extern void -XOTclFreeObjectData(XOTclClass* cl); +XOTclFreeObjectData(XOTclClass *cl); #endif /* @@ -702,39 +702,39 @@ #if defined(PROFILE) extern void -XOTclProfileFillTable(Tcl_HashTable* table, Tcl_DString* key, +XOTclProfileFillTable(Tcl_HashTable *table, Tcl_DString *key, double totalMicroSec); extern void -XOTclProfileEvaluateData(Tcl_Interp* interp, long int startSec, long int startUsec, - XOTclObject* obj, XOTclClass *cl, char *methodName); +XOTclProfileEvaluateData(Tcl_Interp *interp, long int startSec, long int startUsec, + XOTclObject *obj, XOTclClass *cl, char *methodName); extern void -XOTclProfilePrintTable(Tcl_HashTable* table); +XOTclProfilePrintTable(Tcl_HashTable *table); extern void -XOTclProfilePrintData(Tcl_Interp* interp); +XOTclProfilePrintData(Tcl_Interp *interp); extern void -XOTclProfileInit(Tcl_Interp* interp); +XOTclProfileInit(Tcl_Interp *interp); #endif /* * MEM Counting */ #ifdef XOTCL_MEM_COUNT -void XOTclMemCountAlloc(char* id, void *); -void XOTclMemCountFree(char* id, void *); +void XOTclMemCountAlloc(char *id, void *); +void XOTclMemCountFree(char *id, void *); void XOTclMemCountDump(); #endif /* XOTCL_MEM_COUNT */ /* * old, deprecated meta-data command */ #if defined(XOTCL_METADATA) extern void -XOTclMetaDataDestroy(XOTclObject* obj); +XOTclMetaDataDestroy(XOTclObject *obj); extern void -XOTclMetaDataInit(XOTclObject* obj); +XOTclMetaDataInit(XOTclObject *obj); extern int -XOTclOMetaDataMethod (ClientData cd, Tcl_Interp* interp, +XOTclOMetaDataMethod (ClientData cd, Tcl_Interp *interp, int objc, Tcl_Obj *objv[]); #endif /* XOTCL_METADATA */ @@ -759,19 +759,19 @@ Tcl_ObjCmdProc XOTclInitProcNSCmd, XOTclSelfDispatchCmd, XOTclNextObjCmd, XOTclGetSelfObjCmd; -int XOTclDirectSelfDispatch(ClientData cd, Tcl_Interp* interp, +int XOTclDirectSelfDispatch(ClientData cd, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]); #endif int -XOTclObjDispatch(ClientData cd, Tcl_Interp* interp, +XOTclObjDispatch(ClientData cd, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]); XOTclCallStackContent * -XOTclCallStackFindActiveFrame(Tcl_Interp* interp, int offset); +XOTclCallStackFindActiveFrame(Tcl_Interp *interp, int offset); XOTclCallStackContent * -XOTclCallStackFindLastInvocation(Tcl_Interp* interp, int offset); +XOTclCallStackFindLastInvocation(Tcl_Interp *interp, int offset); /* functions from xotclUtil.c */ char *XOTcl_ltoa(char *buf, long i, int *len); Index: tests/mixinoftest.xotcl =================================================================== diff -u -r43e8ea0de59e32655b41cbd6c8a47acf8ada443a -r91e9b1a3b1c3e60a8538156b4aa37d5a664d5133 --- tests/mixinoftest.xotcl (.../mixinoftest.xotcl) (revision 43e8ea0de59e32655b41cbd6c8a47acf8ada443a) +++ tests/mixinoftest.xotcl (.../mixinoftest.xotcl) (revision 91e9b1a3b1c3e60a8538156b4aa37d5a664d5133) @@ -56,17 +56,17 @@ Object o -mixin M ? {o info mixin} ::M -? {o info precedence} "::M ::xotcl::Object ::oo::object" +? {o info precedence} "::M ::xotcl::Object" ? {o procsearch foo} "::M instproc foo" Class M -instproc foo args next ? {o info mixin} ::M -? {o info precedence} "::M ::xotcl::Object ::oo::object" +? {o info precedence} "::M ::xotcl::Object" ? {o procsearch foo} "::M instproc foo" M destroy ? {o info mixin} "" -? {o info precedence} "::xotcl::Object ::oo::object" +? {o info precedence} "::xotcl::Object" ? {o procsearch foo} "" o destroy @@ -83,11 +83,11 @@ ? {B instmixin} ::A ? {B info instmixin} ::A ? {A info instmixinof} ::B -? {c1 info precedence} "::A ::C ::B ::xotcl::Object ::oo::object" +? {c1 info precedence} "::A ::C ::B ::xotcl::Object" B destroy ? {A info instmixinof} "" -? {c1 info precedence} "::C ::xotcl::Object ::oo::object" +? {c1 info precedence} "::C ::xotcl::Object" A destroy C destroy @@ -135,9 +135,9 @@ ? {B instmixin} ::A ? {B info instmixin} ::A ? {A info instmixinof} ::B -? {a1 info precedence} "::M ::A ::xotcl::Object ::oo::object" -? {b1 info precedence} "::M ::A ::B ::xotcl::Object ::oo::object" -? {c1 info precedence} "::M ::A ::C ::B ::xotcl::Object ::oo::object" +? {a1 info precedence} "::M ::A ::xotcl::Object" +? {b1 info precedence} "::M ::A ::B ::xotcl::Object" +? {c1 info precedence} "::M ::A ::C ::B ::xotcl::Object" ? {M info instmixinof} "::A" # since M is an instmixin of A and A is a instmixin of B, @@ -150,13 +150,13 @@ # and now destroy mixin classes M destroy -? {a1 info precedence} "::A ::xotcl::Object ::oo::object" -? {b1 info precedence} "::A ::B ::xotcl::Object ::oo::object" -? {c1 info precedence} "::A ::C ::B ::xotcl::Object ::oo::object" +? {a1 info precedence} "::A ::xotcl::Object" +? {b1 info precedence} "::A ::B ::xotcl::Object" +? {c1 info precedence} "::A ::C ::B ::xotcl::Object" B destroy ? {A info instmixinof} "" -? {c1 info precedence} "::C ::xotcl::Object ::oo::object" +? {c1 info precedence} "::C ::xotcl::Object" foreach o {A C a1 b1 c1} { $o destroy } @@ -183,9 +183,9 @@ ? {A info instmixinof -closure} "" ? {B info instmixinof -closure} "" ? {X info instmixinof -closure} "::D ::C ::A ::B" -? {b1 info precedence} "::C ::X ::D ::B ::A ::xotcl::Object ::oo::object" +? {b1 info precedence} "::C ::X ::D ::B ::A ::xotcl::Object" B b2 -? {b2 info precedence} "::C ::X ::D ::B ::A ::xotcl::Object ::oo::object" +? {b2 info precedence} "::C ::X ::D ::B ::A ::xotcl::Object" foreach o {X D C A B b1 b2} {$o destroy} @@ -230,23 +230,23 @@ ? {B instmixin} ::A ? {B info instmixin} ::A ? {A info instmixinof} ::B -? {a1 info precedence} "::M ::A ::xotcl::Object ::oo::object" -? {b1 info precedence} "::M ::A ::B ::xotcl::Object ::oo::object" -? {c1 info precedence} "::M ::A ::C ::B ::xotcl::Object ::oo::object" +? {a1 info precedence} "::M ::A ::xotcl::Object" +? {b1 info precedence} "::M ::A ::B ::xotcl::Object" +? {c1 info precedence} "::M ::A ::C ::B ::xotcl::Object" # and now destroy A A destroy -? {a1 info precedence} "::xotcl::Object ::oo::object" -? {b1 info precedence} "::B ::xotcl::Object ::oo::object" -? {c1 info precedence} "::C ::B ::xotcl::Object ::oo::object" +? {a1 info precedence} "::xotcl::Object" +? {b1 info precedence} "::B ::xotcl::Object" +? {c1 info precedence} "::C ::B ::xotcl::Object" ? {M info instmixinof} "" ? {M info instmixinof -closure} "" B destroy ? {M info instmixinof} "" -? {c1 info precedence} "::C ::xotcl::Object ::oo::object" +? {c1 info precedence} "::C ::xotcl::Object" foreach o {M C a1 b1 c1} { $o destroy } @@ -265,14 +265,14 @@ ? {B instmixin} ::A ? {B info instmixin} ::A ? {A info instmixinof} ::B -? {a1 info precedence} "::M ::A ::xotcl::Object ::oo::object" -? {b1 info precedence} "::M ::A ::B ::xotcl::Object ::oo::object" -? {c1 info precedence} "::M ::A ::C ::B ::xotcl::Object ::oo::object" +? {a1 info precedence} "::M ::A ::xotcl::Object" +? {b1 info precedence} "::M ::A ::B ::xotcl::Object" +? {c1 info precedence} "::M ::A ::C ::B ::xotcl::Object" B destroy -? {a1 info precedence} "::M ::A ::xotcl::Object ::oo::object" -? {b1 info precedence} "::xotcl::Object ::oo::object" -? {c1 info precedence} "::C ::xotcl::Object ::oo::object" +? {a1 info precedence} "::M ::A ::xotcl::Object" +? {b1 info precedence} "::xotcl::Object" +? {c1 info precedence} "::C ::xotcl::Object" ? {M info instmixinof} "::A" ? {M info instmixinof -closure} "::A" @@ -294,22 +294,22 @@ ? {B instmixin} ::A ? {B info instmixin} ::A ? {A info instmixinof} ::B -? {c1 info precedence} "::A ::C ::B ::xotcl::Object ::oo::object" -? {B info heritage} "::xotcl::Object ::oo::object" -? {C info heritage} "::B ::xotcl::Object ::oo::object" +? {c1 info precedence} "::A ::C ::B ::xotcl::Object" +? {B info heritage} "::xotcl::Object" +? {C info heritage} "::B ::xotcl::Object" Class B -instmixin A -? {B info heritage} "::xotcl::Object ::oo::object" -? {C info heritage} "::xotcl::Object ::oo::object" +? {B info heritage} "::xotcl::Object" +? {C info heritage} "::xotcl::Object" ? {B instmixin} ::A ? {B info instmixin} ::A ? {A info instmixinof} ::B -? {c1 info precedence} "::C ::xotcl::Object ::oo::object" +? {c1 info precedence} "::C ::xotcl::Object" B destroy ? {A info instmixinof} "" -? {c1 info precedence} "::C ::xotcl::Object ::oo::object" +? {c1 info precedence} "::C ::xotcl::Object" A destroy C destroy @@ -330,20 +330,20 @@ ? {B instmixin} ::A ? {B info instmixin} ::A ? {A info instmixinof} ::B -? {c1 info precedence} "::A ::C ::B ::xotcl::Object ::oo::object" -? {C info heritage} "::B ::xotcl::Object ::oo::object" -? {B info heritage} "::xotcl::Object ::oo::object" +? {c1 info precedence} "::A ::C ::B ::xotcl::Object" +? {C info heritage} "::B ::xotcl::Object" +? {B info heritage} "::xotcl::Object" Class B -instmixin A -? {C info heritage} "::B ::xotcl::Object ::oo::object" -? {B info heritage} "::xotcl::Object ::oo::object" +? {C info heritage} "::B ::xotcl::Object" +? {B info heritage} "::xotcl::Object" ? {B info instmixin} ::A ? {A info instmixinof} ::B -? {c1 info precedence} "::A ::C ::B ::xotcl::Object ::oo::object" +? {c1 info precedence} "::A ::C ::B ::xotcl::Object" B destroy ? {A info instmixinof} "" -? {c1 info precedence} "::C ::xotcl::Object ::oo::object" +? {c1 info precedence} "::C ::xotcl::Object" A destroy C destroy @@ -363,23 +363,23 @@ A a1 O o1 ? {A info superclass} "::O" -? {B info heritage} "::A ::O ::xotcl::Object ::oo::object" +? {B info heritage} "::A ::O ::xotcl::Object" ? {list [A info subclass] [B info subclass] [O info subclass]} "::B {} ::A" ? {list [A info superclass] [B info superclass] [O info superclass]} "::O ::A ::xotcl::Object" ? {list [a1 info class] [b1 info class] [o1 info class]} "::A ::B ::O" -? {o1 info precedence} "::O ::xotcl::Object ::oo::object" -? {a1 info precedence} "::A ::O ::xotcl::Object ::oo::object" -? {b1 info precedence} "::B ::A ::O ::xotcl::Object ::oo::object" +? {o1 info precedence} "::O ::xotcl::Object" +? {a1 info precedence} "::A ::O ::xotcl::Object" +? {b1 info precedence} "::B ::A ::O ::xotcl::Object" # we recreate the class new, with the same superclass Class A -superclass O ? {A info superclass} "::O" -? {B info heritage} "::xotcl::Object ::oo::object" +? {B info heritage} "::xotcl::Object" ? {list [A info subclass] [B info subclass] [O info subclass]} "{} {} ::A" ? {list [A info superclass] [B info superclass] [O info superclass]} "::O ::xotcl::Object ::xotcl::Object" ? {list [a1 info class] [b1 info class] [o1 info class]} "::xotcl::Object ::B ::O" -? {o1 info precedence} "::O ::xotcl::Object ::oo::object" -? {a1 info precedence} "::xotcl::Object ::oo::object" -? {b1 info precedence} "::B ::xotcl::Object ::oo::object" +? {o1 info precedence} "::O ::xotcl::Object" +? {a1 info precedence} "::xotcl::Object" +? {b1 info precedence} "::B ::xotcl::Object" foreach o {A O B a1 b1 o1} {$o destroy} ########################################### @@ -395,23 +395,23 @@ A a1 O o1 ? {A info superclass} "::O" -? {B info heritage} "::A ::O ::xotcl::Object ::oo::object" +? {B info heritage} "::A ::O ::xotcl::Object" ? {list [A info subclass] [B info subclass] [O info subclass]} "::B {} ::A" ? {list [A info superclass] [B info superclass] [O info superclass]} "::O ::A ::xotcl::Object" ? {list [a1 info class] [b1 info class] [o1 info class]} "::A ::B ::O" -? {o1 info precedence} "::O ::xotcl::Object ::oo::object" -? {a1 info precedence} "::A ::O ::xotcl::Object ::oo::object" -? {b1 info precedence} "::B ::A ::O ::xotcl::Object ::oo::object" +? {o1 info precedence} "::O ::xotcl::Object" +? {a1 info precedence} "::A ::O ::xotcl::Object" +? {b1 info precedence} "::B ::A ::O ::xotcl::Object" # we recreate the class new, with a different superclass Class A ? {A info superclass} "::xotcl::Object" -? {B info heritage} "::xotcl::Object ::oo::object" +? {B info heritage} "::xotcl::Object" ? {list [A info subclass] [B info subclass] [O info subclass]} "{} {} {}" ? {list [A info superclass] [B info superclass] [O info superclass]} "::xotcl::Object ::xotcl::Object ::xotcl::Object" ? {list [a1 info class] [b1 info class] [o1 info class]} "::xotcl::Object ::B ::O" -? {o1 info precedence} "::O ::xotcl::Object ::oo::object" -? {a1 info precedence} "::xotcl::Object ::oo::object" -? {b1 info precedence} "::B ::xotcl::Object ::oo::object" +? {o1 info precedence} "::O ::xotcl::Object" +? {a1 info precedence} "::xotcl::Object" +? {b1 info precedence} "::B ::xotcl::Object" foreach o {A O B a1 b1 o1} {$o destroy} @@ -428,23 +428,23 @@ A a1 O o1 ? {A info superclass} "::O" -? {B info heritage} "::A ::O ::xotcl::Object ::oo::object" +? {B info heritage} "::A ::O ::xotcl::Object" ? {list [A info subclass] [B info subclass] [O info subclass]} "::B {} ::A" ? {list [A info superclass] [B info superclass] [O info superclass]} "::O ::A ::xotcl::Object" ? {list [a1 info class] [b1 info class] [o1 info class]} "::A ::B ::O" -? {o1 info precedence} "::O ::xotcl::Object ::oo::object" -? {a1 info precedence} "::A ::O ::xotcl::Object ::oo::object" -? {b1 info precedence} "::B ::A ::O ::xotcl::Object ::oo::object" +? {o1 info precedence} "::O ::xotcl::Object" +? {a1 info precedence} "::A ::O ::xotcl::Object" +? {b1 info precedence} "::B ::A ::O ::xotcl::Object" # we recreate the class new, with the same superclass Class A -superclass O ? {A info superclass} "::O" -? {B info heritage} "::A ::O ::xotcl::Object ::oo::object" +? {B info heritage} "::A ::O ::xotcl::Object" ? {list [A info subclass] [B info subclass] [O info subclass]} "::B {} ::A" ? {list [A info superclass] [B info superclass] [O info superclass]} "::O ::A ::xotcl::Object" ? {list [a1 info class] [b1 info class] [o1 info class]} "::A ::B ::O" -? {o1 info precedence} "::O ::xotcl::Object ::oo::object" -? {a1 info precedence} "::A ::O ::xotcl::Object ::oo::object" -? {b1 info precedence} "::B ::A ::O ::xotcl::Object ::oo::object" +? {o1 info precedence} "::O ::xotcl::Object" +? {a1 info precedence} "::A ::O ::xotcl::Object" +? {b1 info precedence} "::B ::A ::O ::xotcl::Object" foreach o {A O B a1 b1 o1} {$o destroy} ########################################### @@ -459,24 +459,24 @@ B b1 A a1 O o1 -? {B info heritage} "::A ::O ::xotcl::Object ::oo::object" +? {B info heritage} "::A ::O ::xotcl::Object" ? {list [A info subclass] [B info subclass] [O info subclass]} "::B {} ::A" ? {list [A info superclass] [B info superclass] [O info superclass]} "::O ::A ::xotcl::Object" ? {list [a1 info class] [b1 info class] [o1 info class]} "::A ::B ::O" -? {o1 info precedence} "::O ::xotcl::Object ::oo::object" -? {a1 info precedence} "::A ::O ::xotcl::Object ::oo::object" -? {b1 info precedence} "::B ::A ::O ::xotcl::Object ::oo::object" +? {o1 info precedence} "::O ::xotcl::Object" +? {a1 info precedence} "::A ::O ::xotcl::Object" +? {b1 info precedence} "::B ::A ::O ::xotcl::Object" # we recreate the class new, with a different superclass Class A ? {A info superclass} "::xotcl::Object" -? {B info heritage} "::A ::xotcl::Object ::oo::object" -? {B info heritage} "::A ::xotcl::Object ::oo::object" +? {B info heritage} "::A ::xotcl::Object" +? {B info heritage} "::A ::xotcl::Object" ? {list [A info subclass] [B info subclass] [O info subclass]} "::B {} {}" ? {list [A info superclass] [B info superclass] [O info superclass]} "::xotcl::Object ::A ::xotcl::Object" ? {list [a1 info class] [b1 info class] [o1 info class]} "::A ::B ::O" -? {o1 info precedence} "::O ::xotcl::Object ::oo::object" -? {a1 info precedence} "::A ::xotcl::Object ::oo::object" -? {b1 info precedence} "::B ::A ::xotcl::Object ::oo::object" +? {o1 info precedence} "::O ::xotcl::Object" +? {a1 info precedence} "::A ::xotcl::Object" +? {b1 info precedence} "::B ::A ::xotcl::Object" foreach o {A O B a1 b1 o1} {$o destroy} Index: tests/object-system.xotcl =================================================================== diff -u -r98003953e8c728b105528e0c2ed7d67ee7135d64 -r91e9b1a3b1c3e60a8538156b4aa37d5a664d5133 --- tests/object-system.xotcl (.../object-system.xotcl) (revision 98003953e8c728b105528e0c2ed7d67ee7135d64) +++ tests/object-system.xotcl (.../object-system.xotcl) (revision 91e9b1a3b1c3e60a8538156b4aa37d5a664d5133) @@ -20,13 +20,13 @@ ? {Object isobject Object} 1 ? {Object isclass} 1 ? {Object ismetaclass} 0 -? {Object info superclass} ::oo::object +? {Object info superclass} "" ? {Object info class} ::xotcl::Class ? {Object isobject Class} 1 ? {Class isclass} 1 ? {Class ismetaclass} 1 -? {Class info superclass} "::oo::class ::xotcl::Object" +? {Class info superclass} ::xotcl::Object ? {Class info class} ::xotcl::Class Object o Index: tests/testx.xotcl =================================================================== diff -u -r43e8ea0de59e32655b41cbd6c8a47acf8ada443a -r91e9b1a3b1c3e60a8538156b4aa37d5a664d5133 --- tests/testx.xotcl (.../testx.xotcl) (revision 43e8ea0de59e32655b41cbd6c8a47acf8ada443a) +++ tests/testx.xotcl (.../testx.xotcl) (revision 91e9b1a3b1c3e60a8538156b4aa37d5a664d5133) @@ -2035,11 +2035,11 @@ Class M Object o -mixin M M instmixin IM - ::errorCheck [o info precedence] {::IM ::M ::xotcl::Object ::oo::object} \ + ::errorCheck [o info precedence] {::IM ::M ::xotcl::Object} \ {trans. mixin precedence 1} Object o -mixin M - ::errorCheck [o info precedence] {::IM ::M ::xotcl::Object ::oo::object} \ + ::errorCheck [o info precedence] {::IM ::M ::xotcl::Object} \ {trans. mixin precedence 2} o destroy } @@ -2879,9 +2879,9 @@ ::errorCheck [o2 info mixin] ::C "up/down before 5" ::errorCheck [B info mixinof] ::o1 "up/down before 6" ::errorCheck [C info mixinof] ::o2 "up/down before 7" - ::errorCheck [c1 info precedence] "::C ::B ::xotcl::Object ::oo::object" "up/down before 8" - ::errorCheck [o1 info precedence] "::B ::xotcl::Object ::oo::object" "up/down before 9" - ::errorCheck [o2 info precedence] "::C ::B ::xotcl::Object ::oo::object" "up/down before 10" + ::errorCheck [c1 info precedence] "::C ::B ::xotcl::Object" "up/down before 8" + ::errorCheck [o1 info precedence] "::B ::xotcl::Object" "up/down before 9" + ::errorCheck [o2 info precedence] "::C ::B ::xotcl::Object" "up/down before 10" ::errorCheck [catch {B class Object}] 1 "don't allow downgrading" @@ -2894,9 +2894,9 @@ ::errorCheck [o2 info mixin] ::C "up/down after 5" ::errorCheck [catch {B info mixinof}] 1 "up/down after 6" ::errorCheck [C info mixinof] ::o2 "up/down after 7" - ::errorCheck [c1 info precedence] "::C ::xotcl::Object ::oo::object" "up/down after 8" - ::errorCheck [o1 info precedence] "::xotcl::Object ::oo::object" "up/down after 9" - ::errorCheck [o2 info precedence] "::C ::xotcl::Object ::oo::object" "up/down after 10" + ::errorCheck [c1 info precedence] "::C ::xotcl::Object" "up/down after 8" + ::errorCheck [o1 info precedence] "::xotcl::Object" "up/down after 9" + ::errorCheck [o2 info precedence] "::C ::xotcl::Object" "up/down after 10" ::errorCheck [B info class] "::xotcl::Object" "up/down after 0x" B class Object @@ -3251,7 +3251,7 @@ ::errorCheck [C info subclass -closure E] ::E "transitive subclass 1" ::errorCheck [Object info subclass -closure E] ::E "transitive subclass 2" ::errorCheck [D info subclass -closure C] "" "transitive subclass 3" - ::errorCheck [E info heritage] "::D ::C ::xotcl::Object ::oo::object" "heritage" + ::errorCheck [E info heritage] "::D ::C ::xotcl::Object" "heritage" ::errorCheck [E info instargs t] "a b c" "instargs" ::errorCheck [E info instdefault t c x] 1 "instdefault" ::errorCheck [E info args p] "a b c" "args" @@ -3301,9 +3301,9 @@ ::errorCheck [catch {X class Object}] 1 "turn class into an object (error)" Class Y -superclass X Object o1 -mixin Y - ::errorCheck [o1 info precedence] "::Y ::X ::xotcl::Object ::oo::object" "normal mixin precedence" + ::errorCheck [o1 info precedence] "::Y ::X ::xotcl::Object" "normal mixin precedence" Object X ;# turn class X into Object X (via destroy/create) - ::errorCheck [o1 info precedence] "::Y ::xotcl::Object ::oo::object" "reduced mixin precedence" + ::errorCheck [o1 info precedence] "::Y ::xotcl::Object" "reduced mixin precedence" X destroy Y destroy o1 destroy @@ -3347,11 +3347,11 @@ D instmixin D1 D d1 - ::errorCheck [d1 info precedence] "::D1 ::D ::C ::xotcl::Object ::oo::object" "d1 info precedence" - ::errorCheck [d1 info precedence *] "::D1 ::D ::C ::xotcl::Object ::oo::object" "d1 info precedence *" + ::errorCheck [d1 info precedence] "::D1 ::D ::C ::xotcl::Object" "d1 info precedence" + ::errorCheck [d1 info precedence *] "::D1 ::D ::C ::xotcl::Object" "d1 info precedence *" ::errorCheck [d1 info precedence ::D*] "::D1 ::D" "d1 info precedence pattern" - ::errorCheck [d1 info precedence -intrinsic] "::D ::C ::xotcl::Object ::oo::object" "d1 info precedence -intrinsic" - ::errorCheck [d1 info precedence -intrinsic *] "::D ::C ::xotcl::Object ::oo::object" "d1 info precedence -intrinsic *" + ::errorCheck [d1 info precedence -intrinsic] "::D ::C ::xotcl::Object" "d1 info precedence -intrinsic" + ::errorCheck [d1 info precedence -intrinsic *] "::D ::C ::xotcl::Object" "d1 info precedence -intrinsic *" ::errorCheck [d1 info precedence -intrinsic ::D*] "::D" "d1 info precedence -intrinsic pattern" d1 destroy