Index: ChangeLog =================================================================== diff -u -r1b27a533f020bd0c0334abd6b2e1ba02db1eae71 -r652147d4e1a22b381b2ca9e6354f52e1d8050c61 --- ChangeLog (.../ChangeLog) (revision 1b27a533f020bd0c0334abd6b2e1ba02db1eae71) +++ ChangeLog (.../ChangeLog) (revision 652147d4e1a22b381b2ca9e6354f52e1d8050c61) @@ -67,8 +67,8 @@ - removed compatibility for versions before Tcl 8.4 (was not tested anyhow) This version requires at least Tcl 8.4. - support for generating interface for ::xotcl commands - - generated interface for ::xotcl::alias - - from 15356 generic/xotcl.c => 13313 + - generated interface for ::xotcl::alias, ::xotcl::relation, ::xotcl::setinstvar + - from 15356 generic/xotcl.c => 13311 2009-07-01 - moved all definitions of method commands to generated code Index: generic/gentclAPI.decls =================================================================== diff -u -r1b27a533f020bd0c0334abd6b2e1ba02db1eae71 -r652147d4e1a22b381b2ca9e6354f52e1d8050c61 --- generic/gentclAPI.decls (.../gentclAPI.decls) (revision 1b27a533f020bd0c0334abd6b2e1ba02db1eae71) +++ generic/gentclAPI.decls (.../gentclAPI.decls) (revision 652147d4e1a22b381b2ca9e6354f52e1d8050c61) @@ -24,6 +24,16 @@ {-argName "-protected"} {-argName "cmdName" -required 1 -type tclobj} } +xotclCmd relation XOTclRelationCmd { + {-argName "object" -required 1 -type object} + {-argName "reltype" -required 1 -type tclobj} + {-argName "value" -required 0 -type tclobj} +} +xotclCmd setinstvar XOTclSetInstvarCmd { + {-argName "object" -required 1 -type object} + {-argName "variable" -required 1 -type tclobj} + {-argName "value" -required 0 -type tclobj} +} # # object methods # Index: generic/tclAPI.h =================================================================== diff -u -r1b27a533f020bd0c0334abd6b2e1ba02db1eae71 -r652147d4e1a22b381b2ca9e6354f52e1d8050c61 --- generic/tclAPI.h (.../tclAPI.h) (revision 1b27a533f020bd0c0334abd6b2e1ba02db1eae71) +++ generic/tclAPI.h (.../tclAPI.h) (revision 652147d4e1a22b381b2ca9e6354f52e1d8050c61) @@ -110,6 +110,8 @@ static int XOTclOVolatileMethodStub(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv []); static int XOTclOVwaitMethodStub(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv []); static int XOTclAliasCmdStub(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv []); +static int XOTclRelationCmdStub(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv []); +static int XOTclSetInstvarCmdStub(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv []); static int XOTclCheckBooleanArgs(Tcl_Interp *interp, char *name, Tcl_Obj *value); static int XOTclCheckRequiredArgs(Tcl_Interp *interp, char *name, Tcl_Obj *value); @@ -203,6 +205,8 @@ static int XOTclOVolatileMethod(Tcl_Interp *interp, XOTclObject *obj); static int XOTclOVwaitMethod(Tcl_Interp *interp, XOTclObject *obj, char *varname); static int XOTclAliasCmd(Tcl_Interp *interp, XOTclObject *object, char *methodName, int withObjscope, int withPer_object, int withProtected, Tcl_Obj *cmdName); +static int XOTclRelationCmd(Tcl_Interp *interp, XOTclObject *object, Tcl_Obj *reltype, Tcl_Obj *value); +static int XOTclSetInstvarCmd(Tcl_Interp *interp, XOTclObject *object, Tcl_Obj *variable, Tcl_Obj *value); enum { XOTclCheckBooleanArgsIdx, @@ -296,7 +300,9 @@ XOTclOUpvarMethodIdx, XOTclOVolatileMethodIdx, XOTclOVwaitMethodIdx, - XOTclAliasCmdIdx + XOTclAliasCmdIdx, + XOTclRelationCmdIdx, + XOTclSetInstvarCmdIdx } XOTclMethods; @@ -1816,6 +1822,38 @@ } } +static int +XOTclRelationCmdStub(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { + parseContext pc; + + if (parseObjv(interp, objc, objv, XOTclRelationCmdIdx, &pc) != TCL_OK) { + return TCL_ERROR; + } else { + XOTclObject *object = (XOTclObject *)pc.clientData[0]; + Tcl_Obj *reltype = (Tcl_Obj *)pc.clientData[1]; + Tcl_Obj *value = (Tcl_Obj *)pc.clientData[2]; + + return XOTclRelationCmd(interp, object, reltype, value); + + } +} + +static int +XOTclSetInstvarCmdStub(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { + parseContext pc; + + if (parseObjv(interp, objc, objv, XOTclSetInstvarCmdIdx, &pc) != TCL_OK) { + return TCL_ERROR; + } else { + XOTclObject *object = (XOTclObject *)pc.clientData[0]; + Tcl_Obj *variable = (Tcl_Obj *)pc.clientData[1]; + Tcl_Obj *value = (Tcl_Obj *)pc.clientData[2]; + + return XOTclSetInstvarCmd(interp, object, variable, value); + + } +} + static methodDefinition method_definitions[] = { {"::xotcl::cmd::NonposArgs::type=boolean", XOTclCheckBooleanArgsStub, { {"name", 1, 0, NULL}, @@ -2200,6 +2238,16 @@ {"-per-object", 0, 0, NULL}, {"-protected", 0, 0, NULL}, {"cmdName", 1, 0, "tclobj"}} +}, +{"::xotcl::relation", XOTclRelationCmdStub, { + {"object", 1, 0, "object"}, + {"reltype", 1, 0, "tclobj"}, + {"value", 0, 0, "tclobj"}} +}, +{"::xotcl::setinstvar", XOTclSetInstvarCmdStub, { + {"object", 1, 0, "object"}, + {"variable", 1, 0, "tclobj"}, + {"value", 0, 0, "tclobj"}} } }; Index: generic/xotcl.c =================================================================== diff -u -r1b27a533f020bd0c0334abd6b2e1ba02db1eae71 -r652147d4e1a22b381b2ca9e6354f52e1d8050c61 --- generic/xotcl.c (.../xotcl.c) (revision 1b27a533f020bd0c0334abd6b2e1ba02db1eae71) +++ generic/xotcl.c (.../xotcl.c) (revision 652147d4e1a22b381b2ca9e6354f52e1d8050c61) @@ -9195,59 +9195,7 @@ return result; } -static int XOTclAliasCmd(Tcl_Interp *interp, XOTclObject *object, char *methodName, - int withObjscope, int withPer_object, int withProtected, Tcl_Obj *cmdName) { - XOTclClass *cl; - Tcl_Command cmd, importedCmd; - Tcl_ObjCmdProc *objProc; - char allocation; - Tcl_CmdDeleteProc *dp = NULL; - aliasCmdClientData *tcd = NULL; - int flags = 0; - - if (XOTclObjectIsClass(object)) { - cl = (XOTclClass *)object; - allocation = 'c'; - } else { - cl = NULL; - allocation = 'o'; - } - cmd = Tcl_GetCommandFromObj(interp, cmdName); - if (cmd == NULL) - return XOTclVarErrMsg(interp, "cannot lookup command '", - ObjStr(cmdName), "'", (char *) NULL); - - if ((importedCmd = TclGetOriginalCommand(cmd))) { - cmd = importedCmd; - } - objProc = Tcl_Command_objProc(cmd); - if (withObjscope) { - tcd = NEW(aliasCmdClientData); - tcd->cmdName = NULL; - tcd->obj = allocation == 'c' ? &cl->object : object; - tcd->objProc = objProc; - tcd->clientData = Tcl_Command_objClientData(cmd); - objProc = XOTclObjscopedMethod; - dp = aliasCmdDeleteProc; - } else { - tcd = Tcl_Command_objClientData(cmd); - } - - if (withProtected) { - flags = XOTCL_PROTECTED_METHOD; - } - - if (allocation == 'c') { - XOTclAddInstanceMethod(interp, (XOTcl_Class*)cl, methodName, - objProc, tcd, dp, flags); - } else { - XOTclAddObjectMethod(interp, (XOTcl_Object*)object, methodName, - objProc, tcd, dp, flags); - } - return TCL_OK; -} - static int XOTclConfigureCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { int bool, opt, result = TCL_OK; @@ -9290,19 +9238,7 @@ return result; } -static int -XOTclSetInstvarCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { - XOTclObject *obj = NULL; - if (objc < 3 || objc > 4) - return XOTclObjErrArgCnt(interp, objv[0], NULL, "obj var ?value?"); - /*fprintf(stderr,"setinstvar obj '%s' var '%s' %d\n", ObjStr(objv[1]), ObjStr(objv[2]), objc);*/ - XOTclObjConvertObject(interp, objv[1], &obj); - if (!obj) return XOTclObjErrType(interp, objv[0], "Object"); - - return setInstVar(interp, obj , objv[2], objc == 4 ? objv[3] : NULL); -} - typedef enum {NO_DASH, SKALAR_DASH, LIST_DASH} dashArgType; static dashArgType @@ -10125,10 +10061,67 @@ * End result setting commands ********************************/ -static int -XOTclRelationCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { + +/********************************* + * Begin generated XOTcl commands + *********************************/ + +static int XOTclAliasCmd(Tcl_Interp *interp, XOTclObject *object, char *methodName, + int withObjscope, int withPer_object, int withProtected, Tcl_Obj *cmdName) { + XOTclClass *cl; + Tcl_Command cmd, importedCmd; + Tcl_ObjCmdProc *objProc; + char allocation; + Tcl_CmdDeleteProc *dp = NULL; + aliasCmdClientData *tcd = NULL; + int flags = 0; + + if (XOTclObjectIsClass(object)) { + cl = (XOTclClass *)object; + allocation = 'c'; + } else { + cl = NULL; + allocation = 'o'; + } + cmd = Tcl_GetCommandFromObj(interp, cmdName); + if (cmd == NULL) + return XOTclVarErrMsg(interp, "cannot lookup command '", + ObjStr(cmdName), "'", (char *) NULL); + + if ((importedCmd = TclGetOriginalCommand(cmd))) { + cmd = importedCmd; + } + objProc = Tcl_Command_objProc(cmd); + + if (withObjscope) { + tcd = NEW(aliasCmdClientData); + tcd->cmdName = NULL; + tcd->obj = allocation == 'c' ? &cl->object : object; + tcd->objProc = objProc; + tcd->clientData = Tcl_Command_objClientData(cmd); + objProc = XOTclObjscopedMethod; + dp = aliasCmdDeleteProc; + } else { + tcd = Tcl_Command_objClientData(cmd); + } + + if (withProtected) { + flags = XOTCL_PROTECTED_METHOD; + } + + if (allocation == 'c') { + XOTclAddInstanceMethod(interp, (XOTcl_Class*)cl, methodName, + objProc, tcd, dp, flags); + } else { + XOTclAddObjectMethod(interp, (XOTcl_Object*)object, methodName, + objProc, tcd, dp, flags); + } + return TCL_OK; +} + +static int XOTclRelationCmd(Tcl_Interp *interp, XOTclObject *object, Tcl_Obj *reltype, Tcl_Obj *value) { int oc; Tcl_Obj **ov; - XOTclObject *obj = NULL, *nobj = NULL; + XOTclObject *nobj = NULL; XOTclClass *cl = NULL; XOTclObjectOpt *objopt = NULL; XOTclClassOpt *clopt = NULL, *nclopt = NULL; @@ -10145,10 +10138,7 @@ classIdx, superclassIdx, rootclassIdx }; - if (objc < 3 || objc > 4) - return XOTclObjErrArgCnt(interp, objv[0], NULL, "obj reltype value"); - - if (Tcl_GetIndexFromObj(interp, objv[2], opts, "relation type", 0, &opt) != TCL_OK) { + if (Tcl_GetIndexFromObj(interp, reltype, opts, "relation type", 0, &opt) != TCL_OK) { return TCL_ERROR; } @@ -10157,30 +10147,31 @@ case mixinIdx: case pofIdx: case filterIdx: - XOTclObjConvertObject(interp, objv[1], &obj); - if (!obj) return XOTclObjErrType(interp, objv[1], "Object"); - if (objc == 3) { - objopt = obj->opt; + if (value == NULL) { + objopt = object->opt; switch (opt) { case pomIdx: case mixinIdx: return objopt ? MixinInfo(interp, objopt->mixins, NULL, 1, NULL) : TCL_OK; case pofIdx: case filterIdx: return objopt ? FilterInfo(interp, objopt->filters, NULL, 1, 0) : TCL_OK; } - } - if (Tcl_ListObjGetElements(interp, objv[3], &oc, &ov) != TCL_OK) + } + if (Tcl_ListObjGetElements(interp, value, &oc, &ov) != TCL_OK) return TCL_ERROR; - objopt = XOTclRequireObjectOpt(obj); + objopt = XOTclRequireObjectOpt(object); break; case pcmIdx: case instmixinIdx: case pcfIdx: case instfilterIdx: - GetXOTclClassFromObj(interp, objv[1], &cl, 0); - if (!cl) return XOTclObjErrType(interp, objv[1], "Class"); + if (XOTclObjectIsClass(object)) { + cl = (XOTclClass *)object; + } else { + return XOTclObjErrType(interp, object->cmdName, "Class"); + } - if (objc == 3) { + if (value == NULL) { clopt = cl->opt; switch (opt) { case pcmIdx: @@ -10190,48 +10181,50 @@ } } - if (Tcl_ListObjGetElements(interp, objv[3], &oc, &ov) != TCL_OK) + if (Tcl_ListObjGetElements(interp, value, &oc, &ov) != TCL_OK) return TCL_ERROR; clopt = XOTclRequireClassOpt(cl); break; case superclassIdx: - GetXOTclClassFromObj(interp, objv[1], &cl, 0); - if (objc == 3) { + if (!XOTclObjectIsClass(object)) + return XOTclObjErrType(interp, object->cmdName, "Class"); + cl = (XOTclClass *)object; + if (value == NULL) { return ListSuperclasses(interp, cl, NULL, 0); } - if (!cl) return XOTclObjErrType(interp, objv[1], "Class"); - if (Tcl_ListObjGetElements(interp, objv[3], &oc, &ov) != TCL_OK) + if (Tcl_ListObjGetElements(interp, value, &oc, &ov) != TCL_OK) return TCL_ERROR; - return SuperclassAdd(interp, cl, oc, ov, objv[3], cl->object.cl); + return SuperclassAdd(interp, cl, oc, ov, value, cl->object.cl); case classIdx: - XOTclObjConvertObject(interp, objv[1], &obj); - if (!obj) return XOTclObjErrType(interp, objv[1], "Object"); - if (objc == 3) { - Tcl_SetObjResult(interp, obj->cl->object.cmdName); + if (value == NULL) { + Tcl_SetObjResult(interp, object->cl->object.cmdName); return TCL_OK; } - GetXOTclClassFromObj(interp, objv[3], &cl, obj->cl); - if (!cl) return XOTclErrBadVal(interp, "class", "a class", ObjStr(objv[1])); - return changeClass(interp, obj, cl); - + GetXOTclClassFromObj(interp, value, &cl, object->cl); + if (!cl) return XOTclErrBadVal(interp, "class", "a class", objectName(object)); + return changeClass(interp, object, cl); + 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"); - GetXOTclClassFromObj(interp, objv[3], &metaClass, 0); - if (!metaClass) return XOTclObjErrType(interp, objv[3], "Class"); + if (!XOTclObjectIsClass(object)) + return XOTclObjErrType(interp, object->cmdName, "Class"); + cl = (XOTclClass *)object; + + if (value == NULL) { + return XOTclVarErrMsg(interp, "metaclass must be specified as third argument", + (char *) NULL); + } + GetXOTclClassFromObj(interp, value, &metaClass, 0); + if (!metaClass) return XOTclObjErrType(interp, value, "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: need to remove these properties? @@ -10243,17 +10236,16 @@ switch (opt) { case pomIdx: case mixinIdx: - if (objopt->mixins) { XOTclCmdList *cmdlist, *del; for (cmdlist = objopt->mixins; cmdlist; cmdlist = cmdlist->nextPtr) { cl = XOTclGetClassFromCmdPtr(cmdlist->cmdPtr); clopt = cl ? cl->opt : NULL; if (clopt) { - del = CmdListFindCmdInList(obj->id, clopt->isObjectMixinOf); + del = CmdListFindCmdInList(object->id, clopt->isObjectMixinOf); if (del) { /* fprintf(stderr,"Removing object %s from isObjectMixinOf of class %s\n", - objectName(obj), ObjStr(XOTclGetClassFromCmdPtr(cmdlist->cmdPtr)->object.cmdName)); */ + objectName(object), ObjStr(XOTclGetClassFromCmdPtr(cmdlist->cmdPtr)->object.cmdName)); */ del = CmdListRemoveFromList(&clopt->isObjectMixinOf, del); CmdListDeleteCmdListEntry(del, GuardDel); } @@ -10262,19 +10254,19 @@ CmdListRemoveList(&objopt->mixins, GuardDel); } - obj->flags &= ~XOTCL_MIXIN_ORDER_VALID; + object->flags &= ~XOTCL_MIXIN_ORDER_VALID; /* * since mixin procs may be used as filters -> we have to invalidate */ - obj->flags &= ~XOTCL_FILTER_ORDER_VALID; + object->flags &= ~XOTCL_FILTER_ORDER_VALID; /* * now add the specified mixins */ for (i = 0; i < oc; i++) { Tcl_Obj *ocl = NULL; - if (MixinAdd(interp, &objopt->mixins, ov[i], obj->cl->object.cl) != TCL_OK) { + if (MixinAdd(interp, &objopt->mixins, ov[i], object->cl->object.cl) != TCL_OK) { return TCL_ERROR; } /* fprintf(stderr,"Added to mixins of %s: %s\n", objectName(obj), ObjStr(ov[i])); */ @@ -10284,23 +10276,23 @@ /* fprintf(stderr,"Registering object %s to isObjectMixinOf of class %s\n", objectName(obj), objectName(nobj)); */ nclopt = XOTclRequireClassOpt((XOTclClass*) nobj); - CmdListAdd(&nclopt->isObjectMixinOf, obj->id, NULL, /*noDuplicates*/ 1); + CmdListAdd(&nclopt->isObjectMixinOf, object->id, NULL, /*noDuplicates*/ 1); } /* else fprintf(stderr,"Problem registering %s as a mixinof of %s\n", ObjStr(ov[i]), className(cl)); */ } - MixinComputeDefined(interp, obj); - FilterComputeDefined(interp, obj); + MixinComputeDefined(interp, object); + FilterComputeDefined(interp, object); break; case pofIdx: case filterIdx: if (objopt->filters) CmdListRemoveList(&objopt->filters, GuardDel); - obj->flags &= ~XOTCL_FILTER_ORDER_VALID; + object->flags &= ~XOTCL_FILTER_ORDER_VALID; for (i = 0; i < oc; i ++) { - if (FilterAdd(interp, &objopt->filters, ov[i], obj, 0) != TCL_OK) + if (FilterAdd(interp, &objopt->filters, ov[i], object, 0) != TCL_OK) return TCL_ERROR; } /*FilterComputeDefined(interp, obj);*/ @@ -10356,7 +10348,15 @@ return TCL_OK; } +static int XOTclSetInstvarCmd(Tcl_Interp *interp, XOTclObject *object, Tcl_Obj *variable, Tcl_Obj *value) { + return setInstVar(interp, object , variable, value); +} + /*************************** + * End generated XOTcl commands + ***************************/ + +/*************************** * Begin Object Methods ***************************/ static int XOTclOAutonameMethod(Tcl_Interp *interp, XOTclObject *obj, int withInstance, int withReset, @@ -13247,8 +13247,6 @@ Tcl_CreateObjCommand(interp, "::xotcl::namespace_copyvars", XOTcl_NSCopyVars, 0, 0); Tcl_CreateObjCommand(interp, "::xotcl::namespace_copycmds", XOTcl_NSCopyCmds, 0, 0); Tcl_CreateObjCommand(interp, "::xotcl::__qualify", XOTclQualifyObjCmd, 0, 0); - Tcl_CreateObjCommand(interp, "::xotcl::setinstvar", XOTclSetInstvarCmd, 0, 0); - Tcl_CreateObjCommand(interp, "::xotcl::relation", XOTclRelationCmd, 0, 0); Tcl_CreateObjCommand(interp, "::xotcl::trace", XOTcl_TraceObjCmd, 0, 0); Tcl_CreateObjCommand(interp, "::xotcl::is", XOTclIsCmd, 0, 0);