Index: TODO =================================================================== diff -u -r0fc068c3ea858736283e8add7c273253cd5a2a47 -rdfaca66a33107320eac62bde6ac8ea15abbcbe83 --- TODO (.../TODO) (revision 0fc068c3ea858736283e8add7c273253cd5a2a47) +++ TODO (.../TODO) (revision dfaca66a33107320eac62bde6ac8ea15abbcbe83) @@ -3813,10 +3813,16 @@ specification". Also: "-returns" spec is not included in "info method definition". +- simplified usage of ObjectName() and ClassName() macros (no caller parenthesis needed) +- added exerpimental object property keepcaller self (currently only evaluated by aliased objects) ======================================================================== TODO: +- remove settings of keepcallerself infrom destroy.test labeld with + "# TODO: fixme; should probably be not necessary" + currently, without these, we have recursive loops. + - Aliases and forwards are not handled by NsfNSCopyCmdsCmd; object cloning/copying remains incomplete; also, there might be object and method properties not handled as well (as the "returns" method Index: generic/nsf.c =================================================================== diff -u -r4f17631ecd74cd12f18168931a93b46908cec01b -rdfaca66a33107320eac62bde6ac8ea15abbcbe83 --- generic/nsf.c (.../nsf.c) (revision 4f17631ecd74cd12f18168931a93b46908cec01b) +++ generic/nsf.c (.../nsf.c) (revision dfaca66a33107320eac62bde6ac8ea15abbcbe83) @@ -2996,7 +2996,7 @@ methodObj = osPtr->methods[methodIdx]; /*fprintf(stderr, "OS of %s is %s, method %s methodObj %p osPtr %p defined %.8x %.8x overloaded %.8x %.8x flags %.8x\n", - ObjectName(object), ObjectName((&osPtr->rootClass->object)), + ObjectName(object), ObjectName(&osPtr->rootClass->object), Nsf_SystemMethodOpts[methodIdx]+1, methodObj, osPtr, osPtr->definedMethods, osPtr->definedMethods & (1 << methodIdx), @@ -9560,10 +9560,11 @@ cscPtr->flags |= NSF_CSC_CALL_IS_ENSEMBLE; /* - * The client data cp is still the obj of the called method + * The client data cp is still the obj (the ensemble object) of the called method */ - /*fprintf(stderr, "ensemble dispatch %s objc %d\n", methodName, objc);*/ + /*fprintf(stderr, "ensemble dispatch cp %s %s objc %d\n", + ObjectName((NsfObject*)cp), methodName, objc);*/ if (unlikely(objc < 2)) { CallFrame frame, *framePtr = &frame; @@ -9598,14 +9599,25 @@ * they were executed later, they would find their parent frame * (CMETHOD) being popped from the stack already. */ - - /*fprintf(stderr, ".... ensemble dispatch on %s.%s cscPtr %p base flags %.6x cl %s\n", - ObjectName(object), methodName, cscPtr, - (0xFF & cscPtr->flags), - cscPtr->cl ? ObjStr(cscPtr->cl->object.cmdName) : NULL);*/ - - result = MethodDispatch(object, interp, objc-1, objv+1, - cmd, object, cscPtr->cl, methodName, + // FIXME: decls should not stay here, can / should we reuse other vars? + NsfObject *newSelf; + NsfClass *newClass; + if (self->flags & NSF_KEEP_CALLER_SELF) { + newSelf = object; + newClass = cscPtr->cl; + } else { + newSelf = self; + newClass = NULL; + } + /*fprintf(stderr, ".... ensemble dispatch object %s self %s pass %s\n", + ObjectName(object), ObjectName(self), (self->flags & NSF_KEEP_CALLER_SELF) ? "object" : "self");*/ + /*fprintf(stderr, ".... ensemble dispatch on %s.%s objflags %.8x cscPtr %p base flags %.6x cl %s\n", + ObjectName(newSelf), methodName, self->flags, + cscPtr, (0xFF & cscPtr->flags), + newClass ? ClassName(newClass) : "NONE");*/ + result = MethodDispatch(newSelf, + interp, objc-1, objv+1, + cmd, newSelf, newClass, methodName, cscPtr->frameType|NSF_CSC_TYPE_ENSEMBLE, (cscPtr->flags & 0xFF)|NSF_CSC_IMMEDIATE); goto obj_dispatch_ok; @@ -9705,7 +9717,7 @@ /* * The cmd has no client data. In these situations, no stack frame * is needed. Dispatch the method without the cscPtr, such - * CmdMethodDispatch () does not stack a frame. + * CmdMethodDispatch() does not stack a frame. */ CscListAdd(interp, cscPtr); @@ -17384,6 +17396,7 @@ Tcl_Command importedCmd; Tcl_ObjCmdProc *proc, *resolvedProc; + assert(isObject); proc = Tcl_Command_objProc(cmd); importedCmd = GetOriginalCommand(cmd); resolvedProc = Tcl_Command_objProc(importedCmd); @@ -17533,6 +17546,9 @@ } else { + /* + * We have to iterate over the elements + */ for (hPtr = Tcl_FirstHashEntry(tablePtr, &hSrch); hPtr; hPtr = Tcl_NextHashEntry(&hSrch)) { @@ -17907,6 +17923,38 @@ } #endif +/* + *---------------------------------------------------------------------- + * SetBooleanFlag -- + * + * Set an unsigned short flag based on valueObj + * + * Results: + * Tcl result code + * + * Side effects: + * update passed flags + * + *---------------------------------------------------------------------- + */ + +static int +SetBooleanFlag(Tcl_Interp *interp, unsigned short *flagsPtr, unsigned short flag, Tcl_Obj *valueObj) { + int bool, result; + + assert(flagsPtr); + result = Tcl_GetBooleanFromObj(interp, valueObj, &bool); + if (result != TCL_OK) { + return result; + } + if (bool) { + *flagsPtr |= flag; + } else { + *flagsPtr &= ~flag; + } + return result; +} + /*********************************************************************** * Begin generated Next Scripting commands ***********************************************************************/ @@ -18929,16 +18977,10 @@ } flag = NSF_IS_SLOT_CONTAINER; if (valueObj) { - int bool, result; - result = Tcl_GetBooleanFromObj(interp, valueObj, &bool); + int result = SetBooleanFlag(interp, &containerObject->flags, flag, valueObj); if (result != TCL_OK) { return result; } - if (bool) { - containerObject->flags |= flag; - } else { - containerObject->flags &= ~flag; - } } Tcl_SetIntObj(Tcl_GetObjResult(interp), (containerObject->flags & flag) != 0); break; @@ -19263,22 +19305,36 @@ /* cmd "object::property" NsfObjectPropertyCmd { {-argName "objectName" -required 1 -type object} - {-argName "objectproperty" -type "initialized|class|rootmetaclass|rootclass|slotcontainer" -required 1} + {-argName "objectproperty" -type "initialized|class|rootmetaclass|rootclass|slotcontainer|keepcallerself" -required 1} + {-argName "value" -required 0 -type tclobj} } */ + static int -NsfObjectPropertyCmd(Tcl_Interp *interp, NsfObject *object, int objectproperty) { - int flags = 0;; +NsfObjectPropertyCmd(Tcl_Interp *interp, NsfObject *object, int objectproperty, Tcl_Obj *valueObj) { + int flags = 0, allowSet = 0; switch (objectproperty) { case ObjectpropertyInitializedIdx: flags = NSF_INIT_CALLED; break; case ObjectpropertyClassIdx: flags = NSF_IS_CLASS; break; case ObjectpropertyRootmetaclassIdx: flags = NSF_IS_ROOT_META_CLASS; break; case ObjectpropertyRootclassIdx: flags = NSF_IS_ROOT_CLASS; break; case ObjectpropertySlotcontainerIdx: flags = NSF_IS_SLOT_CONTAINER; break; + case ObjectpropertyKeepcallerselfIdx: flags = NSF_KEEP_CALLER_SELF; allowSet = 1; break; } - Tcl_SetObjResult(interp, + if (valueObj) { + if (likely(allowSet)) { + int result = SetBooleanFlag(interp, &object->flags, flags, valueObj); + if (result != TCL_OK) { + return result; + } + } else { + return NsfPrintError(interp, "object property is read only"); + } + } + + Tcl_SetObjResult(interp, NsfGlobalObjs[(object->flags & flags) ? NSF_ONE : NSF_ZERO]); return TCL_OK; @@ -19410,8 +19466,8 @@ AddSuper(thecls, theobj); if (NSF_DTRACE_OBJECT_ALLOC_ENABLED()) { - NSF_DTRACE_OBJECT_ALLOC(ObjectName(((NsfObject *)theobj)), ClassName(((NsfObject *)theobj)->cl)); - NSF_DTRACE_OBJECT_ALLOC(ObjectName(((NsfObject *)thecls)), ClassName(((NsfObject *)thecls)->cl)); + NSF_DTRACE_OBJECT_ALLOC(ObjectName((NsfObject *)theobj), ClassName((NsfObject *)theobj)->cl); + NSF_DTRACE_OBJECT_ALLOC(ObjectName((NsfObject *)thecls), ClassName((NsfObject *)thecls)->cl); } return TCL_OK; @@ -22100,7 +22156,7 @@ } else { /*NsfObjectSystem *osPtr = GetObjectSystem(object); fprintf(stderr, "RECREATE calls method cleanup for object %p %s OS %s\n", - object, ObjectName(object), ObjectName((&osPtr->rootClass->object)));*/ + object, ObjectName(object), ObjectName(&osPtr->rootClass->object));*/ result = CallMethod(object, interp, methodObj, 2, 0, NSF_CM_IGNORE_PERMISSIONS|NSF_CSC_IMMEDIATE); } Index: generic/nsfAPI.decls =================================================================== diff -u -re530487c1945b471b745838c3168e1b3788d48c5 -rdfaca66a33107320eac62bde6ac8ea15abbcbe83 --- generic/nsfAPI.decls (.../nsfAPI.decls) (revision e530487c1945b471b745838c3168e1b3788d48c5) +++ generic/nsfAPI.decls (.../nsfAPI.decls) (revision dfaca66a33107320eac62bde6ac8ea15abbcbe83) @@ -151,7 +151,8 @@ } {-nxdoc 1} cmd "object::property" NsfObjectPropertyCmd { {-argName "objectName" -required 1 -type object} - {-argName "objectproperty" -type "initialized|class|rootmetaclass|rootclass|slotcontainer" -required 1} + {-argName "objectproperty" -type "initialized|class|rootmetaclass|rootclass|slotcontainer|keepcallerself" -required 1} + {-argName "value" -required 0 -type tclobj} } {-nxdoc 1} cmd "object::qualify" NsfObjectQualifyCmd { {-argName "objectName" -required 1 -type tclobj} Index: generic/nsfAPI.h =================================================================== diff -u -re530487c1945b471b745838c3168e1b3788d48c5 -rdfaca66a33107320eac62bde6ac8ea15abbcbe83 --- generic/nsfAPI.h (.../nsfAPI.h) (revision e530487c1945b471b745838c3168e1b3788d48c5) +++ generic/nsfAPI.h (.../nsfAPI.h) (revision dfaca66a33107320eac62bde6ac8ea15abbcbe83) @@ -148,12 +148,12 @@ return result; } -enum ObjectpropertyIdx {ObjectpropertyNULL, ObjectpropertyInitializedIdx, ObjectpropertyClassIdx, ObjectpropertyRootmetaclassIdx, ObjectpropertyRootclassIdx, ObjectpropertySlotcontainerIdx}; +enum ObjectpropertyIdx {ObjectpropertyNULL, ObjectpropertyInitializedIdx, ObjectpropertyClassIdx, ObjectpropertyRootmetaclassIdx, ObjectpropertyRootclassIdx, ObjectpropertySlotcontainerIdx, ObjectpropertyKeepcallerselfIdx}; static int ConvertToObjectproperty(Tcl_Interp *interp, Tcl_Obj *objPtr, Nsf_Param CONST *pPtr, ClientData *clientData, Tcl_Obj **outObjPtr) { int index, result; - static CONST char *opts[] = {"initialized", "class", "rootmetaclass", "rootclass", "slotcontainer", NULL}; + static CONST char *opts[] = {"initialized", "class", "rootmetaclass", "rootclass", "slotcontainer", "keepcallerself", NULL}; (void)pPtr; result = Tcl_GetIndexFromObj(interp, objPtr, opts, "objectproperty", 0, &index); *clientData = (ClientData) INT2PTR(index + 1); @@ -201,7 +201,7 @@ {ConvertToRelationtype, "object-mixin|class-mixin|object-filter|class-filter|class|superclass|rootclass"}, {ConvertToSource, "all|application|baseclasses"}, {ConvertToConfigureoption, "debug|dtrace|filter|profile|softrecreate|objectsystems|keepinitcmd|checkresults|checkarguments"}, - {ConvertToObjectproperty, "initialized|class|rootmetaclass|rootclass|slotcontainer"}, + {ConvertToObjectproperty, "initialized|class|rootmetaclass|rootclass|slotcontainer|keepcallerself"}, {ConvertToAssertionsubcmd, "check|object-invar|class-invar"}, {NULL, NULL} }; @@ -365,7 +365,7 @@ static int NsfNSCopyVarsCmd(Tcl_Interp *interp, Tcl_Obj *fromNs, Tcl_Obj *toNs); static int NsfNextCmd(Tcl_Interp *interp, Tcl_Obj *arguments); static int NsfObjectExistsCmd(Tcl_Interp *interp, Tcl_Obj *value); -static int NsfObjectPropertyCmd(Tcl_Interp *interp, NsfObject *objectName, int objectproperty); +static int NsfObjectPropertyCmd(Tcl_Interp *interp, NsfObject *objectName, int objectproperty, Tcl_Obj *value); static int NsfObjectQualifyCmd(Tcl_Interp *interp, Tcl_Obj *objectName); static int NsfObjectSystemCreateCmd(Tcl_Interp *interp, Tcl_Obj *rootClass, Tcl_Obj *rootMetaClass, Tcl_Obj *systemMethods); static int NsfProcCmd(Tcl_Interp *interp, int withAd, Tcl_Obj *procName, Tcl_Obj *arguments, Tcl_Obj *body); @@ -1556,9 +1556,10 @@ &pc) == TCL_OK)) { NsfObject *objectName = (NsfObject *)pc.clientData[0]; int objectproperty = (int )PTR2INT(pc.clientData[1]); + Tcl_Obj *value = (Tcl_Obj *)pc.clientData[2]; assert(pc.status == 0); - return NsfObjectPropertyCmd(interp, objectName, objectproperty); + return NsfObjectPropertyCmd(interp, objectName, objectproperty, value); } else { return TCL_ERROR; @@ -2686,9 +2687,10 @@ {"::nsf::object::exists", NsfObjectExistsCmdStub, 1, { {"value", NSF_ARG_REQUIRED, 1, Nsf_ConvertToTclobj, NULL,NULL,NULL,NULL,NULL,NULL,NULL,NULL}} }, -{"::nsf::object::property", NsfObjectPropertyCmdStub, 2, { +{"::nsf::object::property", NsfObjectPropertyCmdStub, 3, { {"objectName", NSF_ARG_REQUIRED, 1, Nsf_ConvertToObject, NULL,NULL,"object",NULL,NULL,NULL,NULL,NULL}, - {"objectproperty", NSF_ARG_REQUIRED|NSF_ARG_IS_ENUMERATION, 1, ConvertToObjectproperty, NULL,NULL,NULL,NULL,NULL,NULL,NULL,NULL}} + {"objectproperty", NSF_ARG_REQUIRED|NSF_ARG_IS_ENUMERATION, 1, ConvertToObjectproperty, NULL,NULL,NULL,NULL,NULL,NULL,NULL,NULL}, + {"value", 0, 1, Nsf_ConvertToTclobj, NULL,NULL,NULL,NULL,NULL,NULL,NULL,NULL}} }, {"::nsf::object::qualify", NsfObjectQualifyCmdStub, 1, { {"objectName", NSF_ARG_REQUIRED, 1, Nsf_ConvertToTclobj, NULL,NULL,NULL,NULL,NULL,NULL,NULL,NULL}} Index: generic/nsfInt.h =================================================================== diff -u -r64c08fef023b96fa1272ec177961a19c5312e29a -rdfaca66a33107320eac62bde6ac8ea15abbcbe83 --- generic/nsfInt.h (.../nsfInt.h) (revision 64c08fef023b96fa1272ec177961a19c5312e29a) +++ generic/nsfInt.h (.../nsfInt.h) (revision dfaca66a33107320eac62bde6ac8ea15abbcbe83) @@ -383,9 +383,10 @@ /* deletion state */ #define NSF_TCL_DELETE 0x0400 #define NSF_DESTROY_CALLED_SUCCESS 0x0800 -#define NSF_DURING_DELETE 0x2000 -#define NSF_DELETED 0x4000 -#define NSF_RECREATE 0x8000 +#define NSF_DURING_DELETE 0x1000 +#define NSF_DELETED 0x2000 +#define NSF_RECREATE 0x4000 +#define NSF_KEEP_CALLER_SELF 0x8000 @@ -497,7 +498,7 @@ NsfFilterStack *filterStack; NsfMixinStack *mixinStack; int refCount; - short flags; + unsigned short flags; short activationCount; } NsfObject; Index: library/nx/nx.tcl =================================================================== diff -u -r1398015d9294ce3adec8b1d5dc6e98f7c717b243 -rdfaca66a33107320eac62bde6ac8ea15abbcbe83 --- library/nx/nx.tcl (.../nx.tcl) (revision 1398015d9294ce3adec8b1d5dc6e98f7c717b243) +++ library/nx/nx.tcl (.../nx.tcl) (revision dfaca66a33107320eac62bde6ac8ea15abbcbe83) @@ -470,6 +470,9 @@ # in nsf when calling e.g. "unknown" (such that a subcmd # "unknown" does not interfere with the method "unknown"). # + :protected method init {} { + ::nsf::object::property [self] keepcallerself true + } :protected method unknown {callInfo args} { set path [lrange $callInfo 1 end-1]; # set path [current methodpath] set m [lindex $callInfo end] Index: library/xotcl/library/xotcl2.tcl =================================================================== diff -u -r1398015d9294ce3adec8b1d5dc6e98f7c717b243 -rdfaca66a33107320eac62bde6ac8ea15abbcbe83 --- library/xotcl/library/xotcl2.tcl (.../xotcl2.tcl) (revision 1398015d9294ce3adec8b1d5dc6e98f7c717b243) +++ library/xotcl/library/xotcl2.tcl (.../xotcl2.tcl) (revision dfaca66a33107320eac62bde6ac8ea15abbcbe83) @@ -462,6 +462,8 @@ ######################## Object create ::xotcl::objectInfo Object create ::xotcl::classInfo + ::nsf::object::property ::xotcl::objectInfo keepcallerself true + ::nsf::object::property ::xotcl::classInfo keepcallerself true # note, we are using ::xotcl::infoError, defined below #Object instforward info -onerror ::nsf::infoError ::xotcl::objectInfo %1 {%@2 %self} Index: tests/destroy.test =================================================================== diff -u -re52370808287bc485ce7f4211ce727bd8dd39904 -rdfaca66a33107320eac62bde6ac8ea15abbcbe83 --- tests/destroy.test (.../destroy.test) (revision e52370808287bc485ce7f4211ce727bd8dd39904) +++ tests/destroy.test (.../destroy.test) (revision dfaca66a33107320eac62bde6ac8ea15abbcbe83) @@ -438,13 +438,17 @@ Test case deleting-aliased-object { Object create o Object create o2 + # TODO: fixme; should probably be not necessary + ::nsf::object::property o2 keepcallerself 1 ::nsf::method::alias o a o2 ? {o a} ::o2 "call object via alias" ? {o info method type a} alias ## the ensemble-object needs per-object methods o2 method info args {:info {*}$args} o2 method set args {:set {*}$args} + puts stderr HU1 ? {o a info vars} "" "call info on aliased object" + puts stderr HU2 ? {o set x 10} 10 "set variable on object" ? {o info vars} x "query vars" ? {o a info vars} x "query vars via alias" @@ -482,6 +486,8 @@ Object create o3 o alias x o3 Object create o3 + # TODO: fixme; should probably be not necessary + ::nsf::object::property o3 keepcallerself 1 o3 method set args {:set {*}$args} o set a 13 ? {o x set a} 13 "aliased object works after recreate" @@ -495,6 +501,9 @@ Class create C Object create o Object create o3 + # TODO: fixme; should probably be not necessary + ::nsf::object::property o keepcallerself 1 + ::nsf::object::property o3 keepcallerself 1 o alias a o3 C alias b o Index: tests/disposition.test =================================================================== diff -u -r9a0b8bb0992be0561d8187c275fc1d9b7e0bbcd0 -rdfaca66a33107320eac62bde6ac8ea15abbcbe83 --- tests/disposition.test (.../disposition.test) (revision 9a0b8bb0992be0561d8187c275fc1d9b7e0bbcd0) +++ tests/disposition.test (.../disposition.test) (revision dfaca66a33107320eac62bde6ac8ea15abbcbe83) @@ -1176,9 +1176,9 @@ C setObjectParams [list [list FOO:alias,noarg ""]] ? {C create c} "::c" "Defaultmethod of calle is invoked ..." C setObjectParams [list [list FOO:alias "foo"]] - ? {C create c} "::c-FOO" "foo leaf method is selected ..." + ? {C create c} "::callee-FOO" "foo leaf method is selected ..." ::callee mixin add M - ? {C create c} "::c-FOO" "With mixin ..." + ? {C create c} "::callee-FOO" "With mixin ..." # # ... at the calling object level / ensemble path @@ -1195,7 +1195,7 @@ } } - ? {C create c} "::c-FOO" "With mixin ..." + ? {C create c} "::callee-FOO" "With mixin ..." # # ... with filter indirection: tbd @@ -1256,7 +1256,7 @@ set x [UnknownHandler create handledObj] set methods(ix) [::nsf::method::alias ::obj ix $x] - ? {[T create t] z ix baff} "CURRENT-$x-DELEGATOR-::t-UNKNOWNMETHOD-baff-PATH-z ix" \ + ? {[T create t] z ix baff} "CURRENT-$x-DELEGATOR-::obj-UNKNOWNMETHOD-baff-PATH-z ix" \ "Aliased dispatch to unknown method (custom unknown handler)" #