Index: generic/gentclAPI.decls =================================================================== diff -u -raef09781efb62a6336ecf355e927549d72b37a7a -ra4d1fd30453e4e87467b02ed749fb4007d46a5e0 --- generic/gentclAPI.decls (.../gentclAPI.decls) (revision aef09781efb62a6336ecf355e927549d72b37a7a) +++ generic/gentclAPI.decls (.../gentclAPI.decls) (revision a4d1fd30453e4e87467b02ed749fb4007d46a5e0) @@ -60,7 +60,7 @@ {-argName "object" -required 1 -type object} {-argName "methodName" -required 1} {-argName "-per-object"} - {-argName "methodproperty" -required 1 -type "protected|public|slotobj"} + {-argName "methodproperty" -required 1 -type "protected|static|slotobj"} {-argName "value" -type tclobj} } xotclCmd my XOTclMyCmd { @@ -135,7 +135,8 @@ {-argName "invariantlist" -required 1 -type tclobj} } objectMethod method XOTclOMethodMethod { - {-argName "-inner-namespace" -type switch} + {-argName "-inner-namespace"} + {-argName "-protected"} {-argName "name" -required 1 -type tclobj} {-argName "args" -required 1 -type tclobj} {-argName "body" -required 1 -type tclobj} @@ -211,21 +212,15 @@ {-argName "name" -required 1} } classMethod method XOTclCMethodMethod { - {-argName "-per-object" -type switch} {-argName "-inner-namespace" -type switch} + {-argName "-per-object" -type switch} + {-argName "-protected"} {-argName "name" -required 1 -type tclobj} {-argName "args" -required 1 -type tclobj} {-argName "body" -required 1 -type tclobj} {-argName "-precondition" -nrargs 1 -type tclobj} {-argName "-postcondition" -nrargs 1 -type tclobj} } -classMethod classscopedinstproc XOTclCInstProcMethodC { - {-argName "name" -required 1 -type tclobj} - {-argName "args" -required 1 -type tclobj} - {-argName "body" -required 1 -type tclobj} - {-argName "precondition" -type tclobj} - {-argName "postcondition" -type tclobj} -} classMethod instforward XOTclCInstForwardMethod { {-argName "name" -required 1 -type tclobj} {-argName "-default" -nrargs 1 -type tclobj} @@ -244,10 +239,6 @@ {-argName "name" -required 1 -type tclobj} {-argName "args" -type allargs} } -classMethod unknown XOTclCUnknownMethod { - {-argName "name" -required 1} - {-argName "args" -type allargs} -} # # check methods Index: generic/predefined.h =================================================================== diff -u -raef09781efb62a6336ecf355e927549d72b37a7a -ra4d1fd30453e4e87467b02ed749fb4007d46a5e0 --- generic/predefined.h (.../predefined.h) (revision aef09781efb62a6336ecf355e927549d72b37a7a) +++ generic/predefined.h (.../predefined.h) (revision a4d1fd30453e4e87467b02ed749fb4007d46a5e0) @@ -14,6 +14,12 @@ "::xotcl::alias ::xotcl::Object $cmd -objscope ::$cmd}\n" "foreach cmd [info command ::xotcl::cmd::Class::*] {\n" "::xotcl::alias ::xotcl::Class [namespace tail $cmd] $cmd}\n" +"::xotcl::methodproperty ::xotcl::Object destroy static true\n" +"::xotcl::methodproperty ::xotcl::Class alloc static true\n" +"::xotcl::methodproperty ::xotcl::Class dealloc static true\n" +"::xotcl::methodproperty ::xotcl::Class create static true\n" +"::xotcl::Class method unknown {args} {\n" +"eval my create $args}\n" "::xotcl::Object method init args {}\n" "::xotcl::Object method objectparameter {} {;}\n" "::xotcl::Class create ::xotcl::ParameterType\n" Index: generic/predefined.xotcl =================================================================== diff -u -raef09781efb62a6336ecf355e927549d72b37a7a -ra4d1fd30453e4e87467b02ed749fb4007d46a5e0 --- generic/predefined.xotcl (.../predefined.xotcl) (revision aef09781efb62a6336ecf355e927549d72b37a7a) +++ generic/predefined.xotcl (.../predefined.xotcl) (revision a4d1fd30453e4e87467b02ed749fb4007d46a5e0) @@ -67,6 +67,18 @@ foreach cmd [info command ::xotcl::cmd::Class::*] { ::xotcl::alias ::xotcl::Class [namespace tail $cmd] $cmd } + + # protect some methods against redefinition + ::xotcl::methodproperty ::xotcl::Object destroy static true + ::xotcl::methodproperty ::xotcl::Class alloc static true + ::xotcl::methodproperty ::xotcl::Class dealloc static true + ::xotcl::methodproperty ::xotcl::Class create static true + + ::xotcl::Class method unknown {args} { + #puts stderr "use explict create commands!, not [self] $args" + eval my create $args + } + # "init" must exist on Object. per default it is empty. ::xotcl::Object method init args {} Index: generic/tclAPI.h =================================================================== diff -u -raef09781efb62a6336ecf355e927549d72b37a7a -ra4d1fd30453e4e87467b02ed749fb4007d46a5e0 --- generic/tclAPI.h (.../tclAPI.h) (revision aef09781efb62a6336ecf355e927549d72b37a7a) +++ generic/tclAPI.h (.../tclAPI.h) (revision a4d1fd30453e4e87467b02ed749fb4007d46a5e0) @@ -12,10 +12,10 @@ enum objectkindIdx {objectkindTypeIdx, objectkindObjectIdx, objectkindClassIdx, objectkindMetaclassIdx, objectkindMixinIdx}; static int convertToMethodproperty(Tcl_Interp *interp, Tcl_Obj *objPtr, XOTclParam CONST *pPtr, ClientData *clientData) { - static CONST char *opts[] = {"protected", "public", "slotobj", NULL}; + static CONST char *opts[] = {"protected", "static", "slotobj", NULL}; return Tcl_GetIndexFromObj(interp, objPtr, opts, "methodproperty", 0, (int *)clientData); } -enum methodpropertyIdx {methodpropertyProtectedIdx, methodpropertyPublicIdx, methodpropertySlotobjIdx}; +enum methodpropertyIdx {methodpropertyProtectedIdx, methodpropertyStaticIdx, methodpropertySlotobjIdx}; static int convertToRelationtype(Tcl_Interp *interp, Tcl_Obj *objPtr, XOTclParam CONST *pPtr, ClientData *clientData) { static CONST char *opts[] = {"mixin", "instmixin", "object-mixin", "class-mixin", "filter", "instfilter", "object-filter", "class_filter", "class", "superclass", "rootclass", NULL}; @@ -57,13 +57,11 @@ static int XOTclCInstForwardMethodStub(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv []); static int XOTclCInstMixinGuardMethodStub(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv []); static int XOTclCInstParametercmdMethodStub(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv []); -static int XOTclCInstProcMethodCStub(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv []); static int XOTclCInvalidateObjectParameterMethodStub(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv []); static int XOTclCInvariantsMethodStub(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv []); static int XOTclCMethodMethodStub(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv []); static int XOTclCNewMethodStub(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv []); static int XOTclCRecreateMethodStub(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv []); -static int XOTclCUnknownMethodStub(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv []); static int XOTclClassInfoHeritageMethodStub(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv []); static int XOTclClassInfoInstancesMethodStub(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv []); static int XOTclClassInfoInstbodyMethodStub(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv []); @@ -157,13 +155,11 @@ static int XOTclCInstForwardMethod(Tcl_Interp *interp, XOTclClass *cl, Tcl_Obj *name, Tcl_Obj *withDefault, int withEarlybinding, Tcl_Obj *withMethodprefix, int withObjscope, Tcl_Obj *withOnerror, int withVerbose, Tcl_Obj *target, int nobjc, Tcl_Obj *CONST nobjv[]); static int XOTclCInstMixinGuardMethod(Tcl_Interp *interp, XOTclClass *cl, char *mixin, Tcl_Obj *guard); static int XOTclCInstParametercmdMethod(Tcl_Interp *interp, XOTclClass *cl, char *name); -static int XOTclCInstProcMethodC(Tcl_Interp *interp, XOTclClass *cl, Tcl_Obj *name, Tcl_Obj *args, Tcl_Obj *body, Tcl_Obj *precondition, Tcl_Obj *postcondition); static int XOTclCInvalidateObjectParameterMethod(Tcl_Interp *interp, XOTclClass *cl); static int XOTclCInvariantsMethod(Tcl_Interp *interp, XOTclClass *cl, Tcl_Obj *invariantlist); -static int XOTclCMethodMethod(Tcl_Interp *interp, XOTclClass *cl, int withPer_object, int withInner_namespace, Tcl_Obj *name, Tcl_Obj *args, Tcl_Obj *body, Tcl_Obj *withPrecondition, Tcl_Obj *withPostcondition); +static int XOTclCMethodMethod(Tcl_Interp *interp, XOTclClass *cl, int withInner_namespace, int withPer_object, int withProtected, Tcl_Obj *name, Tcl_Obj *args, Tcl_Obj *body, Tcl_Obj *withPrecondition, Tcl_Obj *withPostcondition); static int XOTclCNewMethod(Tcl_Interp *interp, XOTclClass *cl, XOTclObject *withChildof, int nobjc, Tcl_Obj *CONST nobjv[]); static int XOTclCRecreateMethod(Tcl_Interp *interp, XOTclClass *cl, Tcl_Obj *name, int objc, Tcl_Obj *CONST objv[]); -static int XOTclCUnknownMethod(Tcl_Interp *interp, XOTclClass *cl, char *name, int objc, Tcl_Obj *CONST objv[]); static int XOTclClassInfoHeritageMethod(Tcl_Interp *interp, XOTclClass *class, char *pattern); static int XOTclClassInfoInstancesMethod(Tcl_Interp *interp, XOTclClass *class, int withClosure, char *patternString, XOTclObject *patternObj); static int XOTclClassInfoInstbodyMethod(Tcl_Interp *interp, XOTclClass *class, char *methodName); @@ -218,7 +214,7 @@ static int XOTclOForwardMethod(Tcl_Interp *interp, XOTclObject *obj, Tcl_Obj *method, Tcl_Obj *withDefault, int withEarlybinding, Tcl_Obj *withMethodprefix, int withObjscope, Tcl_Obj *withOnerror, int withVerbose, Tcl_Obj *target, int nobjc, Tcl_Obj *CONST nobjv[]); static int XOTclOInstVarMethod(Tcl_Interp *interp, XOTclObject *obj, int objc, Tcl_Obj *CONST objv[]); static int XOTclOInvariantsMethod(Tcl_Interp *interp, XOTclObject *obj, Tcl_Obj *invariantlist); -static int XOTclOMethodMethod(Tcl_Interp *interp, XOTclObject *obj, int withInner_namespace, Tcl_Obj *name, Tcl_Obj *args, Tcl_Obj *body, Tcl_Obj *withPrecondition, Tcl_Obj *withPostcondition); +static int XOTclOMethodMethod(Tcl_Interp *interp, XOTclObject *obj, int withInner_namespace, int withProtected, Tcl_Obj *name, Tcl_Obj *args, Tcl_Obj *body, Tcl_Obj *withPrecondition, Tcl_Obj *withPostcondition); static int XOTclOMixinGuardMethod(Tcl_Interp *interp, XOTclObject *obj, char *mixin, Tcl_Obj *guard); static int XOTclONextMethod(Tcl_Interp *interp, XOTclObject *obj, int objc, Tcl_Obj *CONST objv[]); static int XOTclONoinitMethod(Tcl_Interp *interp, XOTclObject *obj); @@ -258,13 +254,11 @@ XOTclCInstForwardMethodIdx, XOTclCInstMixinGuardMethodIdx, XOTclCInstParametercmdMethodIdx, - XOTclCInstProcMethodCIdx, XOTclCInvalidateObjectParameterMethodIdx, XOTclCInvariantsMethodIdx, XOTclCMethodMethodIdx, XOTclCNewMethodIdx, XOTclCRecreateMethodIdx, - XOTclCUnknownMethodIdx, XOTclClassInfoHeritageMethodIdx, XOTclClassInfoInstancesMethodIdx, XOTclClassInfoInstbodyMethodIdx, @@ -532,29 +526,6 @@ } static int -XOTclCInstProcMethodCStub(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { - parseContext pc; - XOTclClass *cl = XOTclObjectToClass(clientData); - if (!cl) return XOTclObjErrType(interp, objv[0], "Class"); - if (ArgumentParse(interp, objc, objv, (XOTclObject *) cl, objv[0], - method_definitions[XOTclCInstProcMethodCIdx].paramDefs, - method_definitions[XOTclCInstProcMethodCIdx].nrParameters, - &pc) != TCL_OK) { - return TCL_ERROR; - } else { - Tcl_Obj *name = (Tcl_Obj *)pc.clientData[0]; - Tcl_Obj *args = (Tcl_Obj *)pc.clientData[1]; - Tcl_Obj *body = (Tcl_Obj *)pc.clientData[2]; - Tcl_Obj *precondition = (Tcl_Obj *)pc.clientData[3]; - Tcl_Obj *postcondition = (Tcl_Obj *)pc.clientData[4]; - - parseContextRelease(&pc); - return XOTclCInstProcMethodC(interp, cl, name, args, body, precondition, postcondition); - - } -} - -static int XOTclCInvalidateObjectParameterMethodStub(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { parseContext pc; XOTclClass *cl = XOTclObjectToClass(clientData); @@ -603,16 +574,17 @@ &pc) != TCL_OK) { return TCL_ERROR; } else { - int withPer_object = (int )pc.clientData[0]; - int withInner_namespace = (int )pc.clientData[1]; - Tcl_Obj *name = (Tcl_Obj *)pc.clientData[2]; - Tcl_Obj *args = (Tcl_Obj *)pc.clientData[3]; - Tcl_Obj *body = (Tcl_Obj *)pc.clientData[4]; - Tcl_Obj *withPrecondition = (Tcl_Obj *)pc.clientData[5]; - Tcl_Obj *withPostcondition = (Tcl_Obj *)pc.clientData[6]; + int withInner_namespace = (int )pc.clientData[0]; + int withPer_object = (int )pc.clientData[1]; + int withProtected = (int )pc.clientData[2]; + Tcl_Obj *name = (Tcl_Obj *)pc.clientData[3]; + Tcl_Obj *args = (Tcl_Obj *)pc.clientData[4]; + Tcl_Obj *body = (Tcl_Obj *)pc.clientData[5]; + Tcl_Obj *withPrecondition = (Tcl_Obj *)pc.clientData[6]; + Tcl_Obj *withPostcondition = (Tcl_Obj *)pc.clientData[7]; parseContextRelease(&pc); - return XOTclCMethodMethod(interp, cl, withPer_object, withInner_namespace, name, args, body, withPrecondition, withPostcondition); + return XOTclCMethodMethod(interp, cl, withInner_namespace, withPer_object, withProtected, name, args, body, withPrecondition, withPostcondition); } } @@ -656,25 +628,6 @@ } static int -XOTclCUnknownMethodStub(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { - parseContext pc; - XOTclClass *cl = XOTclObjectToClass(clientData); - if (!cl) return XOTclObjErrType(interp, objv[0], "Class"); - if (ArgumentParse(interp, objc, objv, (XOTclObject *) cl, objv[0], - method_definitions[XOTclCUnknownMethodIdx].paramDefs, - method_definitions[XOTclCUnknownMethodIdx].nrParameters, - &pc) != TCL_OK) { - return TCL_ERROR; - } else { - char *name = (char *)pc.clientData[0]; - - parseContextRelease(&pc); - return XOTclCUnknownMethod(interp, cl, name, objc, objv); - - } -} - -static int XOTclClassInfoHeritageMethodStub(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { parseContext pc; @@ -1801,14 +1754,15 @@ return TCL_ERROR; } else { int withInner_namespace = (int )pc.clientData[0]; - Tcl_Obj *name = (Tcl_Obj *)pc.clientData[1]; - Tcl_Obj *args = (Tcl_Obj *)pc.clientData[2]; - Tcl_Obj *body = (Tcl_Obj *)pc.clientData[3]; - Tcl_Obj *withPrecondition = (Tcl_Obj *)pc.clientData[4]; - Tcl_Obj *withPostcondition = (Tcl_Obj *)pc.clientData[5]; + int withProtected = (int )pc.clientData[1]; + Tcl_Obj *name = (Tcl_Obj *)pc.clientData[2]; + Tcl_Obj *args = (Tcl_Obj *)pc.clientData[3]; + Tcl_Obj *body = (Tcl_Obj *)pc.clientData[4]; + Tcl_Obj *withPrecondition = (Tcl_Obj *)pc.clientData[5]; + Tcl_Obj *withPostcondition = (Tcl_Obj *)pc.clientData[6]; parseContextRelease(&pc); - return XOTclOMethodMethod(interp, obj, withInner_namespace, name, args, body, withPrecondition, withPostcondition); + return XOTclOMethodMethod(interp, obj, withInner_namespace, withProtected, name, args, body, withPrecondition, withPostcondition); } } @@ -2350,22 +2304,16 @@ {"::xotcl::cmd::Class::instparametercmd", XOTclCInstParametercmdMethodStub, 1, { {"name", 1, 0, convertToString}} }, -{"::xotcl::cmd::Class::classscopedinstproc", XOTclCInstProcMethodCStub, 5, { - {"name", 1, 0, convertToTclobj}, - {"args", 1, 0, convertToTclobj}, - {"body", 1, 0, convertToTclobj}, - {"precondition", 0, 0, convertToTclobj}, - {"postcondition", 0, 0, convertToTclobj}} -}, {"::xotcl::cmd::Class::invalidateobjectparameter", XOTclCInvalidateObjectParameterMethodStub, 0, { } }, {"::xotcl::cmd::Class::instinvar", XOTclCInvariantsMethodStub, 1, { {"invariantlist", 1, 0, convertToTclobj}} }, -{"::xotcl::cmd::Class::method", XOTclCMethodMethodStub, 7, { - {"-per-object", 0, 0, convertToBoolean}, +{"::xotcl::cmd::Class::method", XOTclCMethodMethodStub, 8, { {"-inner-namespace", 0, 0, convertToBoolean}, + {"-per-object", 0, 0, convertToBoolean}, + {"-protected", 0, 0, convertToString}, {"name", 1, 0, convertToTclobj}, {"args", 1, 0, convertToTclobj}, {"body", 1, 0, convertToTclobj}, @@ -2380,10 +2328,6 @@ {"name", 1, 0, convertToTclobj}, {"args", 0, 0, convertToNothing}} }, -{"::xotcl::cmd::Class::unknown", XOTclCUnknownMethodStub, 2, { - {"name", 1, 0, convertToString}, - {"args", 0, 0, convertToNothing}} -}, {"::xotcl::cmd::ClassInfo::heritage", XOTclClassInfoHeritageMethodStub, 2, { {"class", 1, 0, convertToClass}, {"pattern", 0, 0, convertToString}} @@ -2613,8 +2557,9 @@ {"::xotcl::cmd::Object::invar", XOTclOInvariantsMethodStub, 1, { {"invariantlist", 1, 0, convertToTclobj}} }, -{"::xotcl::cmd::Object::method", XOTclOMethodMethodStub, 6, { - {"-inner-namespace", 0, 0, convertToBoolean}, +{"::xotcl::cmd::Object::method", XOTclOMethodMethodStub, 7, { + {"-inner-namespace", 0, 0, convertToString}, + {"-protected", 0, 0, convertToString}, {"name", 1, 0, convertToTclobj}, {"args", 1, 0, convertToTclobj}, {"body", 1, 0, convertToTclobj}, @@ -2704,7 +2649,7 @@ {"object", 1, 0, convertToObject}, {"methodName", 1, 0, convertToString}, {"-per-object", 0, 0, convertToString}, - {"protected|public|slotobj", 1, 0, convertToMethodproperty}, + {"protected|static|slotobj", 1, 0, convertToMethodproperty}, {"value", 0, 0, convertToTclobj}} }, {"::xotcl::my", XOTclMyCmdStub, 3, { Index: generic/xotcl.c =================================================================== diff -u -raef09781efb62a6336ecf355e927549d72b37a7a -ra4d1fd30453e4e87467b02ed749fb4007d46a5e0 --- generic/xotcl.c (.../xotcl.c) (revision aef09781efb62a6336ecf355e927549d72b37a7a) +++ generic/xotcl.c (.../xotcl.c) (revision a4d1fd30453e4e87467b02ed749fb4007d46a5e0) @@ -994,24 +994,6 @@ return result; } - -#ifndef NAMESPACEINSTPROCS -static Tcl_Namespace * -GetCallerVarFrame(Tcl_Interp *interp, Tcl_CallFrame *varFramePtr) { - Tcl_Namespace *nsPtr = NULL; - if (varFramePtr) { - Tcl_CallFrame *callerVarPtr = Tcl_CallFrame_callerVarPtr(varFramePtr); - if (callerVarPtr) { - nsPtr = (Tcl_Namespace *)callerVarPtr->nsPtr; - } - } - if (nsPtr == NULL) - nsPtr = Tcl_Interp_globalNsPtr(interp); - - return nsPtr; -} -#endif - static Tcl_Obj * NameInNamespaceObj(Tcl_Interp *interp, char *name, Tcl_Namespace *nsPtr) { Tcl_Obj *objName; @@ -1936,70 +1918,73 @@ return (obj && XOTclObjectIsClass(obj)) ? (XOTclClass*)obj : NULL; } -Tcl_Command +static int +CanRedefineCmd(Tcl_Interp *interp, Tcl_Namespace *nsPtr, XOTclObject *obj, char *methodName) { + int result, ok; + Tcl_Command cmd = FindMethod(nsPtr, methodName); + + ok = cmd ? (Tcl_Command_flags(cmd) & XOTCL_CMD_STATIC_METHOD) == 0 : 1; + if (ok) { + result = TCL_OK; + } else { + result = XOTclVarErrMsg(interp, "Method '", methodName, "' of ", objectName(obj), + " can not be overwritten. Derive e.g. a ", + "sub-class!", (char *) NULL); + } + return result; +} + +int XOTclAddObjectMethod(Tcl_Interp *interp, XOTcl_Object *object, CONST char *methodName, Tcl_ObjCmdProc *proc, ClientData clientData, Tcl_CmdDeleteProc *dp, int flags) { XOTclObject *obj = (XOTclObject *)object; Tcl_DString newCmdName, *dsPtr = &newCmdName; - Tcl_Command newCmd; Tcl_Namespace *ns = requireObjNamespace(interp, obj); + Tcl_Command newCmd; + int result; + /* Check, if we are allowed to redefine the method */ + result = CanRedefineCmd(interp, obj->nsPtr, obj, (char*)methodName); + if (result != TCL_OK) { + return result; + } + ALLOC_NAME_NS(dsPtr, ns->fullName, methodName); newCmd = Tcl_CreateObjCommand(interp, Tcl_DStringValue(dsPtr), proc, clientData, dp); if (flags) { ((Command *) newCmd)->flags |= flags; } DSTRING_FREE(dsPtr); - return newCmd; + return TCL_OK; } -Tcl_Command -XOTclAddPMethod(Tcl_Interp *interp, XOTcl_Object *object, CONST char *methodName, - Tcl_ObjCmdProc *proc, ClientData clientData, Tcl_CmdDeleteProc *dp) { - int flags = 0; - if (clientData == (ClientData) XOTCL_CMD_NONLEAF_METHOD) { - fprintf(stderr, "XOTclAddPMethod(,,,, XOTCL_CMD_NONLEAF_METHOD,) deprecated.\n" - "Use XOTclAddObjectMethod(,,,,,, XOTCL_CMD_NONLEAF_METHOD) instead.\n"); - flags = XOTCL_CMD_NONLEAF_METHOD; - clientData = NULL; - } - return XOTclAddObjectMethod(interp, object, methodName, proc, clientData, dp, flags); -} - - -Tcl_Command +int XOTclAddInstanceMethod(Tcl_Interp *interp, XOTcl_Class *class, CONST char *methodName, Tcl_ObjCmdProc *proc, ClientData clientData, Tcl_CmdDeleteProc *dp, int flags) { - XOTclClass *cl = (XOTclClass*) class; + XOTclClass *cl = (XOTclClass *)class; Tcl_DString newCmdName, *dsPtr = &newCmdName; Tcl_Command newCmd; + int result; + + /* Check, if we are allowed to redefine the method */ + result = CanRedefineCmd(interp, cl->nsPtr, &cl->object, (char*)methodName); + if (result != TCL_OK) { + return result; + } + ALLOC_NAME_NS(dsPtr, cl->nsPtr->fullName, methodName); newCmd = Tcl_CreateObjCommand(interp, Tcl_DStringValue(dsPtr), proc, clientData, dp); + if (flags) { ((Command *) newCmd)->flags |= flags; } DSTRING_FREE(dsPtr); - return newCmd; + return TCL_OK; } -Tcl_Command -XOTclAddIMethod(Tcl_Interp *interp, XOTcl_Class *class, CONST char *methodName, - Tcl_ObjCmdProc *proc, ClientData clientData, Tcl_CmdDeleteProc *dp) { - int flags = 0; - if (clientData == (ClientData) XOTCL_CMD_NONLEAF_METHOD) { - fprintf(stderr, "XOTclAddIMethod(,,,, XOTCL_CMD_NONLEAF_METHOD,) deprecated.\n" - "Use XOTclAddInstanceMethod(,,,,,, XOTCL_CMD_NONLEAF_METHOD) instead.\n"); - flags = XOTCL_CMD_NONLEAF_METHOD; - clientData = NULL; - } - return XOTclAddInstanceMethod(interp, class, methodName, proc, clientData, dp, flags); -} - - - /* * Generic Tcl_Obj List */ @@ -2581,6 +2566,12 @@ /* we do not check assertion modifying methods, otherwise we can not react in catch on a runtime assertion check failure */ + + /* TODO this check operations are not generic. these should be + removed, most of the is*String() definition are then obsolete and + should be deleted from xotclInt.h as well. + */ + if (isCheckString(methodName) || isInfoString(methodName) || isInvarString(methodName) || isInstinvarString(methodName) || isProcString(methodName) || isInstprocString(methodName)) @@ -5908,25 +5899,32 @@ static int MakeProc(Tcl_Namespace *nsPtr, XOTclAssertionStore *aStore, Tcl_Interp *interp, Tcl_Obj *nameObj, Tcl_Obj *args, Tcl_Obj *body, Tcl_Obj *precondition, - Tcl_Obj *postcondition, XOTclObject *obj, int clsns) { - int result; + Tcl_Obj *postcondition, XOTclObject *obj, int withProtected, int clsns) { TclCallFrame frame, *framePtr = &frame; - Tcl_Obj *ov[4]; char *procName = ObjStr(nameObj); XOTclParsedParam parsedParam; + Tcl_Obj *ov[4]; + Proc *procPtr; + int result; + /* Check, if we are allowed to redefine the method */ + result = CanRedefineCmd(interp, nsPtr, obj, procName); + if (result == TCL_OK) { + /* Yes, so obtain an method parameter definitions */ + result = ParamDefsParse(interp, procName, args, XOTCL_ARG_METHOD_PARAMETER, &parsedParam); + } + if (result != TCL_OK) { + return result; + } + ov[0] = NULL; /*objv[0];*/ ov[1] = nameObj; - /* Obtain an method parameter definitions */ - result = ParamDefsParse(interp, procName, args, XOTCL_ARG_METHOD_PARAMETER, &parsedParam); - if (result != TCL_OK) - return result; - if (parsedParam.paramDefs) { # if defined(CANONICAL_ARGS) XOTclParam *pPtr; Tcl_Obj *argList = Tcl_NewListObj(0, NULL); + for (pPtr = parsedParam.paramDefs->paramsPtr; pPtr->name; pPtr++) { if (*pPtr->name == '-') { Tcl_ListObjAppendElement(interp, argList, Tcl_NewStringObj(pPtr->name+1,-1)); @@ -5947,32 +5945,36 @@ } Tcl_PushCallFrame(interp,(Tcl_CallFrame *)framePtr, nsPtr, 0); - + /* create the method in the provided namespace */ result = Tcl_ProcObjCmd(0, interp, 4, ov) != TCL_OK; -#if defined(NAMESPACEINSTPROCS) - { - Proc *procPtr = TclFindProc((Interp *)interp, procName); - /*** patch the command ****/ - if (procPtr) { - if (clsns) { - /* set the namespace of the method as inside of the class */ - if (!obj->nsPtr) { - makeObjNamespace(interp, obj); - } - /*fprintf(stderr, "obj %s\n", objectName(obj)); - fprintf(stderr, "ns %p obj->ns %p\n", ns, obj->nsPtr); - fprintf(stderr, "ns %s obj->ns %s\n", ns->fullName, obj->nsPtr->fullName);*/ - procPtr->cmdPtr->nsPtr = (Namespace*) obj->nsPtr; - } else { - /* set the namespace of the method to the same namespace the class has */ - procPtr->cmdPtr->nsPtr = ((Command *)obj->id)->nsPtr; + /* retrieve the defined proc */ + procPtr = FindProcMethod(nsPtr, procName); + if (procPtr) { + /* modify the cmd of the proc to set the current namespace for the body */ + if (clsns) { + /* + * Set the namespace of the method as inside of the class + */ + if (!obj->nsPtr) { + makeObjNamespace(interp, obj); } + /*fprintf(stderr, "obj %s\n", objectName(obj)); + fprintf(stderr, "ns %p obj->ns %p\n", ns, obj->nsPtr); + fprintf(stderr, "ns %s obj->ns %s\n", ns->fullName, obj->nsPtr->fullName);*/ + procPtr->cmdPtr->nsPtr = (Namespace*) obj->nsPtr; + } else { + /* + * Set the namespace of the method to the same namespace the class has + */ + procPtr->cmdPtr->nsPtr = ((Command *)obj->id)->nsPtr; } + ParamDefsStore(interp, (Tcl_Command)procPtr->cmdPtr, parsedParam.paramDefs); + if (withProtected) { + Tcl_Command_flags((Tcl_Command)procPtr->cmdPtr) |= XOTCL_CMD_PROTECTED_METHOD; + } } -#endif - Tcl_PopCallFrame(interp); if (precondition || postcondition) { @@ -5989,83 +5991,54 @@ return result; } -static int -MakeObjectMethod(Tcl_Interp *interp, XOTclObject *obj, Tcl_Obj *name, - Tcl_Obj *args, Tcl_Obj *body, - Tcl_Obj *precondition, Tcl_Obj *postcondition, int clsns) { - char *argStr = ObjStr(args), *bdyStr = ObjStr(body), *nameStr = ObjStr(name); +static int +MakeMethod(Tcl_Interp *interp, XOTclObject *obj, XOTclClass *cl, Tcl_Obj *nameObj, + Tcl_Obj *args, Tcl_Obj *body, + Tcl_Obj *precondition, Tcl_Obj *postcondition, + int withProtected, int clsns) { + char *argStr = ObjStr(args), *bdyStr = ObjStr(body), *nameStr = ObjStr(nameObj); int result; if (precondition && !postcondition) { - return XOTclVarErrMsg(interp, objectName(obj), " method '", nameStr, + return XOTclVarErrMsg(interp, className(cl), " method '", nameStr, "'; when specifying a precondition (", ObjStr(precondition), ") a postcondition must be specified as well", (char *) NULL); } /* if both, args and body are empty strings, we delete the method */ if (*argStr == 0 && *bdyStr == 0) { - result = XOTclRemovePMethod(interp, (XOTcl_Object *)obj, nameStr); - + result = cl ? + XOTclRemoveIMethod(interp, (XOTcl_Class *)cl, nameStr) : + XOTclRemovePMethod(interp, (XOTcl_Object *)obj, nameStr); } else { XOTclAssertionStore *aStore = NULL; if (precondition || postcondition) { - XOTclObjectOpt *opt = XOTclRequireObjectOpt(obj); - if (!opt->assertions) - opt->assertions = AssertionCreateStore(); - aStore = opt->assertions; + if (cl) { + XOTclClassOpt *opt = XOTclRequireClassOpt(cl); + if (!opt->assertions) + opt->assertions = AssertionCreateStore(); + aStore = opt->assertions; + } else { + XOTclObjectOpt *opt = XOTclRequireObjectOpt(obj); + if (!opt->assertions) + opt->assertions = AssertionCreateStore(); + aStore = opt->assertions; + } } - requireObjNamespace(interp, obj); - result = MakeProc(obj->nsPtr, aStore, - interp, name, args, body, precondition, postcondition, - obj, clsns); + result = MakeProc(cl ? cl->nsPtr : obj->nsPtr, aStore, + interp, nameObj, args, body, precondition, postcondition, + obj, withProtected, clsns); } - /* could be a filter => recompute filter order */ - FilterComputeDefined(interp, obj); - return result; -} - -static int MakeClassMethod(Tcl_Interp *interp, XOTclClass *cl, - Tcl_Obj *nameObj, Tcl_Obj *args, Tcl_Obj *body, - Tcl_Obj *precondition, Tcl_Obj *postcondition, int clsns) { - XOTclClassOpt *opt = cl->opt; - int result = TCL_OK; - char *argStr = ObjStr(args), *bdyStr = ObjStr(body), *nameStr = ObjStr(nameObj); - - if ((cl->object.flags & XOTCL_IS_ROOT_CLASS && isDestroyString(nameStr)) || - (cl->object.flags & XOTCL_IS_ROOT_META_CLASS && isDeallocString(nameStr)) || - (cl->object.flags & XOTCL_IS_ROOT_META_CLASS && isAllocString(nameStr)) || - (cl->object.flags & XOTCL_IS_ROOT_META_CLASS && isCreateString(nameStr))) - return XOTclVarErrMsg(interp, className(cl), " method '", nameStr, "' of ", - className(cl), " can not be overwritten. Derive a ", - "sub-class", (char *) NULL); - if (precondition && !postcondition) { - return XOTclVarErrMsg(interp, className(cl), " method '", nameStr, - "'; when specifying a precondition (", ObjStr(precondition), - ") a postcondition must be specified as well", - (char *) NULL); - } - - /* if both, args and body are empty strings, we delete the method */ - if (*argStr == 0 && *bdyStr == 0) { - result = XOTclRemoveIMethod(interp, (XOTcl_Class *)cl, nameStr); + if (cl) { + /* could be a filter or filter inheritance ... update filter orders */ + FilterInvalidateObjOrders(interp, cl); } else { - XOTclAssertionStore *aStore = NULL; - if (precondition || postcondition) { - opt = XOTclRequireClassOpt(cl); - if (!opt->assertions) - opt->assertions = AssertionCreateStore(); - aStore = opt->assertions; - } - result = MakeProc(cl->nsPtr, aStore, - interp, nameObj, args, body, precondition, postcondition, - &cl->object, clsns); + /* could be a filter => recompute filter order */ + FilterComputeDefined(interp, obj); } - /* could be a filter or filter inheritance ... update filter orders */ - FilterInvalidateObjOrders(interp, cl); - return result; } @@ -8874,7 +8847,8 @@ return XOTclVarErrMsg(interp, pcPtr->obj ? objectName(pcPtr->obj) : "", pcPtr->obj ? " " : "", ObjStr(pcPtr->full_objv[0]), ": required argument '", - ObjStr(pPtr->nameObj), "' is missing", (char *) NULL); + pPtr->nameObj ? ObjStr(pPtr->nameObj) : pPtr->name, + "' is missing", (char *) NULL); } else { /* Use as dummy default value an arbitrary symbol, which must not be * returned to the Tcl level level; this value is @@ -9401,7 +9375,7 @@ char allocation; Tcl_CmdDeleteProc *dp = NULL; aliasCmdClientData *tcd = NULL; - int flags = 0; + int flags = 0, result; if (XOTclObjectIsClass(object)) { cl = (XOTclClass *)object; @@ -9449,13 +9423,13 @@ } if (allocation == 'c') { - XOTclAddInstanceMethod(interp, (XOTcl_Class*)cl, methodName, + result = XOTclAddInstanceMethod(interp, (XOTcl_Class*)cl, methodName, objProc, tcd, dp, flags); } else { - XOTclAddObjectMethod(interp, (XOTcl_Object*)object, methodName, + result = XOTclAddObjectMethod(interp, (XOTcl_Object*)object, methodName, objProc, tcd, dp, flags); } - return TCL_OK; + return result; } static int XOTclConfigureCmd(Tcl_Interp *interp, int configureoption, Tcl_Obj *value) { @@ -9784,7 +9758,6 @@ XOTclClass *cl; Tcl_Command cmd = NULL; char allocation; - int protected = 0; /* TODO: introspection for method properties */ @@ -9817,16 +9790,26 @@ (char *) NULL); } - if (methodproperty == methodpropertyProtectedIdx || methodproperty == methodpropertyPublicIdx) { - protected = (methodproperty == methodpropertyProtectedIdx); + if (methodproperty == methodpropertyProtectedIdx + || methodproperty == methodpropertyStaticIdx) { - if (protected) { - Tcl_Command_flags(cmd) |= XOTCL_CMD_PROTECTED_METHOD; - } else { - Tcl_Command_flags(cmd) &= XOTCL_CMD_PROTECTED_METHOD; - } - /* TODO check: what about procs? */ + int flag = methodproperty == methodpropertyProtectedIdx ? + XOTCL_CMD_PROTECTED_METHOD : + XOTCL_CMD_STATIC_METHOD; + if (value) { + int bool, result; + result = Tcl_GetBooleanFromObj(interp, value, &bool); + if (result != TCL_OK) { + return result; + } + if (bool) { + Tcl_Command_flags(cmd) |= flag; + } else { + Tcl_Command_flags(cmd) &= ~flag; + } + } + Tcl_SetIntObj(Tcl_GetObjResult(interp), (Tcl_Command_flags(cmd) & flag) != 0); } else { /* slotobj */ XOTclParamDefs *paramDefs; @@ -10890,8 +10873,7 @@ } static int XOTclOParametercmdMethod(Tcl_Interp *interp, XOTclObject *obj, char *name) { - XOTclAddObjectMethod(interp, (XOTcl_Object*) obj, name, (Tcl_ObjCmdProc*)XOTclSetterMethod, 0, 0, 0); - return TCL_OK; + return XOTclAddObjectMethod(interp, (XOTcl_Object*) obj, name, (Tcl_ObjCmdProc*)XOTclSetterMethod, 0, 0, 0); } static int XOTclOProcSearchMethod(Tcl_Interp *interp, XOTclObject *obj, char *name) { @@ -10981,9 +10963,9 @@ target, nobjc, nobjv, &tcd); if (result == TCL_OK) { tcd->obj = obj; - XOTclAddPMethod(interp, (XOTcl_Object *)obj, NSTail(ObjStr(method)), - (Tcl_ObjCmdProc*)XOTclForwardMethod, - (ClientData)tcd, forwardCmdDeleteProc); + result = XOTclAddObjectMethod(interp, (XOTcl_Object *)obj, NSTail(ObjStr(method)), + (Tcl_ObjCmdProc*)XOTclForwardMethod, + (ClientData)tcd, forwardCmdDeleteProc, 0); } return result; } @@ -11372,39 +11354,36 @@ } static int XOTclCInstParametercmdMethod(Tcl_Interp *interp, XOTclClass *cl, char *name) { - XOTclAddInstanceMethod(interp, (XOTcl_Class *)cl, name, (Tcl_ObjCmdProc*)XOTclSetterMethod, 0, 0, 0); - return TCL_OK; + return XOTclAddInstanceMethod(interp, (XOTcl_Class *)cl, name, (Tcl_ObjCmdProc*)XOTclSetterMethod, 0, 0, 0); } /* TODO move me at the right place */ static int XOTclOMethodMethod(Tcl_Interp *interp, XOTclObject *obj, - int withInner_namespace, + int withInner_namespace, int withProtected, Tcl_Obj *name, Tcl_Obj *args, Tcl_Obj *body, Tcl_Obj *withPrecondition, Tcl_Obj *withPostcondition) { - return MakeObjectMethod(interp, obj, name, args, body, - withPrecondition, withPostcondition, - withInner_namespace); + requireObjNamespace(interp, obj); + return MakeMethod(interp, obj, NULL, name, args, body, + withPrecondition, withPostcondition, + withProtected, withInner_namespace); } + /* TODO move me at the right place */ static int XOTclCMethodMethod(Tcl_Interp *interp, XOTclClass *cl, - int withPer_object, int withInner_namespace, + int withInner_namespace, int withPer_object, int withProtected, Tcl_Obj *name, Tcl_Obj *args, Tcl_Obj *body, Tcl_Obj *withPrecondition, Tcl_Obj *withPostcondition) { if (withPer_object) { - return MakeObjectMethod(interp, &cl->object, name, args, body, - withPrecondition, withPostcondition, withInner_namespace); + requireObjNamespace(interp, &cl->object); + return MakeMethod(interp, &cl->object, NULL, name, args, body, + withPrecondition, withPostcondition, + withProtected, withInner_namespace); } else { - return MakeClassMethod(interp, cl, name, args, body, - withPrecondition, withPostcondition, withInner_namespace); + return MakeMethod(interp, &cl->object, cl, name, args, body, + withPrecondition, withPostcondition, + withProtected, withInner_namespace); } } -static int XOTclCInstProcMethodC(Tcl_Interp *interp, XOTclClass *cl, - Tcl_Obj *name, Tcl_Obj *args, Tcl_Obj *body, - Tcl_Obj *precondition, Tcl_Obj *postcondition) { - return MakeClassMethod(interp, cl, name, args, body, precondition, postcondition, 1); -} - - static int XOTclCInstForwardMethod(Tcl_Interp *interp, XOTclClass *cl, Tcl_Obj *method, Tcl_Obj *withDefault, int withEarlybinding, Tcl_Obj *withMethodprefix, int withObjscope, Tcl_Obj *withOnerror, int withVerbose, @@ -11416,12 +11395,11 @@ withDefault, withEarlybinding, withMethodprefix, withObjscope, withOnerror, withVerbose, target, nobjc, nobjv, &tcd); - if (result == TCL_OK) { tcd->obj = &cl->object; - XOTclAddIMethod(interp, (XOTcl_Class*)cl, NSTail(ObjStr(method)), - (Tcl_ObjCmdProc*)XOTclForwardMethod, - (ClientData)tcd, forwardCmdDeleteProc); + result = XOTclAddInstanceMethod(interp, (XOTcl_Class*)cl, NSTail(ObjStr(method)), + (Tcl_ObjCmdProc*)XOTclForwardMethod, + (ClientData)tcd, forwardCmdDeleteProc, 0); } return result; } @@ -11455,17 +11433,6 @@ return result; } -static int XOTclCUnknownMethod(Tcl_Interp *interp, XOTclClass *cl, char *name, - int objc, Tcl_Obj *CONST objv[]) { - if (isCreateString(name)) - return XOTclVarErrMsg(interp, "error ", className(cl), ": unable to dispatch '", - name, "'", (char *)NULL); - - return callMethod((ClientData)cl, interp, XOTclGlobalObjects[XOTE_CREATE], objc+1, objv+1, 0); -} - - - /*************************** * End Class Methods ***************************/ @@ -11963,18 +11930,7 @@ if (RUNTIME_STATE(interp)->cs.top->currentFramePtr == NULL) { RUNTIME_STATE(interp)->cs.top->currentFramePtr = varFramePtr; - } /* else { - - fprintf(stderr, "not overwriting currentFramePtr in %p from %p to %p\n", - RUNTIME_STATE(interp)->cs.top, - RUNTIME_STATE(interp)->cs.top->currentFramePtr, varFramePtr); - } */ - -#if !defined(NAMESPACEINSTPROCS) - if (varFramePtr) { - varFramePtr->nsPtr = GetCallerVarFrame(interp, varFramePtr); - } -#endif + } return TCL_OK; } #endif Index: generic/xotcl.decls =================================================================== diff -u -rd58e86e7557ee729a2a687854c4107d4b212cf35 -ra4d1fd30453e4e87467b02ed749fb4007d46a5e0 --- generic/xotcl.decls (.../xotcl.decls) (revision d58e86e7557ee729a2a687854c4107d4b212cf35) +++ generic/xotcl.decls (.../xotcl.decls) (revision a4d1fd30453e4e87467b02ed749fb4007d46a5e0) @@ -55,16 +55,16 @@ declare 10 generic { int XOTclDeleteClass(Tcl_Interp *interp, struct XOTcl_Class *cl) } -declare 11 generic { - Tcl_Command XOTclAddPMethod(Tcl_Interp *interp, struct XOTcl_Object *obj, - CONST char* nm, Tcl_ObjCmdProc* proc, - ClientData cd, Tcl_CmdDeleteProc *dp) -} -declare 12 generic { - Tcl_Command XOTclAddIMethod(Tcl_Interp *interp, struct XOTcl_Class *cl, - CONST char* nm, Tcl_ObjCmdProc* proc, - ClientData cd, Tcl_CmdDeleteProc *dp) -} +#declare 11 generic { +# int XOTclAddPMethod(Tcl_Interp *interp, struct XOTcl_Object *obj, +# CONST char* nm, Tcl_ObjCmdProc* proc, +# ClientData cd, Tcl_CmdDeleteProc *dp) +#} +#declare 12 generic { +# int XOTclAddIMethod(Tcl_Interp *interp, struct XOTcl_Class *cl, +# CONST char* nm, Tcl_ObjCmdProc* proc, +# ClientData cd, Tcl_CmdDeleteProc *dp) +#} declare 13 generic { int XOTclRemovePMethod(Tcl_Interp *interp,struct XOTcl_Object *obj, char *nm) } @@ -164,12 +164,12 @@ char *arglist) } declare 41 generic { - Tcl_Command XOTclAddObjectMethod(Tcl_Interp *interp, struct XOTcl_Object *obj, + int XOTclAddObjectMethod(Tcl_Interp *interp, struct XOTcl_Object *obj, CONST char *nm, Tcl_ObjCmdProc *proc, ClientData cd, Tcl_CmdDeleteProc *dp, int flags) } declare 42 generic { - Tcl_Command XOTclAddInstanceMethod(Tcl_Interp *interp, struct XOTcl_Class *cl, + int XOTclAddInstanceMethod(Tcl_Interp *interp, struct XOTcl_Class *cl, CONST char *nm, Tcl_ObjCmdProc *proc, ClientData cd, Tcl_CmdDeleteProc *dp, int flags) } Index: generic/xotcl.h =================================================================== diff -u -r6c7f27084c9ec8964db4fb29623fa956aaf65999 -ra4d1fd30453e4e87467b02ed749fb4007d46a5e0 --- generic/xotcl.h (.../xotcl.h) (revision 6c7f27084c9ec8964db4fb29623fa956aaf65999) +++ generic/xotcl.h (.../xotcl.h) (revision a4d1fd30453e4e87467b02ed749fb4007d46a5e0) @@ -40,9 +40,6 @@ # endif #endif -/* new namespace support (post 1.2.0) */ -#define NAMESPACEINSTPROCS 1 - /* activate bytecode support #define XOTCL_BYTECODE */ @@ -52,10 +49,6 @@ #define PROFILE */ -/* make self, proc and class in instproc and procs -#define AUTOVARS -*/ - /* activate/deacticate assert #define NDEBUG 1 @@ -133,8 +126,9 @@ #endif #define XOTCL_CMD_PROTECTED_METHOD 0x00010000 +#define XOTCL_CMD_STATIC_METHOD 0x00020000 /* XOTCL_CMD_NONLEAF_METHOD is used to flag, if a Method implemented via cmd calls "next" */ -#define XOTCL_CMD_NONLEAF_METHOD 0x00020000 +#define XOTCL_CMD_NONLEAF_METHOD 0x00040000 /* * A special definition used to allow this header file to be included Index: generic/xotclDecls.h =================================================================== diff -u -rd58e86e7557ee729a2a687854c4107d4b212cf35 -ra4d1fd30453e4e87467b02ed749fb4007d46a5e0 --- generic/xotclDecls.h (.../xotclDecls.h) (revision d58e86e7557ee729a2a687854c4107d4b212cf35) +++ generic/xotclDecls.h (.../xotclDecls.h) (revision a4d1fd30453e4e87467b02ed749fb4007d46a5e0) @@ -73,22 +73,8 @@ EXTERN int XOTclDeleteClass (Tcl_Interp * interp, struct XOTcl_Class * cl); #endif -#ifndef XOTclAddPMethod_TCL_DECLARED -#define XOTclAddPMethod_TCL_DECLARED -/* 11 */ -EXTERN Tcl_Command XOTclAddPMethod (Tcl_Interp * interp, - struct XOTcl_Object * obj, CONST char* nm, - Tcl_ObjCmdProc* proc, ClientData cd, - Tcl_CmdDeleteProc * dp); -#endif -#ifndef XOTclAddIMethod_TCL_DECLARED -#define XOTclAddIMethod_TCL_DECLARED -/* 12 */ -EXTERN Tcl_Command XOTclAddIMethod (Tcl_Interp * interp, - struct XOTcl_Class * cl, CONST char* nm, - Tcl_ObjCmdProc* proc, ClientData cd, - Tcl_CmdDeleteProc * dp); -#endif +/* Slot 11 is reserved */ +/* Slot 12 is reserved */ #ifndef XOTclRemovePMethod_TCL_DECLARED #define XOTclRemovePMethod_TCL_DECLARED /* 13 */ @@ -245,15 +231,15 @@ #ifndef XOTclAddObjectMethod_TCL_DECLARED #define XOTclAddObjectMethod_TCL_DECLARED /* 41 */ -EXTERN Tcl_Command XOTclAddObjectMethod (Tcl_Interp * interp, +EXTERN int XOTclAddObjectMethod (Tcl_Interp * interp, struct XOTcl_Object * obj, CONST char * nm, Tcl_ObjCmdProc * proc, ClientData cd, Tcl_CmdDeleteProc * dp, int flags); #endif #ifndef XOTclAddInstanceMethod_TCL_DECLARED #define XOTclAddInstanceMethod_TCL_DECLARED /* 42 */ -EXTERN Tcl_Command XOTclAddInstanceMethod (Tcl_Interp * interp, +EXTERN int XOTclAddInstanceMethod (Tcl_Interp * interp, struct XOTcl_Class * cl, CONST char * nm, Tcl_ObjCmdProc * proc, ClientData cd, Tcl_CmdDeleteProc * dp, int flags); @@ -285,8 +271,8 @@ int (*xOTclCreateClass) (Tcl_Interp * interp, Tcl_Obj * name, struct XOTcl_Class * cl); /* 8 */ int (*xOTclDeleteObject) (Tcl_Interp * interp, struct XOTcl_Object * obj); /* 9 */ int (*xOTclDeleteClass) (Tcl_Interp * interp, struct XOTcl_Class * cl); /* 10 */ - Tcl_Command (*xOTclAddPMethod) (Tcl_Interp * interp, struct XOTcl_Object * obj, CONST char* nm, Tcl_ObjCmdProc* proc, ClientData cd, Tcl_CmdDeleteProc * dp); /* 11 */ - Tcl_Command (*xOTclAddIMethod) (Tcl_Interp * interp, struct XOTcl_Class * cl, CONST char* nm, Tcl_ObjCmdProc* proc, ClientData cd, Tcl_CmdDeleteProc * dp); /* 12 */ + void *reserved11; + void *reserved12; int (*xOTclRemovePMethod) (Tcl_Interp * interp, struct XOTcl_Object * obj, char * nm); /* 13 */ int (*xOTclRemoveIMethod) (Tcl_Interp * interp, struct XOTcl_Class * cl, char * nm); /* 14 */ Tcl_Obj * (*xOTclOSetInstVar) (struct XOTcl_Object * obj, Tcl_Interp * interp, Tcl_Obj * name, Tcl_Obj * value, int flgs); /* 15 */ @@ -315,8 +301,8 @@ int (*xOTclNextObjCmd) (ClientData cd, Tcl_Interp * interp, int objc, Tcl_Obj *CONST objv[]); /* 38 */ int (*xOTclCallMethodWithArgs) (ClientData cd, Tcl_Interp * interp, Tcl_Obj * method, Tcl_Obj * arg, int objc, Tcl_Obj *CONST objv[], int flags); /* 39 */ int (*xOTclObjErrArgCnt) (Tcl_Interp * interp, Tcl_Obj * cmdName, Tcl_Obj * methodName, char * arglist); /* 40 */ - Tcl_Command (*xOTclAddObjectMethod) (Tcl_Interp * interp, struct XOTcl_Object * obj, CONST char * nm, Tcl_ObjCmdProc * proc, ClientData cd, Tcl_CmdDeleteProc * dp, int flags); /* 41 */ - Tcl_Command (*xOTclAddInstanceMethod) (Tcl_Interp * interp, struct XOTcl_Class * cl, CONST char * nm, Tcl_ObjCmdProc * proc, ClientData cd, Tcl_CmdDeleteProc * dp, int flags); /* 42 */ + int (*xOTclAddObjectMethod) (Tcl_Interp * interp, struct XOTcl_Object * obj, CONST char * nm, Tcl_ObjCmdProc * proc, ClientData cd, Tcl_CmdDeleteProc * dp, int flags); /* 41 */ + int (*xOTclAddInstanceMethod) (Tcl_Interp * interp, struct XOTcl_Class * cl, CONST char * nm, Tcl_ObjCmdProc * proc, ClientData cd, Tcl_CmdDeleteProc * dp, int flags); /* 42 */ int (*xOTclCreate) (Tcl_Interp * in, XOTcl_Class * class, Tcl_Obj * name, ClientData data, int objc, Tcl_Obj *CONST objv[]); /* 43 */ } XotclStubs; @@ -369,14 +355,8 @@ #define XOTclDeleteClass \ (xotclStubsPtr->xOTclDeleteClass) /* 10 */ #endif -#ifndef XOTclAddPMethod -#define XOTclAddPMethod \ - (xotclStubsPtr->xOTclAddPMethod) /* 11 */ -#endif -#ifndef XOTclAddIMethod -#define XOTclAddIMethod \ - (xotclStubsPtr->xOTclAddIMethod) /* 12 */ -#endif +/* Slot 11 is reserved */ +/* Slot 12 is reserved */ #ifndef XOTclRemovePMethod #define XOTclRemovePMethod \ (xotclStubsPtr->xOTclRemovePMethod) /* 13 */ Index: generic/xotclInt.h =================================================================== diff -u -rd03aa65bff84b01cbdd418581c35faec809cb50f -ra4d1fd30453e4e87467b02ed749fb4007d46a5e0 --- generic/xotclInt.h (.../xotclInt.h) (revision d03aa65bff84b01cbdd418581c35faec809cb50f) +++ generic/xotclInt.h (.../xotclInt.h) (revision a4d1fd30453e4e87467b02ed749fb4007d46a5e0) @@ -111,14 +111,9 @@ #define isArgsString(m) (\ *m == 'a' && m[1] == 'r' && m[2] == 'g' && m[3] == 's' && \ m[4] == '\0') -#define isDoubleDashString(m) (\ - *m == '-' && m[1] == '-' && m[2] == '\0') #define isBodyString(m) (\ *m == 'b' && m[1] == 'o' && m[2] == 'd' && m[3] == 'y' && \ m[4] == '\0') -#define isClassString(m) (\ - *m == 'c' && m[1] == 'l' && m[2] == 'a' && m[3] == 's' && \ - m[4] == 's' && m[5] == '\0') #define isCheckString(m) (\ *m == 'c' && m[1] == 'h' && m[2] == 'e' && m[3] == 'c' && \ m[4] == 'k' && m[5] == '\0') @@ -129,26 +124,12 @@ #define isCreateString(m) (\ *m == 'c' && m[1] == 'r' && m[2] == 'e' && m[3] == 'a' && \ m[4] == 't' && m[5] == 'e' && m[6] == '\0') -#define isAllocString(m) (\ - *m == 'a' && m[1] == 'l' && m[2] == 'l' && m[3] == 'o' && \ - m[4] == 'c' && m[5] == '\0') -#define isDeallocString(m) (\ - *m == 'd' && m[1] == 'e' && m[2] == 'a' && m[3] == 'l' && \ - m[4] == 'l' && m[5] == 'o' && m[6] == 'c' && m[7] == '\0') -#define isDestroyString(m) (\ - *m == 'd' && m[1] == 'e' && m[2] == 's' && m[3] == 't' && \ - m[4] == 'r' && m[5] == 'o' && m[6] == 'y' && m[7] == '\0') #define isInitString(m) (\ *m == 'i' && m[1] == 'n' && m[2] == 'i' && m[3] == 't' && \ m[4] == '\0') #define isInfoString(m) (\ *m == 'i' && m[1] == 'n' && m[2] == 'f' && m[3] == 'o' && \ m[4] == '\0') -#ifdef AUTOVARS -# define isNextString(m) (\ - *m == 'n' && m[1] == 'e' && m[2] == 'x' && m[3] == 't' && \ - m[4] == '\0') -#endif #define isInstinvarString(m) (\ *m == 'i' && m[1] == 'n' && m[2] == 's' && m[3] == 't' && \ m[4] == 'i' && m[5] == 'n' && m[6] == 'v' && m[7] == 'a' && \ Index: generic/xotclStubInit.c =================================================================== diff -u -rd58e86e7557ee729a2a687854c4107d4b212cf35 -ra4d1fd30453e4e87467b02ed749fb4007d46a5e0 --- generic/xotclStubInit.c (.../xotclStubInit.c) (revision d58e86e7557ee729a2a687854c4107d4b212cf35) +++ generic/xotclStubInit.c (.../xotclStubInit.c) (revision a4d1fd30453e4e87467b02ed749fb4007d46a5e0) @@ -47,8 +47,8 @@ XOTclCreateClass, /* 8 */ XOTclDeleteObject, /* 9 */ XOTclDeleteClass, /* 10 */ - XOTclAddPMethod, /* 11 */ - XOTclAddIMethod, /* 12 */ + NULL, /* 11 */ + NULL, /* 12 */ XOTclRemovePMethod, /* 13 */ XOTclRemoveIMethod, /* 14 */ XOTclOSetInstVar, /* 15 */ Index: tests/testx.xotcl =================================================================== diff -u -raef09781efb62a6336ecf355e927549d72b37a7a -ra4d1fd30453e4e87467b02ed749fb4007d46a5e0 --- tests/testx.xotcl (.../testx.xotcl) (revision aef09781efb62a6336ecf355e927549d72b37a7a) +++ tests/testx.xotcl (.../testx.xotcl) (revision a4d1fd30453e4e87467b02ed749fb4007d46a5e0) @@ -3069,7 +3069,7 @@ ::errorCheck [b info methods -nocmds -noprocs] "" "b info methods -nocmds -noprocs" - ::errorCheck [lsort [B info methods -nocmds]] "abstract allinstances contains copy defaultmethod extractConfigureArg f hasclass init instproc isclass ismetaclass ismixin isobject istype move objectparameter parameter proc self setFilter signature uses" "B info methods -nocmds" + ::errorCheck [lsort [B info methods -nocmds]] "abstract allinstances contains copy defaultmethod extractConfigureArg f hasclass init instproc isclass ismetaclass ismixin isobject istype move objectparameter parameter proc self setFilter signature unknown uses" "B info methods -nocmds" namespace eval a { proc o args {return o} @@ -3323,7 +3323,8 @@ ::errorCheck [E info args p] "a b c" "args" ::errorCheck [E info default p c x] 1 "default" ::errorCheck [E configure [list -p -x -y]] {} "list params 1" - ::errorCheck [E e1 [list -t -1 -e -3]] ::e1 "list params 2" + #::errorCheck [E e1 [list -t -1 -e -3]] ::e1 "list params 2"; # TODO worked in 1.6 + ::errorCheck [E create e1 [list -t -1 -e -3]] ::e1 "list params 2" ::errorCheck [e1 x] 1 "instparameter cmd 1" ::errorCheck [e1 x 2] 2 "instparameter cmd 2" ::errorCheck [e1 x] 2 "instparameter cmd 3"