Index: ChangeLog =================================================================== diff -u -r4eafc074cdca60b0089c2a950954c83d519b91d3 -r8cd07ec2847e5ccff9f486950459d72a4d497e8b --- ChangeLog (.../ChangeLog) (revision 4eafc074cdca60b0089c2a950954c83d519b91d3) +++ ChangeLog (.../ChangeLog) (revision 8cd07ec2847e5ccff9f486950459d72a4d497e8b) @@ -33,6 +33,11 @@ C c1 ;# c1 has no no default value for "a", before it had ====== +2009-06-22 + - define default meta-class for ::xotcl::Class + - use default meta-class, when a the topmost meta-class of an + object system is deleted + 2009-06-14 - fixed potential access to deleted command list item in FilterSearchAgain() Index: generic/predefined.h =================================================================== diff -u -r4eafc074cdca60b0089c2a950954c83d519b91d3 -r8cd07ec2847e5ccff9f486950459d72a4d497e8b --- generic/predefined.h (.../predefined.h) (revision 4eafc074cdca60b0089c2a950954c83d519b91d3) +++ generic/predefined.h (.../predefined.h) (revision 8cd07ec2847e5ccff9f486950459d72a4d497e8b) @@ -91,7 +91,8 @@ "if {![$i exists $att]} {::xotcl::setinstvar $i $att $default}}\n" "unset default}}}\n" "createBootstrapAttributeSlots ::xotcl::Class {\n" -"{__default_superclass ::xotcl::Object}}\n" +"{__default_superclass ::xotcl::Object}\n" +"{__default_metaclass ::xotcl::Class}}\n" "createBootstrapAttributeSlots ::xotcl::Slot {\n" "{name \"[namespace tail [::xotcl::self]]\"}\n" "{domain \"[lindex [regexp -inline {^(.*)::slot::[^:]+$} [::xotcl::self]] 1]\"}\n" @@ -202,7 +203,6 @@ "::xotcl::Attribute instproc mk_type_checker {} {\n" "set __initcmd \"\"\n" "if {[::xotcl::my exists type]} {\n" -"puts stderr \"mktypechecker, type=$type\"\n" "::xotcl::my instvar type name\n" "if {[::xotcl::Object isclass $type]} {\n" "set predicate [subst -nocommands {\n" Index: generic/predefined.xotcl =================================================================== diff -u -r4eafc074cdca60b0089c2a950954c83d519b91d3 -r8cd07ec2847e5ccff9f486950459d72a4d497e8b --- generic/predefined.xotcl (.../predefined.xotcl) (revision 4eafc074cdca60b0089c2a950954c83d519b91d3) +++ generic/predefined.xotcl (.../predefined.xotcl) (revision 8cd07ec2847e5ccff9f486950459d72a4d497e8b) @@ -172,6 +172,7 @@ # object systems might co-exist. createBootstrapAttributeSlots ::xotcl::Class { {__default_superclass ::xotcl::Object} + {__default_metaclass ::xotcl::Class} } # Index: generic/xotcl.c =================================================================== diff -u -r4eafc074cdca60b0089c2a950954c83d519b91d3 -r8cd07ec2847e5ccff9f486950459d72a4d497e8b --- generic/xotcl.c (.../xotcl.c) (revision 4eafc074cdca60b0089c2a950954c83d519b91d3) +++ generic/xotcl.c (.../xotcl.c) (revision 8cd07ec2847e5ccff9f486950459d72a4d497e8b) @@ -8011,7 +8011,6 @@ XOTclObject *obj = (XOTclObject*)ckalloc(sizeof(XOTclObject)); unsigned length; - /*fprintf(stderr, "CKALLOC Object %p %s\n", obj, name);*/ #if defined(XOTCLOBJ_TRACE) fprintf(stderr, "CKALLOC Object %p %s\n", obj, name); #endif @@ -8050,17 +8049,21 @@ } static XOTclClass * -DefaultSuperClass(Tcl_Interp *interp, XOTclClass *cl, XOTclClass *mcl, XOTclClass *topcl) { +DefaultSuperClass(Tcl_Interp *interp, XOTclClass *cl, XOTclClass *mcl, XOTclClass *topcl, int isMeta) { XOTclClass *defaultClass = topcl; - /*fprintf(stderr, "DefaultSuperClass cl %s, mcl %s\n", + /* + fprintf(stderr, "DefaultSuperClass cl %s, mcl %s\n", ObjStr(cl->object.cmdName), mcl ? ObjStr(mcl->object.cmdName) : "NULL" - );*/ + ); + */ + if (mcl) { int result; - result = setInstVar(interp, (XOTclObject *)mcl, - XOTclGlobalObjects[XOTE_DEFAULTSUPERCLASS], NULL); + result = setInstVar(interp, (XOTclObject *)mcl, isMeta ? + XOTclGlobalObjects[XOTE_DEFAULTMETACLASS] : + XOTclGlobalObjects[XOTE_DEFAULTSUPERCLASS], NULL); if (result == TCL_OK) { Tcl_Obj *nameObj = Tcl_GetObjResult(interp); @@ -8070,8 +8073,7 @@ /* fprintf(stderr, "DefaultSuperClass got from var %s\n",ObjStr(nameObj));*/ } else { - Tcl_Obj *bootstrap = Tcl_GetVar2Ex(interp, "::xotcl::bootstrap", NULL, - TCL_GLOBAL_ONLY); + Tcl_Obj *bootstrap = Tcl_GetVar2Ex(interp, "::xotcl::bootstrap", NULL, TCL_GLOBAL_ONLY); if (bootstrap) { Tcl_Obj *nameObj = Tcl_NewStringObj("::xotcl::Object", -1); INCR_REF_COUNT(nameObj); @@ -8086,7 +8088,7 @@ /*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",ObjStr(sc->cl->object.cmdName));*/ - result = DefaultSuperClass(interp, cl, sc->cl, topcl); + result = DefaultSuperClass(interp, cl, sc->cl, topcl, isMeta); if (result != topcl) { return result; } @@ -8114,8 +8116,8 @@ assert(softrecreate? recreate == 1 : 1); - /* fprintf(stderr, "CleanupDestroyClass softrecreate=%d,recreate=%d, %p\n", - softrecreate,recreate,clopt); */ + /*fprintf(stderr, "CleanupDestroyClass softrecreate=%d,recreate=%d, %p\n", + softrecreate,recreate,clopt); */ /* do this even with no clopt, since the class might be used as a superclass of a per object mixin, so it has no clopt... @@ -8165,7 +8167,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); + defaultClass = DefaultSuperClass(interp, cl, cl->object.cl, RUNTIME_STATE(interp)->theObject, 0); /* Reclass all instances of the current class the the appropriate most general class ("baseClass"). The most general class of a @@ -8178,14 +8180,19 @@ We do not have to reclassing in case, cl == ::xotcl::Object */ if (cl != theobj) { - XOTclClass *baseClass = IsMetaClass(interp, cl) ? RUNTIME_STATE(interp)->theClass : defaultClass; + XOTclClass *baseClass = IsMetaClass(interp, cl) ? + DefaultSuperClass(interp, cl, cl->object.cl, RUNTIME_STATE(interp)->theClass, 1) + : defaultClass; + if (baseClass == cl) { /* 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; } + /* fprintf(stderr,"baseclass = %s\n",ObjStr(baseClass->object.cmdName));*/ + hPtr = &cl->instances ? Tcl_FirstHashEntry(&cl->instances, &hSrch) : 0; for (; hPtr; hPtr = Tcl_NextHashEntry(&hSrch)) { XOTclObject *inst = (XOTclObject*)Tcl_GetHashKey(&cl->instances, hPtr); @@ -8285,7 +8292,7 @@ cl->super = NULL; /* Look for a configured default superclass */ - defaultSuperclass = DefaultSuperClass(interp, cl, cl->object.cl, RUNTIME_STATE(interp)->theObject); + defaultSuperclass = DefaultSuperClass(interp, cl, cl->object.cl, RUNTIME_STATE(interp)->theObject, 0); /* if (defaultSuperclass) { fprintf(stderr, "default superclass= %s\n", ObjStr(defaultSuperclass->object.cmdName)); @@ -8433,7 +8440,12 @@ XOTCLINLINE static int changeClass(Tcl_Interp *interp, XOTclObject *obj, XOTclClass *cl) { assert(obj); - + + /*fprintf(stderr,"changing %s to class %s ismeta %d\n", + ObjStr(obj->cmdName), + ObjStr(cl->object.cmdName), + IsMetaClass(interp, cl));*/ + if (cl != obj->cl) { if (IsMetaClass(interp, cl)) { /* Do not allow upgrading from a class to a meta-class (in @@ -8478,6 +8490,7 @@ int destroyed = 0, result; XOTclCallStack *cs = &RUNTIME_STATE(interp)->cs; XOTclCallStackContent *csc; + /* * we check whether the object to be re-created is destroyed or not */ @@ -8487,8 +8500,9 @@ } } - if (destroyed) + if (destroyed) { UndestroyObj(interp, newobj); + } /* * re-create, first ensure correct class for newobj @@ -11726,7 +11740,6 @@ /* fprintf(stderr,"instdestroy obj=%s, opt=%p\n", ObjStr(delobj->cmdName), delobj->opt);*/ rc = freeUnsetTraceVariable(interp, delobj); - rc = freeUnsetTraceVariable(interp, delobj); if (rc != TCL_OK) { return rc; } @@ -11854,18 +11867,20 @@ INCR_REF_COUNT(tmpName); } - /*fprintf(stderr," **** name is '%s', isMetaClass => %d\n", objName, IsMetaClass(interp, cl));*/ + /*fprintf(stderr," **** name is '%s', isMetaClass => %d\n", + objName, IsMetaClass(interp, cl));*/ + if (IsMetaClass(interp, cl)) { /* * if the base class is a meta-class, we create a class */ newcl = PrimitiveCCreate(interp, objName, cl); - if (newcl == 0) + if (newcl == 0) { result = XOTclVarErrMsg(interp, "Class alloc failed for '", objName, "' (possibly parent namespace does not exist)", (char *) NULL); - else { + } else { Tcl_SetObjResult(interp, newcl->object.cmdName); result = TCL_OK; } @@ -11923,8 +11938,12 @@ */ newobj = XOTclpGetObject(interp, objName); - /*fprintf(stderr,"+++ create objv[1] '%s', specifiedName '%s', newObj=%p\n", - specifiedName, objName, newobj);*/ + /*fprintf(stderr,"+++ create objv[1] '%s', specifiedName '%s', newObj=%p ismeta(%s) %d, ismeta(%s) %d\n", + specifiedName, objName, newobj, + ObjStr(cl->object.cmdName), IsMetaClass(interp, cl), + newobj ? ObjStr(newobj->cl->object.cmdName) : "NULL", + newobj ? IsMetaClass(interp, newobj->cl) : 0 + );*/ /* don't allow to - recreate an object as a class, and to @@ -11934,8 +11953,10 @@ */ if (newobj && (IsMetaClass(interp, cl) == IsMetaClass(interp, newobj->cl))) { + /*fprintf(stderr, "%%%% recreate, call recreate method ... %s, objc=%d\n", ObjStr(tov[1]), objc+1);*/ + /* call recreate --> initialization */ result = callMethod((ClientData) obj, interp, XOTclGlobalObjects[XOTE_RECREATE], objc+1, tov+1, 0); @@ -11953,7 +11974,7 @@ result = XOTclVarErrMsg(interp, "Cannot create object -- illegal name '", specifiedName, "'", (char *) NULL); - /* fprintf(stderr, "alloc ... %s\n", ObjStr(tov[1]));*/ + /*fprintf(stderr, "alloc ... %s\n", ObjStr(tov[1]));*/ result = callMethod((ClientData) obj, interp, XOTclGlobalObjects[XOTE_ALLOC], objc+1, tov+1, 0); if (result != TCL_OK) Index: generic/xotclInt.h =================================================================== diff -u -r2111020b49da8ce57758e51accf0b6073037f0d2 -r8cd07ec2847e5ccff9f486950459d72a4d497e8b --- generic/xotclInt.h (.../xotclInt.h) (revision 2111020b49da8ce57758e51accf0b6073037f0d2) +++ generic/xotclInt.h (.../xotclInt.h) (revision 8cd07ec2847e5ccff9f486950459d72a4d497e8b) @@ -545,7 +545,7 @@ XOTE_ALLOC, XOTE_INIT, XOTE_INSTVAR, XOTE_INTERP, XOTE_AUTONAMES, XOTE_ZERO, XOTE_ONE, XOTE_MOVE, XOTE_SELF, XOTE_CLASS, XOTE_RECREATE, XOTE_SELF_CLASS, XOTE_SELF_PROC, - XOTE_EXIT_HANDLER, XOTE_DEFAULTSUPERCLASS, + XOTE_EXIT_HANDLER, XOTE_DEFAULTSUPERCLASS, XOTE_DEFAULTMETACLASS, XOTE_NON_POS_ARGS_OBJ, XOTE_SETVALUES, XOTE_CLEANUP, XOTE_CONFIGURE, XOTE_FILTER, XOTE_INSTFILTER, XOTE_INSTPROC, XOTE_PROC, XOTE_INSTFORWARD, XOTE_FORWARD, @@ -565,7 +565,7 @@ "alloc", "init", "instvar", "interp", "__autonames", "0", "1", "move", "self", "class", "recreate", "self class", "self proc", - "__exitHandler", "__default_superclass", + "__exitHandler", "__default_superclass", "__default_metaclass", "::xotcl::nonposArgs", "setvalues", "cleanup", "configure", "filter", "instfilter", "instproc", "proc", "instforward", "forward", Index: tests/object-system.xotcl =================================================================== diff -u -r4eafc074cdca60b0089c2a950954c83d519b91d3 -r8cd07ec2847e5ccff9f486950459d72a4d497e8b --- tests/object-system.xotcl (.../object-system.xotcl) (revision 4eafc074cdca60b0089c2a950954c83d519b91d3) +++ tests/object-system.xotcl (.../object-system.xotcl) (revision 8cd07ec2847e5ccff9f486950459d72a4d497e8b) @@ -38,7 +38,7 @@ ? {C0 ismetaclass} 0 ? {C0 info superclass} ::xotcl::Object ? {C0 info class} ::xotcl::Class -? {Class info vars} __default_superclass +? {lsort [Class info vars]} "__default_metaclass __default_superclass" Class M -superclass ::xotcl::Class ? {Object isobject M} 1 @@ -60,7 +60,21 @@ ? {c1 ismetaclass} 0 ? {c1 info class} ::C +# destroy meta-class M, reclass meta-class instances to the base meta-class +M destroy +? {Object isobject C} 1 +? {C isclass} 1 +? {C ismetaclass} 0 +? {C info superclass} ::xotcl::Object +? {C info class} ::xotcl::Class +# destroy class M, reclass class instances to the base class +C destroy +? {Object isobject c1} 1 +? {c1 isclass} 0 +? {c1 ismetaclass} 0 +? {c1 info class} ::xotcl::Object + # basic parameter tests Class C -parameter {{x 1} {y 2}} Index: tests/testx.xotcl =================================================================== diff -u -r4eafc074cdca60b0089c2a950954c83d519b91d3 -r8cd07ec2847e5ccff9f486950459d72a4d497e8b --- tests/testx.xotcl (.../testx.xotcl) (revision 4eafc074cdca60b0089c2a950954c83d519b91d3) +++ tests/testx.xotcl (.../testx.xotcl) (revision 8cd07ec2847e5ccff9f486950459d72a4d497e8b) @@ -3323,10 +3323,8 @@ ::errorCheck [Object isclass m1] 1 "m1 is still a class" ::errorCheck [::xotcl::is m1 object] 1 "m1 is still an object" ::errorCheck [::xotcl::is m1 class] 1 "m1 is still a class" - ::errorCheck [::xotcl::relation m1 class] ::oo::class "m1 now a baseclass" - # actually, it should be ::xotcl::Class ::errorCheck [::xotcl::relation m1 class] ::xotcl::Class "m1 now a baseclass" - ::errorCheck [m1 info class] ::xotcl::Class "m1 is now an instance of Class" + ::errorCheck [m1 info class] ::xotcl::Class "m1 is now an instance of Class" ::errorCheck [m1 isclass] 1 "m1 is isclass 1" ::errorCheck [m1 info class] ::xotcl::Class "m1 is of class ::xotcl::Class" @@ -3349,10 +3347,10 @@ D instmixin D1 D d1 - ::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] "::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 ::D*] "::D1 ::D" "d1 info precedence pattern" - +puts stderr 1 ::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"