Index: generic/nsf.c =================================================================== diff -u -rb604626384c5692394df7e276ac9c10e6229dbfd -r1279a7ecae38bb092922db436da36d0caa77cf6f --- generic/nsf.c (.../nsf.c) (revision b604626384c5692394df7e276ac9c10e6229dbfd) +++ generic/nsf.c (.../nsf.c) (revision 1279a7ecae38bb092922db436da36d0caa77cf6f) @@ -17747,7 +17747,7 @@ if (npac == 2) { if ((disallowedFlags & NSF_ARG_HAS_DEFAULT) != 0u) { - NsfPrintError(interp, "parameter \"%s\" is not allowed to have default \"%s\"", + NsfPrintError(interp, "parameter specification for \"%s\" is not allowed to have default \"%s\"", argString, ObjStr(npav[1])); goto param_error; } @@ -19843,8 +19843,8 @@ * NextSearchMethod -- * * Determine the method to be called via "next". The function returns on - * success the found cmd and information like method name, was it from a mixin, filter, - * or was the end of the filter chain reached. + * success the found cmd and information like method name, was it from a + * mixin, filter, or was the end of the filter chain reached. * * Results: * Tcl result code @@ -20024,11 +20024,10 @@ *---------------------------------------------------------------------- * NextGetArguments -- * - * Obtain arguments for a method invoked via next either from the - * argument vector or from the stack (call stack content or Tcl - * stack). In case of ensemble calls the stack entries of the - * ensemble invocation are used. The function returns the arguments - * 4 to 8. + * Obtain arguments for a method invoked via next either from the argument + * vector or from the stack (call stack content or Tcl stack). In case of + * ensemble calls the stack entries of the ensemble invocation are + * used. The function returns the arguments 4 to 8. * * Results: * Tcl return code @@ -29160,7 +29159,7 @@ /* cmd "object::property" NsfObjectPropertyCmd { {-argName "object" -required 1 -type object} - {-argName "objectproperty" -type "initialized|class|rootmetaclass|rootclass|volatile|slotcontainer|hasperobjectslots|keepcallerself|perobjectdispatch" -required 1} + {-argName "objectproperty" -type "initialized|class|rootmetaclass|rootclass|volatile|autonamed|slotcontainer|hasperobjectslots|keepcallerself|perobjectdispatch" -required 1} {-argName "value" -required 0 -type tclobj} } */ @@ -29173,6 +29172,7 @@ nonnull_assert(object != NULL); switch (objectProperty) { + case ObjectpropertyAutonamedIdx: flags = NSF_IS_AUTONAMED; allowSet = 1; break; case ObjectpropertyInitializedIdx: flags = NSF_INIT_CALLED; allowSet = 1; break; case ObjectpropertyClassIdx: flags = NSF_IS_CLASS; break; case ObjectpropertyRootmetaclassIdx: flags = NSF_IS_ROOT_META_CLASS; break; @@ -32355,7 +32355,7 @@ /* - * Walk up the stack of this objects invocations. This skips + * Walk up the stack of invocations of the current object. This skips * e.g. overloaded internally called methods like "configure". */ /*fprintf(stderr, "compare object %p == %p\n", (void*)object, (void*)cscPtr->self);*/ @@ -32366,16 +32366,25 @@ } /* - * Final special case to achieve better XOTcl1 compliance: In case, we - * were called from an "unknown" method, skip this frame as well. + * If this was a "next" call, continue to walk up. */ + if ((cscPtr->flags & NSF_CSC_CALL_IS_NEXT) != 0u) { + invocationFrame = Tcl_CallFrame_callerPtr(invocationFrame); + /*fprintf(stderr, "next call with %p\n", (void*)invocationFrame);*/ + continue; + } + + /* + * Final special case for XOTcl1 compliance: In case, we were called + * from an "unknown" method, skip this frame as well. + */ /*fprintf(stderr, "cmd %s\n", Tcl_GetCommandName(interp, cscPtr->cmdPtr));*/ if (strcmp(osPtr->methodNames[NSF_o_unknown_idx], Tcl_GetCommandName(interp, cscPtr->cmdPtr)) == 0) { invocationFrame = Tcl_CallFrame_callerPtr(invocationFrame); /*fprintf(stderr, "have unknown, continue with %p\n", (void*)invocationFrame);*/ continue; - } + } break; } @@ -32921,7 +32930,7 @@ { Tcl_Obj *methodObj; - int callDirectly; + int callDirectly; callDirectly = CallDirectly(interp, &class->object, NSF_c_create_idx, &methodObj); @@ -32944,6 +32953,16 @@ } } + { + Tcl_Obj *resultObj; + NsfObject *object; + + resultObj = Tcl_GetObjResult(interp); + if (GetObjectFromObj(interp, resultObj, &object) == TCL_OK) { + object->flags |= NSF_IS_AUTONAMED; + } + } + DECR_REF_COUNT(fullnameObj); Tcl_DStringFree(dsPtr); Index: generic/nsfAPI.decls =================================================================== diff -u -rb604626384c5692394df7e276ac9c10e6229dbfd -r1279a7ecae38bb092922db436da36d0caa77cf6f --- generic/nsfAPI.decls (.../nsfAPI.decls) (revision b604626384c5692394df7e276ac9c10e6229dbfd) +++ generic/nsfAPI.decls (.../nsfAPI.decls) (revision 1279a7ecae38bb092922db436da36d0caa77cf6f) @@ -262,7 +262,7 @@ } {-nxdoc 1} cmd "object::property" NsfObjectPropertyCmd { {-argName "object" -required 1 -type object} - {-argName "objectProperty" -type "initialized|class|rootmetaclass|rootclass|volatile|slotcontainer|hasperobjectslots|keepcallerself|perobjectdispatch" -required 1} + {-argName "objectProperty" -type "initialized|class|rootmetaclass|rootclass|volatile|autonamed|slotcontainer|hasperobjectslots|keepcallerself|perobjectdispatch" -required 1} {-argName "value" -required 0 -type tclobj} } {-nxdoc 1} cmd "object::qualify" NsfObjectQualifyCmd { Index: generic/nsfAPI.h =================================================================== diff -u -rb604626384c5692394df7e276ac9c10e6229dbfd -r1279a7ecae38bb092922db436da36d0caa77cf6f --- generic/nsfAPI.h (.../nsfAPI.h) (revision b604626384c5692394df7e276ac9c10e6229dbfd) +++ generic/nsfAPI.h (.../nsfAPI.h) (revision 1279a7ecae38bb092922db436da36d0caa77cf6f) @@ -220,12 +220,12 @@ return result; } -typedef enum {ObjectpropertyNULL, ObjectpropertyInitializedIdx, ObjectpropertyClassIdx, ObjectpropertyRootmetaclassIdx, ObjectpropertyRootclassIdx, ObjectpropertyVolatileIdx, ObjectpropertySlotcontainerIdx, ObjectpropertyHasperobjectslotsIdx, ObjectpropertyKeepcallerselfIdx, ObjectpropertyPerobjectdispatchIdx} ObjectpropertyIdx_t; +typedef enum {ObjectpropertyNULL, ObjectpropertyInitializedIdx, ObjectpropertyClassIdx, ObjectpropertyRootmetaclassIdx, ObjectpropertyRootclassIdx, ObjectpropertyVolatileIdx, ObjectpropertyAutonamedIdx, ObjectpropertySlotcontainerIdx, ObjectpropertyHasperobjectslotsIdx, ObjectpropertyKeepcallerselfIdx, ObjectpropertyPerobjectdispatchIdx} ObjectpropertyIdx_t; 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", "volatile", "slotcontainer", "hasperobjectslots", "keepcallerself", "perobjectdispatch", NULL}; + static const char *opts[] = {"initialized", "class", "rootmetaclass", "rootclass", "volatile", "autonamed", "slotcontainer", "hasperobjectslots", "keepcallerself", "perobjectdispatch", NULL}; (void)pPtr; result = Tcl_GetIndexFromObj(interp, objPtr, opts, "objectProperty", 0, &index); *clientData = (ClientData) INT2PTR(index + 1); @@ -271,7 +271,7 @@ {ConvertToDefinitionsource, "all|application|system"}, {ConvertToForwardproperty, "prefix|target|verbose"}, {ConvertToConfigureoption, "debug|dtrace|filter|softrecreate|objectsystems|keepcmds|checkresults|checkarguments"}, - {ConvertToObjectproperty, "initialized|class|rootmetaclass|rootclass|volatile|slotcontainer|hasperobjectslots|keepcallerself|perobjectdispatch"}, + {ConvertToObjectproperty, "initialized|class|rootmetaclass|rootclass|volatile|autonamed|slotcontainer|hasperobjectslots|keepcallerself|perobjectdispatch"}, {ConvertToAssertionsubcmd, "check|object-invar|class-invar"}, {ConvertToParametersubcmd, "default|list|name|syntax|type"}, {ConvertToMixinscope, "all|class|object"}, Index: generic/nsfInt.h =================================================================== diff -u -r2a2f104357f92c52f53b72025ae2183152644140 -r1279a7ecae38bb092922db436da36d0caa77cf6f --- generic/nsfInt.h (.../nsfInt.h) (revision 2a2f104357f92c52f53b72025ae2183152644140) +++ generic/nsfInt.h (.../nsfInt.h) (revision 1279a7ecae38bb092922db436da36d0caa77cf6f) @@ -547,6 +547,7 @@ #define NSF_KEEP_CALLER_SELF 0x0400u #define NSF_PER_OBJECT_DISPATCH 0x0800u #define NSF_HAS_PER_OBJECT_SLOTS 0x1000u +#define NSF_IS_AUTONAMED 0x2000u /* deletion states */ #define NSF_DESTROY_CALLED_SUCCESS 0x010000u /* requires flags to be int, not short */ #define NSF_DURING_DELETE 0x020000u Index: library/xotcl/tests/speedtest.xotcl =================================================================== diff -u -rc4f449cb353be812ba6502ef8e9587e87881f59b -r1279a7ecae38bb092922db436da36d0caa77cf6f --- library/xotcl/tests/speedtest.xotcl (.../speedtest.xotcl) (revision c4f449cb353be812ba6502ef8e9587e87881f59b) +++ library/xotcl/tests/speedtest.xotcl (.../speedtest.xotcl) (revision 1279a7ecae38bb092922db436da36d0caa77cf6f) @@ -561,7 +561,32 @@ -cmd {catch {a1 br}} -expected 3 -count 2 \ -post {A destroy; a1 destroy} +# +# volatile tests +# +nx::test new -msg {volatile + new overloaded } \ + -pre {Class A; A proc new args {next}} \ + -cmd {set a [A new -volatile]; $a info class} -expected ::A -count 2 \ + -post {A destroy} +nx::test new -msg {volatile + next overloaded + proc } \ + -pre {Class A; A proc new args {next}; proc foo {} {set a [A new -volatile]; $a info class}} \ + -cmd {foo; ::A info instances} -expected {} -count 2 \ + -post {A destroy; rename foo ""} + + + +nx::test new -msg {volatile + configure overloaded} \ + -pre {Class A; A instproc configure args {next}} \ + -cmd {A create a1 -volatile; A a2 -volatile; lsort [A info instances]} -expected "::a1 ::a2" -count 2 \ + -post {A destroy} + +nx::test new -msg {volatile + configure overloaded + proc} \ + -pre {Class A; A instproc configure args {next}; proc foo {} {A create a1 -volatile; A a2 -volatile}} \ + -cmd {foo; ::A info instances} -expected {} -count 2 \ + -post {A destroy; rename foo ""} + + nx::test run #