Index: generic/predefined.h =================================================================== diff -u -r8cd07ec2847e5ccff9f486950459d72a4d497e8b -rfd82d80829200a3928e29cdfc0d19df6222a9267 --- generic/predefined.h (.../predefined.h) (revision 8cd07ec2847e5ccff9f486950459d72a4d497e8b) +++ generic/predefined.h (.../predefined.h) (revision fd82d80829200a3928e29cdfc0d19df6222a9267) @@ -10,7 +10,12 @@ "::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 {::oo::class ::xotcl::Object}\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" "set bootstrap 1\n" Index: generic/predefined.xotcl =================================================================== diff -u -r8cd07ec2847e5ccff9f486950459d72a4d497e8b -rfd82d80829200a3928e29cdfc0d19df6222a9267 --- generic/predefined.xotcl (.../predefined.xotcl) (revision 8cd07ec2847e5ccff9f486950459d72a4d497e8b) +++ generic/predefined.xotcl (.../predefined.xotcl) (revision fd82d80829200a3928e29cdfc0d19df6222a9267) @@ -11,6 +11,7 @@ # "destroy" and "instdestroy" are only defined on these # objects. So, we register these on ::oo::object and ::oo::class # for the time being, since these two classes are deleted last. + # ::xotcl::alias ::oo::object destroy ::xotcl::cmd::Object::destroy ::xotcl::alias ::oo::class instdestroy ::xotcl::cmd::Class::instdestroy # @@ -23,10 +24,23 @@ # ::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]" +# } +# } # # ... and define the superclass and class relations on these. # - ::xotcl::relation ::xotcl::Class superclass {::oo::class ::xotcl::Object} + ::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 } @@ -65,6 +79,12 @@ ######################## ::xotcl::Object create ::xotcl::objectInfo ::xotcl::Object create ::xotcl::classInfo + + #foreach o {::xotcl::objectInfo ::xotcl::classInfo} { + # foreach r {object class metaclass} { + # puts stderr "$o $r=[::xotcl::is $o $r]" + # } + #} foreach cmd [info command ::xotcl::cmd::ObjectInfo::*] { ::xotcl::alias ::xotcl::objectInfo [namespace tail $cmd] $cmd ::xotcl::alias ::xotcl::classInfo [namespace tail $cmd] $cmd @@ -128,15 +148,22 @@ ################## # still bootstrap code; we cannot use slots/-parameter yet ::xotcl::Class create ::xotcl::MetaSlot - ::xotcl::relation ::xotcl::MetaSlot superclass ::xotcl::Class + ::xotcl::MetaSlot instproc new args { set slotobject [::xotcl::self callingobject]::slot if {![::xotcl::is $slotobject object]} {::xotcl::Object create $slotobject} eval next -childof $slotobject $args } + ::xotcl::MetaSlot create ::xotcl::Slot + #foreach o {::xotcl::MetaSlot ::xotcl::Slot} { + # foreach r {object class metaclass} { + # puts stderr "$o $r=[::xotcl::is $o $r]" + # } + #} + # use low level interface for defining slot values. Normally, this is # done via slot objects, which are defined later. Index: generic/xotcl.c =================================================================== diff -u -r072e1c7c091c1370fc2fe26f66acf7a7cbd4a66f -rfd82d80829200a3928e29cdfc0d19df6222a9267 --- generic/xotcl.c (.../xotcl.c) (revision 072e1c7c091c1370fc2fe26f66acf7a7cbd4a66f) +++ generic/xotcl.c (.../xotcl.c) (revision fd82d80829200a3928e29cdfc0d19df6222a9267) @@ -97,7 +97,7 @@ static int GuardCheck(Tcl_Interp *interp, Tcl_Obj *guards); static int GuardCall(XOTclObject *obj, XOTclClass *cl, Tcl_Command cmd, Tcl_Interp *interp, Tcl_Obj *guard, int push); static void GuardDel(XOTclCmdList *filterCL); -static int IsMetaClass(Tcl_Interp *interp, XOTclClass *cl); +static int IsMetaClass(Tcl_Interp *interp, XOTclClass *cl, int withMixins); static int hasMixin(Tcl_Interp *interp, XOTclObject *obj, XOTclClass *cl); static int isSubType(XOTclClass *subcl, XOTclClass *cl); static int setInstVar(Tcl_Interp *interp, XOTclObject *obj, Tcl_Obj *name, Tcl_Obj *value); @@ -8144,7 +8144,7 @@ We do not have to reclassing in case, cl == ::xotcl::Object */ if (cl != theobj) { - XOTclClass *baseClass = IsMetaClass(interp, cl) ? + XOTclClass *baseClass = IsMetaClass(interp, cl, 1) ? DefaultSuperClass(interp, cl, cl->object.cl, RUNTIME_STATE(interp)->theClass, 1) : defaultClass; @@ -8408,16 +8408,16 @@ /*fprintf(stderr,"changing %s to class %s ismeta %d\n", objectName(obj), className(cl), - IsMetaClass(interp, cl));*/ + IsMetaClass(interp, cl, 1));*/ if (cl != obj->cl) { - if (IsMetaClass(interp, cl)) { + if (IsMetaClass(interp, cl, 1)) { /* Do not allow upgrading from a class to a meta-class (in other words, don't make an object to a class). To allow this, it would be necessary to reallocate the base structures. */ - if (!IsMetaClass(interp, obj->cl)) { + if (!IsMetaClass(interp, obj->cl, 1)) { return XOTclVarErrMsg(interp, "cannot turn object into a class", (char *) NULL); } @@ -8716,42 +8716,54 @@ return TCL_OK; } +static int +hasMetaProperty(Tcl_Interp *interp, XOTclClass *cl) { + return (cl->object.flags & XOTCL_IS_METACLASS) || (cl == RUNTIME_STATE(interp)->theClass); +} + static int -IsMetaClass(Tcl_Interp *interp, XOTclClass *cl) { - /* check if cl is a meta-class by checking is Class is a superclass of cl*/ +IsMetaClass(Tcl_Interp *interp, XOTclClass *cl, int withMixins) { + /* check if class is a meta-class */ XOTclClasses *pl, *checkList = NULL, *mixinClasses = NULL, *mc; int hasMCM = 0; - if (cl == RUNTIME_STATE(interp)->theClass) + /* is the class the most general meta-class? */ + if (hasMetaProperty(interp, cl)) return 1; - + + /* is the class a subclass of a meta-class? */ for (pl = ComputeOrder(cl, cl->order, Super); pl; pl = pl->nextPtr) { - if (pl->cl == RUNTIME_STATE(interp)->theClass) + if (hasMetaProperty(interp, pl->cl)) return 1; } - for (pl = ComputeOrder(cl, cl->order, Super); pl; pl = pl->nextPtr) { - XOTclClassOpt *clopt = pl->cl->opt; - if (clopt && clopt->instmixins) { - MixinComputeOrderFullList(interp, - &clopt->instmixins, - &mixinClasses, - &checkList, 0); + if (withMixins) { + /* has the class metaclass mixed in? */ + for (pl = ComputeOrder(cl, cl->order, Super); pl; pl = pl->nextPtr) { + XOTclClassOpt *clopt = pl->cl->opt; + if (clopt && clopt->instmixins) { + MixinComputeOrderFullList(interp, + &clopt->instmixins, + &mixinClasses, + &checkList, 0); + } } - } - - for (mc=mixinClasses; mc; mc = mc->nextPtr) { - /*fprintf(stderr,"- got %s\n", className(mc->cl));*/ - if (isSubType(mc->cl, RUNTIME_STATE(interp)->theClass)) { - hasMCM = 1; - break; + + /* TODO: should be a class of isMetaClass, or? */ + for (mc=mixinClasses; mc; mc = mc->nextPtr) { + /*fprintf(stderr,"- got %s\n", className(mc->cl));*/ + /*if (isSubType(mc->cl, RUNTIME_STATE(interp)->theClass)) {*/ + if (IsMetaClass(interp, mc->cl, 0)) { + hasMCM = 1; + break; + } } - } - XOTclClassListFree(mixinClasses); - XOTclClassListFree(checkList); - /*fprintf(stderr,"has MC returns %d, mixinClasses = %p\n", - hasMCM, mixinClasses);*/ - + XOTclClassListFree(mixinClasses); + XOTclClassListFree(checkList); + /*fprintf(stderr,"has MC returns %d, mixinClasses = %p\n", + hasMCM, mixinClasses);*/ + } + return hasMCM; } @@ -8767,7 +8779,7 @@ if (XOTclObjConvertObject(interp, className, &o) == TCL_OK && XOTclObjectIsClass(o) - && IsMetaClass(interp, (XOTclClass*)o)) { + && IsMetaClass(interp, (XOTclClass*)o, 1)) { Tcl_SetIntObj(Tcl_GetObjResult(interp), 1); } else { Tcl_SetIntObj(Tcl_GetObjResult(interp), 0); @@ -8854,7 +8866,7 @@ success = (XOTclObjConvertObject(interp, objv[1], &obj) == TCL_OK && XOTclObjectIsClass(obj) - && IsMetaClass(interp, (XOTclClass*)obj)); + && IsMetaClass(interp, (XOTclClass*)obj, 1)); break; case mixinIdx: @@ -10836,13 +10848,13 @@ static CONST char *opts[] = { "mixin", "instmixin", "object-mixin", "class-mixin", "filter", "instfilter", "object-filter", "class-filter", - "class", "superclass", + "class", "superclass", "metaclass", NULL }; enum subCmdIdx { mixinIdx, instmixinIdx, pomIdx, pcmIdx, filterIdx, instfilterIdx, pofIdx, pcfIdx, - classIdx, superclassIdx + classIdx, superclassIdx, metaclassIdx }; if (objc < 3 || objc > 4) @@ -10915,6 +10927,15 @@ GetXOTclClassFromObj(interp, objv[3], &cl, obj->cl); if (!cl) return XOTclErrBadVal(interp, "class", "a class", ObjStr(objv[1])); return changeClass(interp, obj, cl); + + case metaclassIdx: + GetXOTclClassFromObj(interp, objv[1], &cl, 0); + if (!cl) return XOTclObjErrType(interp, objv[1], "Class"); + cl->object.flags |= XOTCL_IS_METACLASS; + /* todo: + how to remove metaclass property? + problems with deletion order? + */ } switch (opt) { @@ -11535,9 +11556,9 @@ } /*fprintf(stderr," **** name is '%s', isMetaClass => %d\n", - objName, IsMetaClass(interp, cl));*/ + objName, IsMetaClass(interp, cl, 1));*/ - if (IsMetaClass(interp, cl)) { + if (IsMetaClass(interp, cl, 1)) { /* * if the base class is a meta-class, we create a class */ @@ -11606,9 +11627,9 @@ /*fprintf(stderr,"+++ create objv[1] '%s', specifiedName '%s', newObj=%p ismeta(%s) %d, ismeta(%s) %d\n", specifiedName, objName, newobj, - className(cl), IsMetaClass(interp, cl), + className(cl), IsMetaClass(interp, cl, 1), newobj ? ObjStr(newobj->cl->object.cmdName) : "NULL", - newobj ? IsMetaClass(interp, newobj->cl) : 0 + newobj ? IsMetaClass(interp, newobj->cl, 1) : 0 );*/ /* don't allow to @@ -11618,7 +11639,7 @@ In these clases, we use destroy + create instead of recrate. */ - if (newobj && (IsMetaClass(interp, cl) == IsMetaClass(interp, newobj->cl))) { + if (newobj && (IsMetaClass(interp, cl, 1) == IsMetaClass(interp, newobj->cl, 1))) { /*fprintf(stderr, "%%%% recreate, call recreate method ... %s, objc=%d\n", ObjStr(tov[1]), objc+1);*/ Index: generic/xotclInt.h =================================================================== diff -u -r98003953e8c728b105528e0c2ed7d67ee7135d64 -rfd82d80829200a3928e29cdfc0d19df6222a9267 --- generic/xotclInt.h (.../xotclInt.h) (revision 98003953e8c728b105528e0c2ed7d67ee7135d64) +++ generic/xotclInt.h (.../xotclInt.h) (revision fd82d80829200a3928e29cdfc0d19df6222a9267) @@ -443,11 +443,12 @@ #define XOTCL_FILTER_ORDER_DEFINED_AND_VALID 0x0030 /* IS_CLASS set, when object is a class */ #define XOTCL_IS_CLASS 0x0040 +#define XOTCL_IS_METACLASS 0x0080 /* DESTROYED set, when object is physically destroyed with PrimitiveODestroy */ -#define XOTCL_DESTROYED 0x0080 -#define XOTCL_REFCOUNTED 0x0100 -#define XOTCL_RECREATE 0x0200 -#define XOTCL_NS_DESTROYED 0x0400 +#define XOTCL_DESTROYED 0x0100 +#define XOTCL_REFCOUNTED 0x0200 +#define XOTCL_RECREATE 0x0400 +#define XOTCL_NS_DESTROYED 0x0800 #define XOTclObjectSetClass(obj) \ (obj)->flags |= XOTCL_IS_CLASS