Index: generic/gentclAPI.decls =================================================================== diff -u -r1f1067f1a36bee1c928bb28c5284f53bf422c6dd -r25b538dc2ef31223ad89edf12c3f6e60201049a8 --- generic/gentclAPI.decls (.../gentclAPI.decls) (revision 1f1067f1a36bee1c928bb28c5284f53bf422c6dd) +++ generic/gentclAPI.decls (.../gentclAPI.decls) (revision 25b538dc2ef31223ad89edf12c3f6e60201049a8) @@ -36,6 +36,7 @@ xotclCmd createobjectsystem XOTclCreateObjectSystemCmd { {-argName "rootClass" -required 1 -type tclobj} {-argName "rootMetaClass" -required 1 -type tclobj} + {-argName "systemMethods" -required 0 -type tclobj} } xotclCmd deprecated XOTclDeprecatedCmd { {-argName "what" -required 1} Index: generic/predefined.h =================================================================== diff -u -r7b269f76914972e68ebdd5d419f543793bb01c51 -r25b538dc2ef31223ad89edf12c3f6e60201049a8 --- generic/predefined.h (.../predefined.h) (revision 7b269f76914972e68ebdd5d419f543793bb01c51) +++ generic/predefined.h (.../predefined.h) (revision 25b538dc2ef31223ad89edf12c3f6e60201049a8) @@ -3,7 +3,12 @@ "set bootstrap 1}\n" "namespace eval xotcl2 {\n" "namespace path ::xotcl\n" -"::xotcl::createobjectsystem ::xotcl2::Object ::xotcl2::Class\n" +"::xotcl::createobjectsystem ::xotcl2::Object ::xotcl2::Class {\n" +"-alloc alloc -configure configure -create create\n" +"-defaultmethod defaultmethod -destroy destroy -dealloc dealloc\n" +"-init init -move move -objectparameter objectparameter\n" +"-recreate recreate -residualargs residualargs -unknown unknown\n" +"-__unknown __unknown}\n" "foreach cmd [info command ::xotcl::cmd::Object::*] {\n" "set cmdName [namespace tail $cmd]\n" "if {$cmdName in [list \"instvar\"]} continue\n" Index: generic/predefined.xotcl =================================================================== diff -u -r7b269f76914972e68ebdd5d419f543793bb01c51 -r25b538dc2ef31223ad89edf12c3f6e60201049a8 --- generic/predefined.xotcl (.../predefined.xotcl) (revision 7b269f76914972e68ebdd5d419f543793bb01c51) +++ generic/predefined.xotcl (.../predefined.xotcl) (revision 25b538dc2ef31223ad89edf12c3f6e60201049a8) @@ -12,7 +12,13 @@ namespace eval xotcl2 { namespace path ::xotcl - ::xotcl::createobjectsystem ::xotcl2::Object ::xotcl2::Class + ::xotcl::createobjectsystem ::xotcl2::Object ::xotcl2::Class { + -alloc alloc -configure configure -create create + -defaultmethod defaultmethod -destroy destroy -dealloc dealloc + -init init -move move -objectparameter objectparameter + -recreate recreate -residualargs residualargs -unknown unknown + -__unknown __unknown + } # provide the standard command set for ::xotcl2::Object foreach cmd [info command ::xotcl::cmd::Object::*] { Index: generic/tclAPI.h =================================================================== diff -u -r66c24900b6a07a0cac4a28251c492bd3a05ec8e7 -r25b538dc2ef31223ad89edf12c3f6e60201049a8 --- generic/tclAPI.h (.../tclAPI.h) (revision 66c24900b6a07a0cac4a28251c492bd3a05ec8e7) +++ generic/tclAPI.h (.../tclAPI.h) (revision 25b538dc2ef31223ad89edf12c3f6e60201049a8) @@ -284,7 +284,7 @@ static int XOTclAssertionCmd(Tcl_Interp *interp, XOTclObject *object, int assertionsubcmd, Tcl_Obj *arg); static int XOTclColonCmd(Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]); static int XOTclConfigureCmd(Tcl_Interp *interp, int configureoption, Tcl_Obj *value); -static int XOTclCreateObjectSystemCmd(Tcl_Interp *interp, Tcl_Obj *rootClass, Tcl_Obj *rootMetaClass); +static int XOTclCreateObjectSystemCmd(Tcl_Interp *interp, Tcl_Obj *rootClass, Tcl_Obj *rootMetaClass, Tcl_Obj *systemMethods); static int XOTclCurrentCmd(Tcl_Interp *interp, int currentoption); static int XOTclDeprecatedCmd(Tcl_Interp *interp, CONST char *what, CONST char *oldCmd, CONST char *newCmd); static int XOTclDispatchCmd(Tcl_Interp *interp, XOTclObject *object, int withObjscope, Tcl_Obj *command, int nobjc, Tcl_Obj *CONST nobjv[]); @@ -1548,9 +1548,10 @@ } else { Tcl_Obj *rootClass = (Tcl_Obj *)pc.clientData[0]; Tcl_Obj *rootMetaClass = (Tcl_Obj *)pc.clientData[1]; + Tcl_Obj *systemMethods = (Tcl_Obj *)pc.clientData[2]; parseContextRelease(&pc); - return XOTclCreateObjectSystemCmd(interp, rootClass, rootMetaClass); + return XOTclCreateObjectSystemCmd(interp, rootClass, rootMetaClass, systemMethods); } } @@ -2223,9 +2224,10 @@ {"configureoption", 1, 0, convertToConfigureoption}, {"value", 0, 0, convertToTclobj}} }, -{"::xotcl::createobjectsystem", XOTclCreateObjectSystemCmdStub, 2, { +{"::xotcl::createobjectsystem", XOTclCreateObjectSystemCmdStub, 3, { {"rootClass", 1, 0, convertToTclobj}, - {"rootMetaClass", 1, 0, convertToTclobj}} + {"rootMetaClass", 1, 0, convertToTclobj}, + {"systemMethods", 0, 0, convertToTclobj}} }, {"::xotcl::current", XOTclCurrentCmdStub, 1, { {"currentoption", 0, 0, convertToCurrentoption}} Index: generic/xotcl.c =================================================================== diff -u -rf51bd5a29fc392a741fdf61589e43c5cb5755c28 -r25b538dc2ef31223ad89edf12c3f6e60201049a8 --- generic/xotcl.c (.../xotcl.c) (revision f51bd5a29fc392a741fdf61589e43c5cb5755c28) +++ generic/xotcl.c (.../xotcl.c) (revision 25b538dc2ef31223ad89edf12c3f6e60201049a8) @@ -10929,18 +10929,74 @@ return TCL_OK; } +static void ObjectSystemFree(XOTclObjectSystem *osPtr) { + int i; + for (i=0; i<=XO___unknown_idx; i++) { + Tcl_Obj *methodObj = osPtr->methods[i]; + /*fprintf(stderr, "check %d: %p\n", i, methodObj);*/ + if (methodObj) { + /*fprintf(stderr, "ObjectSystemFree %p %s refCount %d\n", + methodObj, ObjStr(methodObj), methodObj->refCount);*/ + DECR_REF_COUNT(methodObj); + } + } + FREE(XOTclObjectSystem *, osPtr); +} + /* xotclCmd createobjectsystem XOTclCreateObjectSystemCmd { {-argName "rootClass" -required 1 -type tclobj} {-argName "rootMetaClass" -required 1 -type tclobj} + {-argName "systemMethods" -required 0 -type tclobj} } */ static int -XOTclCreateObjectSystemCmd(Tcl_Interp *interp, Tcl_Obj *Object, Tcl_Obj *Class) { +XOTclCreateObjectSystemCmd(Tcl_Interp *interp, Tcl_Obj *Object, Tcl_Obj *Class, Tcl_Obj *systemMethodsObj) { XOTclClass *theobj; XOTclClass *thecls; + XOTclObjectSystem *osPtr = NEW(XOTclObjectSystem); + static CONST char *opts[] = {"-alloc", "-cleanup", "-configure", "-create", + "-defaultmethod", "-destroy", "-dealloc", + "-init", "-move", "-objectparameter", + "-recreate", "-residualargs", + "-unknown", "-__unknown", + NULL}; + + + memset(osPtr, 0, sizeof(XOTclObjectSystem)); + + if (systemMethodsObj) { + int oc, i, idx, result; + Tcl_Obj **ov; + + if ((result = Tcl_ListObjGetElements(interp, systemMethodsObj, &oc, &ov)) == TCL_OK) { + if (oc % 2) { + ObjectSystemFree(osPtr); + return XOTclErrMsg(interp, "System methods must be provided as pairs", TCL_STATIC); + } + for (i=0; imethods[idx] = ov[i+1]; + INCR_REF_COUNT(osPtr->methods[idx]); + } + } else { + ObjectSystemFree(osPtr); + return XOTclErrMsg(interp, "Provided system methods are not a proper list", TCL_STATIC); + } + /*xxxx*/ + } + /* TODO remove me, just for developing */ + ObjectSystemFree(osPtr); + /* 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 */ Index: generic/xotclInt.h =================================================================== diff -u -r11d5a8a7fab7ba69a94b161bb9c0aae5a2636e7b -r25b538dc2ef31223ad89edf12c3f6e60201049a8 --- generic/xotclInt.h (.../xotclInt.h) (revision 11d5a8a7fab7ba69a94b161bb9c0aae5a2636e7b) +++ generic/xotclInt.h (.../xotclInt.h) (revision 25b538dc2ef31223ad89edf12c3f6e60201049a8) @@ -503,6 +503,24 @@ struct XOTclClasses *nextPtr; } XOTclClasses; +typedef enum SystemMethodsIdx { + XO_alloc_idx, XO_cleanup_idx, XO_configure_idx, XO_create_idx, + XO_defaultmethod_idx, XO_destroy_idx, XO_dealloc_idx, + XO_init_idx, XO_move_idx, XO_objectparameter_idx, + XO_recreate_idx, XO_residualargs_idx, + XO_unknown_idx, XO___unknown_idx +} SystemMethodsIdx; + +typedef struct XOTclObjectSystem { + XOTclClass *rootClass; + XOTclClass *rootMetaClass; + Tcl_Obj *methods[XO___unknown_idx+1]; + struct XOTclObjectSystem *nextPtr; +} XOTclObjectSystem; + + + + /* XOTcl global names and strings */ /* these are names and contents for global (corresponding) Tcl_Objs and Strings - otherwise these "constants" would have to be built