Index: TODO =================================================================== diff -u -r8274c68ad85f12b1e4a41a01273079405fa865ef -r89b5047e54e47a88a7de75d8523a07ffa5743407 --- TODO (.../TODO) (revision 8274c68ad85f12b1e4a41a01273079405fa865ef) +++ TODO (.../TODO) (revision 89b5047e54e47a88a7de75d8523a07ffa5743407) @@ -958,8 +958,38 @@ - extended regression test - fixed serializer to handle subobjects of explicitely exported objects +- xotcl.c: + * new function GetObjectFromNsName() to obtail object or class + from a fully qualified namespace name used in method handles (such as e.g. + ::nx::core::classes::X) + * new function MethodHandleObj() to return a tcl_obj containing the methodhandle + * removed obsolete method getFullProcQualifier() + * info methods obtain now object and/or class from fully qualified method + names (method handles) if possible + * return message handles in "current next", "current filterreg" and + "... info filter ... -order", which can be used in "info method .... " + for obtaining more details. + * change all occurrances of "self" in next regression tests to current. +- xotcl2.tcl + * implemented "self" as a proc to provide extensibility and + full backward compatibilty; this opens opportunity + to replace now e.g. "self proc" by "current method", etc. + * provide full compatibility for "self next", "self filterreg" and + "... info filter ... -order", returning old-style multiword method handles + (such as e.g. "::C instproc foo") +- changed "next" to current in documentation framework and templates + + TODO: - nameing + * self/current: + - overthink general replacement of "self" by "current". + a consequence is, that slots can't use "self" anymore, since slots + are always next objects + - replace "self proc" by "current method", etc. + - we have "%self" as well, which is better than "%current" + - maybe provide alias "self" for "current object" + * .c-code: . rename source files from xotcl{Int}.{ch}->next*.* | next-scripting*.* ? Stefan, meinung dazu? Notwending|Empfehlenswert|nicht? Index: generic/gentclAPI.decls =================================================================== diff -u -r8f2c993e02fe43f23c7e1653d05f6e298c23b2b2 -r89b5047e54e47a88a7de75d8523a07ffa5743407 --- generic/gentclAPI.decls (.../gentclAPI.decls) (revision 8f2c993e02fe43f23c7e1653d05f6e298c23b2b2) +++ generic/gentclAPI.decls (.../gentclAPI.decls) (revision 89b5047e54e47a88a7de75d8523a07ffa5743407) @@ -260,9 +260,7 @@ # @subcommand filterreg In a method serving as active filter, returns the name of the object (class) on which the method is registered as a filter. # @subcommand callinglevel Returns the "original" callstack level calling into the executing method. Intermediary {{{next}}} calls are ignored in this computation. The level is returned in a form so that it can be used as first argument in {{@method ::nx::Object class uplevel}} or {{@method ::nx::Object class upvar}}. # @subcommand activelevel Returns the actual callstack level calling into the executing method. The active might correspond the {{{callinglevel}}}, but this is not necessarily the case. The {{{activelevel}}} counts {{@command ::nx::next}} call. The level is returned in a form so that it can be used as first argument in {{@method ::nx::Object class uplevel}} or {{@method ::nx::Object class upvar}}. -xotclCmd self XOTclSelfCmd { - {-argName "selfoption" -required 0 -type "proc|method|object|class|activelevel|args|activemixin|calledproc|calledmethod|calledclass|callingproc|callingmethod|callingclass|callinglevel|callingobject|filterreg|isnextcall|next"} -} + xotclCmd setvar XOTclSetVarCmd { {-argName "object" -required 1 -type object} {-argName "variable" -required 1 -type tclobj} Index: generic/predefined.h =================================================================== diff -u -r8f2c993e02fe43f23c7e1653d05f6e298c23b2b2 -r89b5047e54e47a88a7de75d8523a07ffa5743407 --- generic/predefined.h (.../predefined.h) (revision 8f2c993e02fe43f23c7e1653d05f6e298c23b2b2) +++ generic/predefined.h (.../predefined.h) (revision 89b5047e54e47a88a7de75d8523a07ffa5743407) @@ -16,9 +16,8 @@ "-object.residualargs residualargs\n" "-object.unknown unknown}\n" "namespace eval ::nx::core {\n" -"namespace export next self \\\n" -"my is relation interp}\n" -"namespace import ::nx::core::next ::nx::core::self\n" +"namespace export next current my is relation interp}\n" +"namespace import ::nx::core::next ::nx::core::current\n" "foreach cmd [info command ::nx::core::cmd::Object::*] {\n" "set cmdName [namespace tail $cmd]\n" "if {$cmdName in [list \"exists\" \"instvar\"]} continue\n" Index: generic/predefined.tcl =================================================================== diff -u -r8f2c993e02fe43f23c7e1653d05f6e298c23b2b2 -r89b5047e54e47a88a7de75d8523a07ffa5743407 --- generic/predefined.tcl (.../predefined.tcl) (revision 8f2c993e02fe43f23c7e1653d05f6e298c23b2b2) +++ generic/predefined.tcl (.../predefined.tcl) (revision 89b5047e54e47a88a7de75d8523a07ffa5743407) @@ -27,15 +27,13 @@ } # - # get frequenly used primitiva into the ::next namespace + # get frequenly used primitiva into the ::nx::core namespace # namespace eval ::nx::core { - namespace export next self \ - my is relation interp + namespace export next current my is relation interp } - - namespace import ::nx::core::next ::nx::core::self + namespace import ::nx::core::next ::nx::core::current # # provide the standard command set for ::nx::Object Index: generic/tclAPI.h =================================================================== diff -u -r8f2c993e02fe43f23c7e1653d05f6e298c23b2b2 -r89b5047e54e47a88a7de75d8523a07ffa5743407 --- generic/tclAPI.h (.../tclAPI.h) (revision 8f2c993e02fe43f23c7e1653d05f6e298c23b2b2) +++ generic/tclAPI.h (.../tclAPI.h) (revision 89b5047e54e47a88a7de75d8523a07ffa5743407) @@ -109,17 +109,6 @@ } enum RelationtypeIdx {RelationtypeNULL, RelationtypeObject_mixinIdx, RelationtypeClass_mixinIdx, RelationtypeObject_filterIdx, RelationtypeClass_filterIdx, RelationtypeClassIdx, RelationtypeSuperclassIdx, RelationtypeRootclassIdx}; -static int convertToSelfoption(Tcl_Interp *interp, Tcl_Obj *objPtr, XOTclParam CONST *pPtr, - ClientData *clientData, Tcl_Obj **outObjPtr) { - int index, result; - static CONST char *opts[] = {"proc", "method", "object", "class", "activelevel", "args", "activemixin", "calledproc", "calledmethod", "calledclass", "callingproc", "callingmethod", "callingclass", "callinglevel", "callingobject", "filterreg", "isnextcall", "next", NULL}; - result = Tcl_GetIndexFromObj(interp, objPtr, opts, "selfoption", 0, &index); - *clientData = (ClientData) INT2PTR(index + 1); - *outObjPtr = objPtr; - return result; -} -enum SelfoptionIdx {SelfoptionNULL, SelfoptionProcIdx, SelfoptionMethodIdx, SelfoptionObjectIdx, SelfoptionClassIdx, SelfoptionActivelevelIdx, SelfoptionArgsIdx, SelfoptionActivemixinIdx, SelfoptionCalledprocIdx, SelfoptionCalledmethodIdx, SelfoptionCalledclassIdx, SelfoptionCallingprocIdx, SelfoptionCallingmethodIdx, SelfoptionCallingclassIdx, SelfoptionCallinglevelIdx, SelfoptionCallingobjectIdx, SelfoptionFilterregIdx, SelfoptionIsnextcallIdx, SelfoptionNextIdx}; - typedef struct { CONST char *methodName; @@ -220,7 +209,6 @@ static int XOTclParametercheckCmdStub(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv []); static int XOTclQualifyObjCmdStub(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 XOTclSelfCmdStub(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv []); static int XOTclSetVarCmdStub(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv []); static int XOTclSetterCmdStub(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv []); @@ -299,7 +287,6 @@ static int XOTclParametercheckCmd(Tcl_Interp *interp, int withNocomplain, Tcl_Obj *param, Tcl_Obj *value); static int XOTclQualifyObjCmd(Tcl_Interp *interp, Tcl_Obj *name); static int XOTclRelationCmd(Tcl_Interp *interp, XOTclObject *object, int relationtype, Tcl_Obj *value); -static int XOTclSelfCmd(Tcl_Interp *interp, int selfoption); static int XOTclSetVarCmd(Tcl_Interp *interp, XOTclObject *object, Tcl_Obj *variable, Tcl_Obj *value); static int XOTclSetterCmd(Tcl_Interp *interp, XOTclObject *object, int withPer_object, Tcl_Obj *parameter); @@ -379,7 +366,6 @@ XOTclParametercheckCmdIdx, XOTclQualifyObjCmdIdx, XOTclRelationCmdIdx, - XOTclSelfCmdIdx, XOTclSetVarCmdIdx, XOTclSetterCmdIdx } XOTclMethods; @@ -1886,24 +1872,6 @@ } static int -XOTclSelfCmdStub(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { - parseContext pc; - - if (ArgumentParse(interp, objc, objv, NULL, objv[0], - method_definitions[XOTclSelfCmdIdx].paramDefs, - method_definitions[XOTclSelfCmdIdx].nrParameters, - &pc) != TCL_OK) { - return TCL_ERROR; - } else { - int selfoption = (int )PTR2INT(pc.clientData[0]); - - parseContextRelease(&pc); - return XOTclSelfCmd(interp, selfoption); - - } -} - -static int XOTclSetVarCmdStub(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { parseContext pc; @@ -2287,9 +2255,6 @@ {"relationtype", 1, 0, convertToRelationtype}, {"value", 0, 0, convertToTclobj}} }, -{"::nx::core::self", XOTclSelfCmdStub, 1, { - {"selfoption", 0, 0, convertToSelfoption}} -}, {"::nx::core::setvar", XOTclSetVarCmdStub, 3, { {"object", 1, 0, convertToObject}, {"variable", 1, 0, convertToTclobj}, Index: generic/xotcl.c =================================================================== diff -u -r8274c68ad85f12b1e4a41a01273079405fa865ef -r89b5047e54e47a88a7de75d8523a07ffa5743407 --- generic/xotcl.c (.../xotcl.c) (revision 8274c68ad85f12b1e4a41a01273079405fa865ef) +++ generic/xotcl.c (.../xotcl.c) (revision 89b5047e54e47a88a7de75d8523a07ffa5743407) @@ -496,6 +496,21 @@ return string+19; } +XOTCLINLINE static XOTclObject * +GetObjectFromNsName(Tcl_Interp *interp, CONST char *string, int *fromClassNS) { + /* + * Get object or class from a fully qualified cmd name, such as + * e.g. ::nx::core::classes::X + */ + if (isClassName(string)) { + *fromClassNS = 1; + return (XOTclObject *)XOTclpGetClass(interp, NSCutXOTclClasses(string)); + } else { + *fromClassNS = 0; + return XOTclpGetObject(interp, string); + } +} + XOTCLINLINE static char * NSCmdFullName(Tcl_Command cmd) { Tcl_Namespace *nsPtr = Tcl_Command_nsPtr(cmd); @@ -4523,55 +4538,34 @@ cl->order = saved; } -/* - * Build up a qualifier of the form <obj/cl> method <procName>. - * If cl is NULL, we add the modifier "object". - */ static Tcl_Obj * -getFullProcQualifier(Tcl_Interp *interp, CONST char *cmdName, - XOTclObject *object, XOTclClass *cl, Tcl_Command cmd) { - Tcl_Obj *list = Tcl_NewListObj(0, NULL); - Tcl_Obj *procObj = Tcl_NewStringObj(cmdName, -1); - Tcl_ObjCmdProc *objProc = Tcl_Command_objProc(cmd); - int isTcl = CmdIsProc(cmd); - - if (cl) { - Tcl_ListObjAppendElement(interp, list, cl->object.cmdName); - } else { - Tcl_ListObjAppendElement(interp, list, object->cmdName); - Tcl_ListObjAppendElement(interp, list, XOTclGlobalObjs[XOTE_OBJECT]); - } - if (isTcl) { - Tcl_ListObjAppendElement(interp, list, XOTclGlobalObjs[XOTE_METHOD]); - } else if (objProc == XOTclForwardMethod) { - Tcl_ListObjAppendElement(interp, list, XOTclGlobalObjs[XOTE_FORWARD]); - } else if (objProc == XOTclSetterMethod) { - Tcl_ListObjAppendElement(interp, list, XOTclGlobalObjs[XOTE_SETTER]); - } else { - Tcl_ListObjAppendElement(interp, list, XOTclGlobalObjs[XOTE_CMD]); - } - Tcl_ListObjAppendElement(interp, list, procObj); - return list; +MethodHandleObj(XOTclObject *object, int withPer_object, CONST char *methodName) { + Tcl_Obj *resultObj = Tcl_NewStringObj(withPer_object ? "" : "::nx::core::classes", -1); + assert(object); + Tcl_AppendObjToObj(resultObj, object->cmdName); + Tcl_AppendStringsToObj(resultObj, "::", methodName, (char *) NULL); + return resultObj; } /* * info option for filters and classfilters * withGuards -> if not 0 => append guards - * fullProcQualifiers -> if not 0 => full names with obj/class method + * withMethodHandles -> if not 0 => return method handles */ static int FilterInfo(Tcl_Interp *interp, XOTclCmdList *f, CONST char *pattern, - int withGuards, int fullProcQualifiers) { + int withGuards, int withMethodHandles) { CONST char *simpleName; Tcl_Obj *list = Tcl_NewListObj(0, NULL); - /*fprintf(stderr, "FilterInfo %p %s %d %d\n", pattern, pattern, withGuards, fullProcQualifiers);*/ + /*fprintf(stderr, "FilterInfo %p %s %d %d\n", pattern, pattern, + withGuards, withMethodHandles);*/ - /* guard lists should only have unqualified filter lists - when withGuards is activated, fullProcQualifiers has not - effect */ + /* guard lists should only have unqualified filter lists when + withGuards is activated, withMethodHandles has no effect + */ if (withGuards) { - fullProcQualifiers = 0; + withMethodHandles = 0; } while (f) { @@ -4586,19 +4580,11 @@ Tcl_ListObjAppendElement(interp, innerList, g); Tcl_ListObjAppendElement(interp, list, innerList); } else { - if (fullProcQualifiers) { - XOTclClass *filterClass; - XOTclObject *filterObject; - if (f->clorobj && !XOTclObjectIsClass(&f->clorobj->object)) { - filterObject = (XOTclObject *)f->clorobj; - filterClass = NULL; - } else { - filterObject = NULL; - filterClass = f->clorobj; - } + if (withMethodHandles) { + XOTclClass *filterClass = f->clorobj; Tcl_ListObjAppendElement(interp, list, - getFullProcQualifier(interp, simpleName, - filterObject, filterClass, f->cmdPtr)); + MethodHandleObj((XOTclObject *)filterClass, + !XOTclObjectIsClass(&filterClass->object), simpleName)); } else { Tcl_ListObjAppendElement(interp, list, Tcl_NewStringObj(simpleName, -1)); } @@ -7430,15 +7416,15 @@ Tcl_ResetResult(interp); methodName = (char *)Tcl_GetCommandName(interp, cscPtr->cmdPtr); - if (!methodName) + if (!methodName) { return TCL_OK; + } result = NextSearchMethod(object, interp, cscPtr, &cl, &methodName, &cmd, &isMixinEntry, &isFilterEntry, &endOfFilterChain, ¤tCmd); - if (cmd) { - Tcl_SetObjResult(interp, getFullProcQualifier(interp, Tcl_GetCommandName(interp, cmd), - object, cl, cmd)); + Tcl_SetObjResult(interp, MethodHandleObj(cl ? (XOTclObject*)cl : object, + cl == NULL, methodName)); } return result; } @@ -9967,14 +9953,10 @@ static int ListMethodName(Tcl_Interp *interp, XOTclObject *object, int withPer_object, CONST char *methodName) { - Tcl_Obj *resultObj = Tcl_NewStringObj(withPer_object ? "" : "::nx::core::classes", -1); - Tcl_AppendObjToObj(resultObj, object->cmdName); - Tcl_AppendStringsToObj(resultObj, "::", methodName, (char *) NULL); - Tcl_SetObjResult(interp, resultObj); + Tcl_SetObjResult(interp, MethodHandleObj(object, withPer_object, methodName)); return TCL_OK; } - static int ListMethod(Tcl_Interp *interp, XOTclObject *object, CONST char *methodName, Tcl_Command cmd, int subcmd, int withPer_object) { @@ -9989,6 +9971,38 @@ int outputPerObject = 0; Tcl_Obj *resultObj; + if (*methodName == ':') { + /* + * We have a fully qualified method name, maybe an object handle + */ + CONST char *procName = Tcl_GetCommandName(interp, cmd); + size_t objNameLength = strlen(methodName) - strlen(procName) - 2; + Tcl_DString ds, *dsPtr = &ds; + + if (objNameLength > 0) { + XOTclObject *object1; + int fromClassNS; + + Tcl_DStringInit(dsPtr); + Tcl_DStringAppend(dsPtr, methodName, objNameLength); + object1 = GetObjectFromNsName(interp, Tcl_DStringValue(dsPtr), &fromClassNS); + if (object1) { + /* + * The command was from an object, return therefore this + * object as reference. + */ + /*fprintf(stderr, "We are flipping the object to %s, method %s to %s\n", + objectName(object1), methodName, procName);*/ + object = object1; + methodName = procName; + if (!fromClassNS) { + withPer_object = 1; + } + } + Tcl_DStringFree(dsPtr); + } + } + if (!XOTclObjectIsClass(object)) { withPer_object = 1; /* don't output "object" modifier, if object is not a class */ @@ -11056,7 +11070,6 @@ Tcl_DeleteNamespace(RUNTIME_STATE(interp)->XOTclClassesNS); Tcl_DeleteNamespace(RUNTIME_STATE(interp)->XOTclNS); #endif - /*xxxx*/ return TCL_OK; } @@ -11423,25 +11436,24 @@ Tcl_HashEntry *hPtr; XOTclObject *object; XOTclClass *cl; + int fromClassNS; fromNsPtr = ObjFindNamespace(interp, fromNs); if (!fromNsPtr) return TCL_OK; name = ObjStr(fromNs); + /* check, if we work on an object or class namespace */ - if (isClassName(name)) { - cl = XOTclpGetClass(interp, NSCutXOTclClasses(name)); - object = (XOTclObject *)cl; - } else { - cl = NULL; - object = XOTclpGetObject(interp, name); - } + object = GetObjectFromNsName(interp, name, &fromClassNS); if (object == NULL) { return XOTclVarErrMsg(interp, "CopyCmds argument 1 (", ObjStr(fromNs), ") is not an object", NULL); } + + cl = fromClassNS ? (XOTclClass *)object : NULL; + /* object = XOTclpGetObject(interp, ObjStr(fromNs));*/ toNsPtr = ObjFindNamespace(interp, toNs); @@ -12035,21 +12047,18 @@ } /* -xotclCmd self XOTclGetSelfObjCmd { - {-argName "selfoption" -required 0 -type "proc|class|activelevel|args|activemixin|calledproc|calledmethod|calledclass|callingproc|callingclass|callinglevel|callingobject|filterreg|isnextcall|next"} +xotclCmd current XOTclCurrentCmd { + {-argName "currentoption" -required 0 -type "proc|method|object|class|activelevel|args|activemixin|calledproc|calledmethod|calledclass|callingproc|callingmethod|callingclass|callinglevel|callingobject|filterreg|isnextcall|next"} } */ -static int XOTclSelfCmd(Tcl_Interp *interp, int selfoption) { - return XOTclCurrentCmd(interp, selfoption); -} static int XOTclCurrentCmd(Tcl_Interp *interp, int selfoption) { XOTclObject *object = GetSelfObj(interp); XOTclCallStackContent *cscPtr; int result = TCL_OK; /*fprintf(stderr, "getSelfObj returns %p\n", object); tcl85showStack(interp);*/ - if (selfoption == 0 || selfoption == SelfoptionObjectIdx) { + if (selfoption == 0 || selfoption == CurrentoptionObjectIdx) { if (object) { Tcl_SetObjResult(interp, object->cmdName); return TCL_OK; @@ -12058,13 +12067,13 @@ } } - if (!object && selfoption != SelfoptionCallinglevelIdx) { + if (!object && selfoption != CurrentoptionCallinglevelIdx) { return XOTclVarErrMsg(interp, "No current object", (char *) NULL); } switch (selfoption) { - case SelfoptionMethodIdx: /* fall through */ - case SelfoptionProcIdx: + case CurrentoptionMethodIdx: /* fall through */ + case CurrentoptionProcIdx: cscPtr = CallStackGetTopFrame(interp, NULL); if (cscPtr) { CONST char *procName = Tcl_GetCommandName(interp, cscPtr->cmdPtr); @@ -12074,16 +12083,16 @@ } break; - case SelfoptionClassIdx: /* class subcommand */ + case CurrentoptionClassIdx: /* class subcommand */ cscPtr = CallStackGetTopFrame(interp, NULL); Tcl_SetObjResult(interp, cscPtr->cl ? cscPtr->cl->object.cmdName : XOTclGlobalObjs[XOTE_EMPTY]); break; - case SelfoptionActivelevelIdx: + case CurrentoptionActivelevelIdx: Tcl_SetObjResult(interp, computeLevelObj(interp, ACTIVE_LEVEL)); break; - case SelfoptionArgsIdx: { + case CurrentoptionArgsIdx: { int nobjc; Tcl_Obj **nobjv; Tcl_CallFrame *topFramePtr; @@ -12100,7 +12109,7 @@ break; } - case SelfoptionActivemixinIdx: { + case CurrentoptionActivemixinIdx: { XOTclObject *object = NULL; if (RUNTIME_STATE(interp)->cmdPtr) { object = XOTclGetObjectFromCmdPtr(RUNTIME_STATE(interp)->cmdPtr); @@ -12109,8 +12118,8 @@ break; } - case SelfoptionCalledprocIdx: - case SelfoptionCalledmethodIdx: + case CurrentoptionCalledprocIdx: + case CurrentoptionCalledmethodIdx: cscPtr = CallStackFindActiveFilter(interp); if (cscPtr) { Tcl_SetObjResult(interp, cscPtr->filterStackEntry->calledProc); @@ -12120,37 +12129,37 @@ } break; - case SelfoptionCalledclassIdx: + case CurrentoptionCalledclassIdx: Tcl_SetResult(interp, className(FindCalledClass(interp, object)), TCL_VOLATILE); break; - case SelfoptionCallingmethodIdx: - case SelfoptionCallingprocIdx: + case CurrentoptionCallingmethodIdx: + case CurrentoptionCallingprocIdx: cscPtr = XOTclCallStackFindLastInvocation(interp, 1, NULL); Tcl_SetResult(interp, cscPtr ? (char *)Tcl_GetCommandName(interp, cscPtr->cmdPtr) : "", TCL_VOLATILE); break; - case SelfoptionCallingclassIdx: + case CurrentoptionCallingclassIdx: cscPtr = XOTclCallStackFindLastInvocation(interp, 1, NULL); Tcl_SetObjResult(interp, cscPtr && cscPtr->cl ? cscPtr->cl->object.cmdName : XOTclGlobalObjs[XOTE_EMPTY]); break; - case SelfoptionCallinglevelIdx: + case CurrentoptionCallinglevelIdx: if (!object) { Tcl_SetIntObj(Tcl_GetObjResult(interp), 1); } else { Tcl_SetObjResult(interp, computeLevelObj(interp, CALLING_LEVEL)); } break; - case SelfoptionCallingobjectIdx: + case CurrentoptionCallingobjectIdx: cscPtr = XOTclCallStackFindLastInvocation(interp, 1, NULL); Tcl_SetObjResult(interp, cscPtr ? cscPtr->self->cmdName : XOTclGlobalObjs[XOTE_EMPTY]); break; - case SelfoptionFilterregIdx: + case CurrentoptionFilterregIdx: cscPtr = CallStackFindActiveFilter(interp); if (cscPtr) { Tcl_SetObjResult(interp, FilterFindReg(interp, object, cscPtr->cmdPtr)); @@ -12161,7 +12170,7 @@ } break; - case SelfoptionIsnextcallIdx: { + case CurrentoptionIsnextcallIdx: { Tcl_CallFrame *framePtr; cscPtr = CallStackGetTopFrame(interp, &framePtr); framePtr = nextFrameOfType(Tcl_CallFrame_callerPtr(framePtr), FRAME_IS_XOTCL_METHOD|FRAME_IS_XOTCL_CMETHOD); @@ -12172,7 +12181,7 @@ break; } - case SelfoptionNextIdx: + case CurrentoptionNextIdx: result = FindSelfNext(interp); break; } @@ -12786,9 +12795,9 @@ * if it is not found it returns an empty string */ static int XOTclOFilterSearchMethod(Tcl_Interp *interp, XOTclObject *object, CONST char *filter) { + CONST char *filterName; XOTclCmdList *cmdList; XOTclClass *fcl; - XOTclObject *fobj; Tcl_ResetResult(interp); @@ -12798,7 +12807,7 @@ return TCL_OK; for (cmdList = object->filterOrder; cmdList; cmdList = cmdList->nextPtr) { - CONST char *filterName = Tcl_GetCommandName(interp, cmdList->cmdPtr); + filterName = Tcl_GetCommandName(interp, cmdList->cmdPtr); if (filterName[0] == filter[0] && !strcmp(filterName, filter)) break; } @@ -12807,16 +12816,7 @@ return TCL_OK; fcl = cmdList->clorobj; - if (fcl && XOTclObjectIsClass(&fcl->object)) { - fobj = NULL; - } else { - fobj = (XOTclObject*)fcl; - fcl = NULL; - } - - Tcl_SetObjResult(interp, getFullProcQualifier(interp, filter, fobj, fcl, - cmdList->cmdPtr)); - return TCL_OK; + return ListMethodName(interp, (XOTclObject*)fcl, !XOTclObjectIsClass(&fcl->object), filterName); } static int XOTclOInstVarMethod(Tcl_Interp *interp, XOTclObject *object, int objc, Tcl_Obj *CONST objv[]) { @@ -14682,12 +14682,12 @@ #endif Tcl_CreateObjCommand(interp, "::nx::core::next", XOTclNextObjCmd, 0, 0); #ifdef XOTCL_BYTECODE - instructions[INST_SELF].cmdPtr = (Command *)Tcl_FindCommand(interp, "::nx::core::self", 0, 0); + instructions[INST_SELF].cmdPtr = (Command *)Tcl_FindCommand(interp, "::nx::core::current", 0, 0); #endif /*Tcl_CreateObjCommand(interp, "::nx::core::K", XOTclKObjCmd, 0, 0);*/ Tcl_CreateObjCommand(interp, "::nx::core::unsetUnknownArgs", XOTclUnsetUnknownArgsCmd, 0, 0); - Tcl_Export(interp, RUNTIME_STATE(interp)->XOTclNS, "self", 0); + Tcl_Export(interp, RUNTIME_STATE(interp)->XOTclNS, "current", 0); Tcl_Export(interp, RUNTIME_STATE(interp)->XOTclNS, "next", 0); Tcl_Export(interp, RUNTIME_STATE(interp)->XOTclNS, "my", 0); Tcl_Export(interp, RUNTIME_STATE(interp)->XOTclNS, "importvar", 0); Index: generic/xotclStack85.c =================================================================== diff -u -r224d1a24b787b67fb9f0ff8a894f3092e8e4d5ae -r89b5047e54e47a88a7de75d8523a07ffa5743407 --- generic/xotclStack85.c (.../xotclStack85.c) (revision 224d1a24b787b67fb9f0ff8a894f3092e8e4d5ae) +++ generic/xotclStack85.c (.../xotclStack85.c) (revision 89b5047e54e47a88a7de75d8523a07ffa5743407) @@ -329,6 +329,9 @@ } } + +#if 0 +/* just used by XOTclONextMethod() */ static XOTclCallStackContent* CallStackGetObjectFrame(Tcl_Interp *interp, XOTclObject *object) { register Tcl_CallFrame *varFramePtr = (Tcl_CallFrame *)Tcl_Interp_varFramePtr(interp); @@ -343,6 +346,7 @@ } return NULL; } +#endif /* * Pop any callstack entry that is still alive (e.g. Index: library/lib/doc-assets/entity.html.tmpl =================================================================== diff -u -r783648c4c7132adc4a447faa69d6e4e12b621c46 -r89b5047e54e47a88a7de75d8523a07ffa5743407 --- library/lib/doc-assets/entity.html.tmpl (.../entity.html.tmpl) (revision 783648c4c7132adc4a447faa69d6e4e12b621c46) +++ library/lib/doc-assets/entity.html.tmpl (.../entity.html.tmpl) (revision 89b5047e54e47a88a7de75d8523a07ffa5743407) @@ -68,7 +68,7 @@ <ul class="content"> [:for package $packages { [:let css "" ] - [:? {[:info is type ::nx::doc::@package] && [self] eq $package} { + [:? {[:info is type ::nx::doc::@package] && [current] eq $package} { [:let css "selected" ] }] <li class="$css"><a href="[$package filename].html" title="[$package name]">[:fit [$package name] 30]</a></li> @@ -83,7 +83,7 @@ <ul class="content"> [:for object $objects { [:let css "" ] - [:? {[:info is type ::nx::doc::@object] && [self] eq $object} { + [:? {[:info is type ::nx::doc::@object] && [current] eq $object} { [:let css "selected" ] }] <li class="$css"><a href="[$object filename].html" title="[$object name]">[:fit [$object name] 30]</a></li> @@ -98,7 +98,7 @@ <ul class="content"> [:for command $commands { [:let css "" ] - [:? {[:info is type ::nx::doc::@command] && [self] eq $command} { + [:? {[:info is type ::nx::doc::@command] && [current] eq $command} { [:let css "selected"] }] <li class="$css"><a href="[$command filename].html" title="[$command name]">[$command name]</a></li> Index: library/lib/doc-tools.tcl =================================================================== diff -u -rf62c1f601dda43d69c8b159e81b57d4271cd3175 -r89b5047e54e47a88a7de75d8523a07ffa5743407 --- library/lib/doc-tools.tcl (.../doc-tools.tcl) (revision f62c1f601dda43d69c8b159e81b57d4271cd3175) +++ library/lib/doc-tools.tcl (.../doc-tools.tcl) (revision 89b5047e54e47a88a7de75d8523a07ffa5743407) @@ -109,7 +109,7 @@ :method behind? {error_msg} { return [expr {[::nx::core::is $error_msg object] && \ - [::nx::core::is $error_msg type [self]]}] + [::nx::core::is $error_msg type [current]]}] } # @method thrown_by? @@ -150,7 +150,7 @@ # # uplevel: throw at the call site # - uplevel 1 [list ::error [self]] + uplevel 1 [list ::error [current]] } } @@ -182,7 +182,7 @@ # @param tag Defaults to the tag label to be used in comment tags. It may vary from the auto-generated default! # @param root_namespace You may choose your own root-level namespace hosting the namespace hierarchy of entity objects - :attribute {tag {[string trimleft [string tolower [namespace tail [self]]] @]}} + :attribute {tag {[string trimleft [string tolower [namespace tail [current]]] @]}} :attribute {root_namespace "::nx::doc::entities"} namespace eval ::nx::doc::entities {} @@ -198,7 +198,7 @@ # @see tag # @see root_namespace :method id {name} { - set subns [string trimleft [namespace tail [self]] @] + set subns [string trimleft [namespace tail [current]] @] return [:root_namespace]::${subns}::[string trimleft $name :] } @@ -243,22 +243,22 @@ Class create PartClass -superclass EntityClass { :method id {partof_object scope name} { # ::Foo class foo - set subns [string trimleft [namespace tail [self]] @] + set subns [string trimleft [namespace tail [current]] @] set partof_name [string trimleft $partof_object :] return [join [list [:root_namespace] $subns $partof_name $scope $name] ::] } :method new { -part_attribute {-partof:substdefault {[[MissingPartofEntity new \ -message [subst { - Parts of type '[namespace tail [self]]' + Parts of type '[namespace tail [current]]' require a partof entity to be set }]] throw]}} -name args } { - :createOrConfigure [:id [$partof name] [$part_attribute scope] $name] {*}[self args] + :createOrConfigure [:id [$partof name] [$part_attribute scope] $name] {*}[current args] } } @@ -295,7 +295,7 @@ # :default "" if {![info exists :scope]} { set :scope class - regexp -- {@(.*)-.*} [namespace tail [self]] _ :scope + regexp -- {@(.*)-.*} [namespace tail [current]] _ :scope } next } @@ -309,7 +309,7 @@ return [${:part_class} new \ -name [lindex $value 0] \ -partof $domain \ - -part_attribute [self] \ + -part_attribute [current] \ -@doc [lrange $value 1 end]] } return $value @@ -398,7 +398,7 @@ comment_block } { EntityClass process \ - -partof_entity [self] \ + -partof_entity [current] \ -initial_section $initial_section \ {*}[expr {[info exists entity]?"-entity $entity":""}] \ $comment_block @@ -680,7 +680,7 @@ } else { set comment "<span style='color: red'>cannot check object, probably not instantiated</span>" } - #puts stderr "XXXX [self] ${:name} is part of ${:partof} // [${:partof} name]" + #puts stderr "XXXX [current] ${:name} is part of ${:partof} // [${:partof} name]" return [concat $params <br>$comment] } return $params @@ -691,7 +691,7 @@ } { next \ -initial_section $initial_section \ - -entity [self] $comment_block + -entity [current] $comment_block } }; # @method @@ -734,7 +734,7 @@ -part_attribute {-partof:substdefault {[[MissingPartofEntity new \ -message [subst { - Parts of type '[namespace tail [self]]' + Parts of type '[namespace tail [current]]' require a partof entity to be set }]] throw]}} -name @@ -770,7 +770,7 @@ :method render { {-initscript ""} template - {entity:substdefault "[self]"} + {entity:substdefault "[current]"} } { # Here, we assume the -nonleaf mode being active for {{{[eval]}}}. set tmplscript [list subst [[::nx::core::current class] read_tmpl $template]] @@ -1051,7 +1051,7 @@ ::nx::Object create doc { :method log {msg} { - puts stderr "[self]->[uplevel 1 [list ::nx::core::current proc]]: $msg" + puts stderr "[current]->[uplevel 1 [list ::nx::core::current proc]]: $msg" } # @method process @@ -1086,7 +1086,7 @@ #dict set :scripts [info script] objects # } #} - #puts stderr "dict lappend :scripts([info script]) objects [self]" + #puts stderr "dict lappend :scripts([info script]) objects [current]" [::nx::core::current class] eval [list dict set :scripts [info script] objects \$obj _] return \$obj } @@ -1386,7 +1386,7 @@ set :comment_block $block # initialise the context object - #puts stderr "--- [self callingproc] -> :partof_entity $partof_entity :processed_section $initial_section block $block" + #puts stderr "--- [current callingproc] -> :partof_entity $partof_entity :processed_section $initial_section block $block" set :processed_section $initial_section set :partof_entity $partof_entity @@ -1400,7 +1400,7 @@ set :is_not_completed 1 - ${:processed_section} eval [list set :context [self]] + ${:processed_section} eval [list set :context [current]] set is_first_iteration 1 set :idx 0 set failure "" @@ -1493,7 +1493,7 @@ # now, we just ignore and bypass this issue by allowing # InvalidTag exceptions in analyze() # - set qualified_tag [namespace qualifiers [self]]::$tag + set qualified_tag [namespace qualifiers [current]]::$tag if {[EntityClass info instances -closure $qualified_tag] eq ""} { [InvalidTag new -message [subst { The entity type '$tag' is not available @@ -1687,7 +1687,7 @@ :attribute next_comment_section; # implements a STATE-OWNED TRANSITION scheme :method init {} { - ${:entry_comment_line} comment_section [self] + ${:entry_comment_line} comment_section [current] } :method transition {line} { @@ -1709,7 +1709,7 @@ $src on_exit $line; } if {![info exists transitions(${src}->${tgt})]} { - set msg "Style violation in a [namespace tail [self]] section:\n" + set msg "Style violation in a [namespace tail [current]] section:\n" if {$src eq ""} { append msg "Invalid first line ('${tgt}')" } else { @@ -1719,7 +1719,7 @@ } set :current_comment_line $tgt - $tgt comment_section [self] + $tgt comment_section [current] ${:current_comment_line} processed_line $line ${:current_comment_line} on_enter $line Index: library/lib/test.tcl =================================================================== diff -u -r35c67391973a07983d0b0dfe70706e6a69fbdbfc -r89b5047e54e47a88a7de75d8523a07ffa5743407 --- library/lib/test.tcl (.../test.tcl) (revision 35c67391973a07983d0b0dfe70706e6a69fbdbfc) +++ library/lib/test.tcl (.../test.tcl) (revision 89b5047e54e47a88a7de75d8523a07ffa5743407) @@ -48,7 +48,7 @@ set :case $name if {[info exists arg]} { foreach o [Object info instances -closure] {set pre_exist($o) 1} - namespace eval :: [list [self] eval $arg] + namespace eval :: [list [current] eval $arg] #:eval $arg foreach o [Object info instances -closure] { if {[info exists pre_exist($o)]} continue @@ -60,11 +60,11 @@ :public object method parameter {name value:optional} { if {[info exists value]} { - #[[self] slot $name] default $value - [self] slot $name default $value + #[[current] slot $name] default $value + :slot $name default $value :__invalidateobjectparameter } else { - return [[self] slot $name default] + return [:slot $name default] } } Index: library/xotcl/library/xotcl2.tcl =================================================================== diff -u -rf3b7952aabc9e4f9079febd1f5b7f5fb833fd50c -r89b5047e54e47a88a7de75d8523a07ffa5743407 --- library/xotcl/library/xotcl2.tcl (.../xotcl2.tcl) (revision f3b7952aabc9e4f9079febd1f5b7f5fb833fd50c) +++ library/xotcl/library/xotcl2.tcl (.../xotcl2.tcl) (revision 89b5047e54e47a88a7de75d8523a07ffa5743407) @@ -45,6 +45,16 @@ namespace import ::nx::core::* namespace import ::nx::Attribute + proc ::xotcl::self {{arg "object"}} { + switch $arg { + next { + set handle [uplevel ::nx::core::current $arg] + method_handle_to_xotcl $handle + } + default {uplevel ::nx::core::current $arg} + } + } + # provide the standard command set for ::xotcl::Object foreach cmd [info command ::nx::core::cmd::Object::*] { set cmdName [namespace tail $cmd] @@ -358,8 +368,7 @@ set patternArg [expr {[info exists pattern] ? [list $pattern] : ""}] if {$order && !$guards} { set def [::nx::core::cmd::ObjectInfo::filter $o -order {*}$guardsFlag {*}$patternArg] - #puts stderr "TO CONVERT: $def" - set def [filterorder_list_to_xotcl1 $def] + set def [method_handles_to_xotcl $def] } else { set def [::nx::core::cmd::ObjectInfo::filter $o {*}$guardsFlag {*}$patternArg] } @@ -468,30 +477,37 @@ } return $options } - proc filterorder_list_to_xotcl1 definitions { + proc method_handles_to_xotcl definitions { set defs [list] - foreach def $definitions {lappend defs [filterorder_to_xotcl1 $def]} + foreach def $definitions {lappend defs [method_handle_to_xotcl $def]} return $defs } - proc filterorder_to_xotcl1 definition { + proc method_handle_to_xotcl methodHandle { + set definition [::nx::Object info method definition $methodHandle] + #puts "method_handle_to_xotcl raw definition '$methodHandle' // $definition" if {$definition ne ""} { + set obj [lindex $definition 0] set modifier [lindex $definition 1] - if {$modifier eq "object"} { + if {$modifier eq "object"} { set prefix "" set kind [lindex $definition 2] set name [lindex $definition 3] } else { - set prefix "inst" + set prefix [expr {[::nx::core::objectproperty $obj class] ? "inst" : ""}] set kind $modifier set name [lindex $definition 2] } if {$kind eq "method"} { set kind proc } elseif {$kind eq "setter"} { set kind parametercmd + } elseif {$kind eq "alias"} { + set kind "cmd" + set name [lindex $definition end-1] } set definition [list [lindex $definition 0] ${prefix}$kind $name] } + #puts "method_handle_to_xotcl gets definition '$methodHandle' // $definition" return $definition } @@ -521,7 +537,7 @@ } Object instproc filtersearch {filter} { set definition [::nx::core::dispatch [self] ::nx::core::cmd::Object::filtersearch $filter] - return [filterorder_to_xotcl1 $definition] + return [method_handle_to_xotcl $definition] } Object instproc procsearch {name} { set definition [::nx::core::cmd::ObjectInfo::callable [self] -which $name] Index: library/xotcl/tests/testx.xotcl =================================================================== diff -u -r8f2c993e02fe43f23c7e1653d05f6e298c23b2b2 -r89b5047e54e47a88a7de75d8523a07ffa5743407 --- library/xotcl/tests/testx.xotcl (.../testx.xotcl) (revision 8f2c993e02fe43f23c7e1653d05f6e298c23b2b2) +++ library/xotcl/tests/testx.xotcl (.../testx.xotcl) (revision 89b5047e54e47a88a7de75d8523a07ffa5743407) @@ -1426,7 +1426,7 @@ next } y n - ::errorCheck $infoNext " ::y+::Y->m*<> ::y+::Y->n*<::X method n> ::y+::X->n*<> ::y+->n*<::Y method n> ::y+::Y->n*<::X method n> ::y+::X->n*<>" \ + ::errorCheck $infoNext " ::y+::Y->m*<> ::y+::Y->n*<::X instproc n> ::y+::X->n*<> ::y+->n*<::Y instproc n> ::y+::Y->n*<::X instproc n> ::y+::X->n*<>" \ "simple self next test" set infoNext "" set result "" @@ -1466,7 +1466,7 @@ X x -test ::errorCheck $result "-::x-::x-" \ "Next Test X -- Wrong result" - ::errorCheck $infoNext " 2::b0+::B->m*<::A method m> 2::b+::B->m*<::A method m> 1::x+::X->init*<::xotcl::Object method init>" \ + ::errorCheck $infoNext " 2::b0+::B->m*<::A instproc m> 2::b+::B->m*<::A instproc m> 1::x+::X->init*<::xotcl::Object instproc init>" \ "self next test 2" X destroy x destroy @@ -1488,7 +1488,7 @@ } set result "" o mProc - ::errorCheck $result "::o-::MIX-::o object method mProc::o--" \ + ::errorCheck $result "::o-::MIX-::o proc mProc::o--" \ "Next Test Proc & Mixin" o destroy; MIX destroy @@ -2030,13 +2030,13 @@ Object instfilter "" -# ::errorCheck $::calling \ -# "{filter f: ::mixinTest {} run draw {::MenuDecorator instproc draw}} {m1 draw: ::mixinTest {} run {::ScrollBarDecorator instproc draw}} {m2 draw: ::mixinTest {} run {::Image instproc draw}} {image draw: ::mixinTest {} run {::GrObject instproc draw}} {grObject draw: ::mixinTest {} run {}} {filter f: ::mixinTest {} run draw {::ScrollBarDecorator instproc draw}} {m2 draw: ::mixinTest {} run {::Image instproc draw}} {image draw: ::mixinTest {} run {::GrObject instproc draw}} {grObject draw: ::mixinTest {} run {}} {filter f: ::mixinTest {} run instfilter {::xotcl::Class instforward instfilter}}" \ -# "Mixin: Calling-Obj/Cl/Proc failed" - ::errorCheck $::calling \ - "{filter f: ::mixinTest {} run draw {::MenuDecorator method draw}} {m1 draw: ::mixinTest {} run {::ScrollBarDecorator method draw}} {m2 draw: ::mixinTest {} run {::Image method draw}} {image draw: ::mixinTest {} run {::GrObject method draw}} {grObject draw: ::mixinTest {} run {}} {filter f: ::mixinTest {} run draw {::ScrollBarDecorator method draw}} {m2 draw: ::mixinTest {} run {::Image method draw}} {image draw: ::mixinTest {} run {::GrObject method draw}} {grObject draw: ::mixinTest {} run {}} {filter f: ::mixinTest {} run instfilter {::xotcl::Class forward instfilter}}" \ - "Mixin: Calling-Obj/Cl/Proc failed" + "{filter f: ::mixinTest {} run draw {::MenuDecorator instproc draw}} {m1 draw: ::mixinTest {} run {::ScrollBarDecorator instproc draw}} {m2 draw: ::mixinTest {} run {::Image instproc draw}} {image draw: ::mixinTest {} run {::GrObject instproc draw}} {grObject draw: ::mixinTest {} run {}} {filter f: ::mixinTest {} run draw {::ScrollBarDecorator instproc draw}} {m2 draw: ::mixinTest {} run {::Image instproc draw}} {image draw: ::mixinTest {} run {::GrObject instproc draw}} {grObject draw: ::mixinTest {} run {}} {filter f: ::mixinTest {} run instfilter {::xotcl::Class instforward instfilter}}" \ + "Mixin: Calling-Obj/Cl/Proc failed" + + # ::errorCheck $::calling \ + # "{filter f: ::mixinTest {} run draw {::MenuDecorator method draw}} {m1 draw: ::mixinTest {} run {::ScrollBarDecorator method draw}} {m2 draw: ::mixinTest {} run {::Image method draw}} {image draw: ::mixinTest {} run {::GrObject method draw}} {grObject draw: ::mixinTest {} run {}} {filter f: ::mixinTest {} run draw {::ScrollBarDecorator method draw}} {m2 draw: ::mixinTest {} run {::Image method draw}} {image draw: ::mixinTest {} run {::GrObject method draw}} {grObject draw: ::mixinTest {} run {}} {filter f: ::mixinTest {} run instfilter {::xotcl::Class forward instfilter}}" \ + # "Mixin: Calling-Obj/Cl/Proc failed" ::errorCheck $::mixinResult \ "{filter ::mainImage f ::xotcl::Object} {m1 ::mainImage draw ::MenuDecorator} {m2 ::mainImage draw ::ScrollBarDecorator} {image ::mainImage draw ::Image} {grObject ::mainImage draw ::GrObject} {filter ::zoom f ::xotcl::Object} {m2 ::zoom draw ::ScrollBarDecorator} {image ::zoom draw ::Image} {grObject ::zoom draw ::GrObject} {filter ::xotcl::Object f ::xotcl::Object}" \ @@ -2078,7 +2078,7 @@ # {self ::filteredObject {self proc} infoTraceFilter2 {self class} ::InfoTrace2 {self calledproc} set {self callingproc} callingProc {self callingobject} ::callingObject {self callingclass} ::CallingObjectsClass {self filterreg} {::FilterRegClass instfilter infoTraceFilter2} {self next} {::xotcl::Object instcmd set}} \ # "call stack info" ::errorCheck $::calling \ - {self ::filteredObject {self proc} infoTraceFilter2 {self class} ::InfoTrace2 {self calledproc} set {self callingproc} callingProc {self callingobject} ::callingObject {self callingclass} ::CallingObjectsClass {self filterreg} {::FilterRegClass filter infoTraceFilter2} {self next} {::xotcl::Object cmd set}} \ + {self ::filteredObject {self proc} infoTraceFilter2 {self class} ::InfoTrace2 {self calledproc} set {self callingproc} callingProc {self callingobject} ::callingObject {self callingclass} ::CallingObjectsClass {self filterreg} {::FilterRegClass filter infoTraceFilter2} {self next} {::xotcl::Object instcmd set}} \ "call stack info" Index: tests/aliastest.tcl =================================================================== diff -u -r35c67391973a07983d0b0dfe70706e6a69fbdbfc -r89b5047e54e47a88a7de75d8523a07ffa5743407 --- tests/aliastest.tcl (.../aliastest.tcl) (revision 35c67391973a07983d0b0dfe70706e6a69fbdbfc) +++ tests/aliastest.tcl (.../aliastest.tcl) (revision 89b5047e54e47a88a7de75d8523a07ffa5743407) @@ -62,7 +62,7 @@ S create s - T method foo args { return [self class]->[self proc] } + T method foo args { return [current class]->[current proc] } ::nx::core::alias T FOO ::nx::core::classes::T::foo ? {t foo} ::T->foo @@ -73,7 +73,7 @@ ? {lsort [T info methods]} {} "alias is deleted" # puts stderr "double indirection" - T method foo args { return [self class]->[self proc] } + T method foo args { return [current class]->[current proc] } ::nx::core::alias T FOO ::nx::core::classes::T::foo ::nx::core::alias S BAR ::nx::core::classes::T::FOO @@ -93,7 +93,7 @@ ? {T info methods} {} ? {S info methods} {} - T method foo args { return [self class]->[self proc] } + T method foo args { return [current class]->[current proc] } ::nx::core::alias T FOO ::nx::core::classes::T::foo ::nx::core::alias S BAR ::nx::core::classes::T::FOO @@ -103,8 +103,8 @@ ? {S info methods} {} ? {T info methods} {} - T method foo args { return [self class]->[self proc] } - T object method bar args { return [self class]->[self proc] } + T method foo args { return [current class]->[current proc] } + T object method bar args { return [current class]->[current proc] } ::nx::core::alias T -per-object FOO ::nx::core::classes::T::foo ::nx::core::alias T -per-object BAR ::T::FOO ::nx::core::alias T -per-object ZAP ::T::BAR @@ -140,15 +140,15 @@ Test case alias-per-object { Class create T { - :object method bar args { return [self class]->[self proc] } + :object method bar args { return [current class]->[current proc] } :create t } - proc ::foo args { return [self class]->[self proc] } + proc ::foo args { return [current class]->[current proc] } # # per-object methods as per-object aliases # - T object method m1 args { return [self class]->[self proc] } + T object method m1 args { return [current class]->[current proc] } ::nx::core::alias T -per-object M1 ::T::m1 ::nx::core::alias T -per-object M11 ::T::M1 ? {lsort [T object info methods]} {M1 M11 bar m1} @@ -166,7 +166,7 @@ # a proc as alias # - proc foo args { return [self class]->[self proc] } + proc foo args { return [current class]->[current proc] } ::nx::core::alias T FOO1 ::foo ::nx::core::alias T -per-object FOO2 ::foo # @@ -190,12 +190,12 @@ # namespaced procs + namespace deletion Test case alias-namespaced { Class create T { - :object method bar args { return [self class]->[self proc] } + :object method bar args { return [current class]->[current proc] } :create t } namespace eval ::ns1 { - proc foo args { return [self class]->[self proc] } + proc foo args { return [current class]->[current proc] } proc bar args { return [uplevel 2 {set _}] } proc bar2 args { upvar 2 _ __; return $__} } @@ -217,12 +217,12 @@ Class create U U create u ? {namespace exists ::U} 0 - U object method zap args { return [self class]->[self proc] } + U object method zap args { return [current class]->[current proc] } ::nx::core::alias ::U -per-object ZAP ::U::zap U requireNamespace ? {namespace exists ::U} 1 - U object method bar args { return [self class]->[self proc] } + U object method bar args { return [current class]->[current proc] } ::nx::core::alias U -per-object BAR ::U::bar ? {lsort [U object info methods]} {BAR ZAP bar zap} ? {U BAR} ->bar @@ -369,7 +369,7 @@ # C create c -proc ::foo args { return [self]->[self proc]} +proc ::foo args { return [current]->[current proc]} ? {info exists ::nx::core::alias(::C,FOO,0)} 0 ::nx::core::alias C FOO ::foo ? {info exists ::nx::core::alias(::C,FOO,0)} 1 Index: tests/destroytest.tcl =================================================================== diff -u -r35c67391973a07983d0b0dfe70706e6a69fbdbfc -r89b5047e54e47a88a7de75d8523a07ffa5743407 --- tests/destroytest.tcl (.../destroytest.tcl) (revision 35c67391973a07983d0b0dfe70706e6a69fbdbfc) +++ tests/destroytest.tcl (.../destroytest.tcl) (revision 89b5047e54e47a88a7de75d8523a07ffa5743407) @@ -12,7 +12,7 @@ } :method destroy {} { incr ::ObjectDestroy - #[:info class] dealloc [self] + #[:info class] dealloc [current] next } } @@ -23,13 +23,13 @@ set case "simple destroy (1)" Test case simple-destroy-1 Class create C -superclass O -C method destroy {} {incr ::firstDestroy; puts stderr " *** [self] destroy"; next} +C method destroy {} {incr ::firstDestroy; puts stderr " *** [current] destroy"; next} C method foo {} { - puts stderr "==== $::case [self]" + puts stderr "==== $::case [current]" :destroy - puts stderr "AAAA [self] exists [::nx::core::objectproperty [self] object]" + puts stderr "AAAA [current] exists [::nx::core::objectproperty [current] object]" :set x 1 - ? "[self] set x" 1 "$::case can still access [self]" + ? "[current] set x" 1 "$::case can still access [current]" puts stderr "BBBB" ? {::nx::core::objectproperty c1 object} 1 "$::case object still exists in proc" ? "set ::firstDestroy" 1 "firstDestroy called" @@ -48,13 +48,13 @@ set case "simple destroy (2), destroy blocks" Test case simple-destroy-2 Class create C -superclass O -C method destroy {} {incr ::firstDestroy; puts stderr " *** [self] destroy block"} +C method destroy {} {incr ::firstDestroy; puts stderr " *** [current] destroy block"} C method foo {} { - puts stderr "==== $::case [self]" + puts stderr "==== $::case [current]" :destroy - puts stderr "AAAA [self] exists [::nx::core::objectproperty [self] object]" + puts stderr "AAAA [current] exists [::nx::core::objectproperty [current] object]" :set x 1 - ? "[self] set x" 1 "$::case can still access [self]" + ? "[current] set x" 1 "$::case can still access [current]" puts stderr "BBBB" ? {::nx::core::objectproperty c1 object} 1 "$::case object still exists in proc" ? "set ::firstDestroy" 1 "firstDestroy called" @@ -73,13 +73,13 @@ set case "recreate" Test case recreate Class create C -superclass O -C method destroy {} {incr ::firstDestroy; puts stderr " *** [self] destroy"; next} +C method destroy {} {incr ::firstDestroy; puts stderr " *** [current] destroy"; next} C method foo {} { - puts stderr "==== $::case [self]" - [:info class] create [self] - puts stderr "AAAA [self] exists [::nx::core::objectproperty [self] object]" + puts stderr "==== $::case [current]" + [:info class] create [current] + puts stderr "AAAA [current] exists [::nx::core::objectproperty [current] object]" :set x 1 - ? "[self] set x" 1 "$::case can still access [self]" + ? "[current] set x" 1 "$::case can still access [current]" puts stderr "BBBB" ? {::nx::core::objectproperty c1 object} 1 "$::case object still exists in proc" ? "set ::firstDestroy" 0 "firstDestroy called" @@ -99,13 +99,13 @@ Test case rename-empty-1 Object create o Class create C -superclass O -C method destroy {} {incr ::firstDestroy; puts stderr " *** [self] destroy"; next} +C method destroy {} {incr ::firstDestroy; puts stderr " *** [current] destroy"; next} C method foo {} { - puts stderr "==== $::case [self]" - rename [self] "" - puts stderr "AAAA [self] exists [::nx::core::objectproperty [self] object]" + puts stderr "==== $::case [current]" + rename [current] "" + puts stderr "AAAA [current] exists [::nx::core::objectproperty [current] object]" :set x 1 - ? "[self] set x" 1 "$::case can still access [self]" + ? "[current] set x" 1 "$::case can still access [current]" puts stderr "BBB" ? {::nx::core::objectproperty c1 object} 1 "$::case object still exists in proc" ? "set ::firstDestroy" 1 "firstDestroy called" @@ -126,13 +126,13 @@ set case "cmd rename empty (2)" Test case rename-empty-2 Class create C -superclass O -C method destroy {} {incr ::firstDestroy; puts stderr " *** [self] destroy block"} +C method destroy {} {incr ::firstDestroy; puts stderr " *** [current] destroy block"} C method foo {} { - puts stderr "==== $::case [self]" - rename [self] "" - puts stderr "AAAA [self] exists [::nx::core::objectproperty [self] object]" + puts stderr "==== $::case [current]" + rename [current] "" + puts stderr "AAAA [current] exists [::nx::core::objectproperty [current] object]" :set x 1 - ? "[self] set x" 1 "$::case can still access [self]" + ? "[current] set x" 1 "$::case can still access [current]" puts stderr "BBB" ? {::nx::core::objectproperty c1 object} 1 "$::case object still exists in proc" ? "set ::firstDestroy" 1 "firstDestroy called" @@ -150,17 +150,17 @@ # cmd rename other xotcl object to current, # xotcl's rename invokes a move # -set case "cmd rename object to self" -Test case rename-to-self +set case "cmd rename object to current" +Test case rename-to-current Object create o Class create C -superclass O -C method destroy {} {incr ::firstDestroy; puts stderr " *** [self] destroy"; next} +C method destroy {} {incr ::firstDestroy; puts stderr " *** [current] destroy"; next} C method foo {} { - puts stderr "==== $::case [self]" - rename o [self] - puts stderr "AAAA [self] exists [::nx::core::objectproperty [self] object]" + puts stderr "==== $::case [current]" + rename o [current] + puts stderr "AAAA [current] exists [::nx::core::objectproperty [current] object]" :set x 1 - ? "[self] set x" 1 "$::case can still access [self]" + ? "[current] set x" 1 "$::case can still access [current]" puts stderr "BBB" ? {::nx::core::objectproperty c1 object} 1 "$::case object still exists in proc" ? "set ::firstDestroy" 0 "firstDestroy called" @@ -177,14 +177,14 @@ # cmd rename other proc to current object, # xotcl's rename invokes a move # -set case "cmd rename proc to self" -Test case rename-proc-to-self +set case "cmd rename proc to current" +Test case rename-proc-to-current proc o args {} Class create C -superclass O -C method destroy {} {incr ::firstDestroy; puts stderr " *** [self] destroy"; next} +C method destroy {} {incr ::firstDestroy; puts stderr " *** [current] destroy"; next} C method foo {} { - puts stderr "==== $::case [self]" - set x [catch {rename o [self]}] + puts stderr "==== $::case [current]" + set x [catch {rename o [current]}] ? "set _ $x" 1 "$::case tcl refuses to rename into an existing command" } C create c1 @@ -205,21 +205,21 @@ Test case delete-parent-namespace namespace eval ::test { Class create C -superclass O - C method destroy {} {incr ::firstDestroy; puts stderr " *** [self] destroy"; next} + C method destroy {} {incr ::firstDestroy; puts stderr " *** [current] destroy"; next} C method foo {} { - puts stderr "==== $::case [self]" + puts stderr "==== $::case [current]" namespace delete ::test - puts stderr "AAAA [self] exists [::nx::core::objectproperty [self] object]" + puts stderr "AAAA [current] exists [::nx::core::objectproperty [current] object]" :set x 1 # # If the following line is commented in, the namespace is deleted # here. Is there a bug with nsPtr->activationCount # - #? "[self] set x" 1 "$::case can still access [self]" + #? "[current] set x" 1 "$::case can still access [current]" puts stderr "BBB" - puts stderr "???? [self] exists [::nx::core::objectproperty [self] object]" - ? "::nx::core::objectproperty [self] object" 0 ;# WHY? - puts stderr "???? [self] exists [::nx::core::objectproperty [self] object]" + puts stderr "???? [current] exists [::nx::core::objectproperty [current] object]" + ? "::nx::core::objectproperty [current] object" 0 ;# WHY? + puts stderr "???? [current] exists [::nx::core::objectproperty [current] object]" ? "set ::firstDestroy" 0 "firstDestroy called" ? "set ::ObjectDestroy" 0 "$::case destroy not yet called" } @@ -245,21 +245,21 @@ namespace eval ::test { ? {namespace exists test::C} 0 "exists test::C" Class create C -superclass O - C method destroy {} {incr ::firstDestroy; puts stderr " *** [self] destroy block"} + C method destroy {} {incr ::firstDestroy; puts stderr " *** [current] destroy block"} C method foo {} { - puts stderr "==== $::case [self]" + puts stderr "==== $::case [current]" namespace delete ::test - puts stderr "AAAA [self] exists [::nx::core::objectproperty [self] object]" + puts stderr "AAAA [current] exists [::nx::core::objectproperty [current] object]" :set x 1 # # If the following line is commented in, the namespace is deleted # here. Is there a bug with nsPtr->activationCount # - #? "[self] set x" 1 "$::case can still access [self]" + #? "[current] set x" 1 "$::case can still access [current]" puts stderr "BBBB" - puts stderr "???? [self] exists [::nx::core::objectproperty [self] object]" - ? "::nx::core::objectproperty [self] object" 0 "$::case object still exists in proc";# WHY? - puts stderr "???? [self] exists [::nx::core::objectproperty [self] object]" + puts stderr "???? [current] exists [::nx::core::objectproperty [current] object]" + ? "::nx::core::objectproperty [current] object" 0 "$::case object still exists in proc";# WHY? + puts stderr "???? [current] exists [::nx::core::objectproperty [current] object]" ? "set ::firstDestroy" 0 "firstDestroy called" ? "set ::ObjectDestroy" 0 "ObjectDestroy called"; # NOT YET CALLED } @@ -280,16 +280,16 @@ Test case delete-parent-object Object create o Class create C -superclass O -C method destroy {} {incr ::firstDestroy; puts stderr " *** [self] destroy"; next} +C method destroy {} {incr ::firstDestroy; puts stderr " *** [current] destroy"; next} C method foo {} { - puts stderr "==== $::case [self]" + puts stderr "==== $::case [current]" o destroy puts stderr "AAAA" # the following isobject call has a problem in Tcl_GetCommandFromObj(), # which tries to access invalid memory - puts stderr "AAAA [self] exists [::nx::core::objectproperty [self] object]" + puts stderr "AAAA [current] exists [::nx::core::objectproperty [current] object]" :set x 1 - #? "[self] set x" 1 "$::case can still access [self]" + #? "[current] set x" 1 "$::case can still access [current]" puts stderr "BBBB" ? {::nx::core::objectproperty ::o::c1 object} 0 "$::case object still exists in proc" ? "set ::firstDestroy" 1 "firstDestroy called" @@ -313,13 +313,13 @@ Test case delete-parent-object-2 Object create o Class create C -superclass O -C method destroy {} {incr ::firstDestroy; puts stderr " *** [self] destroy block"} +C method destroy {} {incr ::firstDestroy; puts stderr " *** [current] destroy block"} C method foo {} { - puts stderr "==== $::case [self]" + puts stderr "==== $::case [current]" o destroy - puts stderr "AAAA [self] exists [::nx::core::objectproperty [self] object]" + puts stderr "AAAA [current] exists [::nx::core::objectproperty [current] object]" :set x 1 - #? "[self] set x" 1 "$::case can still access [self]" + #? "[current] set x" 1 "$::case can still access [current]" puts stderr "BBB" ? {::nx::core::objectproperty ::o::c1 object} 0 "$::case object still exists in proc" ? "set ::firstDestroy" 1 "firstDestroy called" @@ -341,13 +341,13 @@ Test case redefined-current-object-as-proc Object create o Class create C -superclass O -C method destroy {} {incr ::firstDestroy; puts stderr " *** [self] destroy"; next} +C method destroy {} {incr ::firstDestroy; puts stderr " *** [current] destroy"; next} C method foo {} { - puts stderr "==== $::case [self]" - proc [self] {args} {puts HELLO} - puts stderr "AAAA [self] exists [::nx::core::objectproperty [self] object]" + puts stderr "==== $::case [current]" + proc [current] {args} {puts HELLO} + puts stderr "AAAA [current] exists [::nx::core::objectproperty [current] object]" :set x 1 - #? "[self] set x" 1 "$::case can still access [self]" + #? "[current] set x" 1 "$::case can still access [current]" puts stderr "BBB" ? "set ::firstDestroy" 1 "firstDestroy called" ? "set ::ObjectDestroy" 1 "ObjectDestroy called" @@ -368,13 +368,13 @@ set case "delete active class" Test case delete-active-class Class create C -superclass O -C method destroy {} {incr ::firstDestroy; puts stderr " *** [self] destroy"; next} +C method destroy {} {incr ::firstDestroy; puts stderr " *** [current] destroy"; next} C method foo {} { - puts stderr "==== $::case [self]" + puts stderr "==== $::case [current]" C destroy - puts stderr "AAAA [self] exists [::nx::core::objectproperty [self] object]" + puts stderr "AAAA [current] exists [::nx::core::objectproperty [current] object]" :set x 1 - #? "[self] set x" 1 "$::case can still access [self]" + #? "[current] set x" 1 "$::case can still access [current]" puts stderr "BBB" #? [:info class] ::xotcl::Object "object reclassed" ? [:info class] ::C "object reclassed?" @@ -398,13 +398,13 @@ set case "delete active object nested in class" Test case delete-active-object-nested-in-class Class create C -superclass O -C method destroy {} {incr ::firstDestroy; puts stderr " *** [self] destroy"; next} +C method destroy {} {incr ::firstDestroy; puts stderr " *** [current] destroy"; next} C method foo {} { - puts stderr "==== $::case [self]" + puts stderr "==== $::case [current]" C destroy - puts stderr "AAAA [self] exists [::nx::core::objectproperty [self] object]" + puts stderr "AAAA [current] exists [::nx::core::objectproperty [current] object]" :set x 1 - #? "[self] set x" 1 "$::case can still access [self]" + #? "[current] set x" 1 "$::case can still access [current]" puts stderr "BBB" #? "set ::firstDestroy" 0 "firstDestroy called" ? "set ::firstDestroy" 1 "firstDestroy called" Index: tests/doc.tcl =================================================================== diff -u -r8f2c993e02fe43f23c7e1653d05f6e298c23b2b2 -r89b5047e54e47a88a7de75d8523a07ffa5743407 --- tests/doc.tcl (.../doc.tcl) (revision 8f2c993e02fe43f23c7e1653d05f6e298c23b2b2) +++ tests/doc.tcl (.../doc.tcl) (revision 89b5047e54e47a88a7de75d8523a07ffa5743407) @@ -699,8 +699,10 @@ # TODO: renaming of self to current? # - # what do you mean by "renaming"? - # maybe we should not import "self" into next scripting. + # what do you mean by "renaming"? both commands were available + # since a while. Maybe we should not import "self" into next scripting. + # DONE (sel is not imported anymore, all occurnces in next tests are changed) + # Not sure, we should keep since, since it will be a problem in many scripts. # TODO: is [self callingclass] == [[self callingobject] info class]? # @@ -712,7 +714,8 @@ # alias)? Retrieving the name from a handle is the more specific # operation (less generic). ... same for "filterreg" # - # this is most likely "self next" and "self filterreg". + # this is most likely "self next" and "self filterreg", + # but as well for .e.g "info filter ... -order ..." # there are already changes to xotcl (see migration guide). # since the handle works now as well for "info method", # this could be effectively done, but it requires Index: tests/forwardtest.tcl =================================================================== diff -u -rb07223692b7ed8b9b1cfc81f202f73c066456c7c -r89b5047e54e47a88a7de75d8523a07ffa5743407 --- tests/forwardtest.tcl (.../forwardtest.tcl) (revision b07223692b7ed8b9b1cfc81f202f73c066456c7c) +++ tests/forwardtest.tcl (.../forwardtest.tcl) (revision 89b5047e54e47a88a7de75d8523a07ffa5743407) @@ -65,7 +65,7 @@ ########################################### Test case mixin-via-forward { Object create mixin { - :method unknown {m args} {return [concat [self] $m $args]} + :method unknown {m args} {return [concat [current] $m $args]} } Object create obj { @@ -162,7 +162,7 @@ package require nx::serializer Test case serializer { Object create obj { - :method test {} {puts "i am [self proc]"} + :method test {} {puts "i am [current proc]"} } set ::a [Serializer deepSerialize obj] #puts <<$::a>> @@ -180,10 +180,10 @@ } ? {obj append x y z} 2yz - Object create n; Object create n::x {:method self {} {self}} + Object create n; Object create n::x {:method current {} {current}} Object create o o forward ::n::x - ? {o x self} ::n::x + ? {o x current} ::n::x } ########################################### @@ -261,9 +261,9 @@ Test case num-args { Object create obj { :forward f %self [list %argclindex [list a b c]] - :method a args {return [list [self proc] $args]} - :method b args {return [list [self proc] $args]} - :method c args {return [list [self proc] $args]} + :method a args {return [list [current proc] $args]} + :method b args {return [list [current proc] $args]} + :method c args {return [list [current proc] $args]} } ? {obj f} [list a {}] ? {obj f 1 } [list b 1] @@ -364,22 +364,22 @@ Object forward expr -objscope Class create C { - :method xx {} {self} + :method xx {} {current} :object method t {o expr} { return [$o expr $expr] } } C create c1 - ? {c1 expr {[self]}} ::c1 - ? {c1 expr {[self] == "::c1"}} 1 + ? {c1 expr {[current]}} ::c1 + ? {c1 expr {[current] == "::c1"}} 1 ? {c1 expr {[:xx]}} ::c1 ? {c1 expr {[:info class]}} ::C ? {c1 expr {[:info is type C]}} 1 ? {c1 expr {[:info is type ::C]}} 1 - ? {C t ::c1 {[self]}} ::c1 - ? {C t ::c1 {[self] == "::c1"}} 1 + ? {C t ::c1 {[current]}} ::c1 + ? {C t ::c1 {[current] == "::c1"}} 1 ? {C t ::c1 {[:xx]}} ::c1 ? {C t ::c1 {[:info class]}} ::C ? {C t ::c1 {[:info is type C]}} 1 Index: tests/method-modifiers.tcl =================================================================== diff -u -r35c67391973a07983d0b0dfe70706e6a69fbdbfc -r89b5047e54e47a88a7de75d8523a07ffa5743407 --- tests/method-modifiers.tcl (.../method-modifiers.tcl) (revision 35c67391973a07983d0b0dfe70706e6a69fbdbfc) +++ tests/method-modifiers.tcl (.../method-modifiers.tcl) (revision 89b5047e54e47a88a7de75d8523a07ffa5743407) @@ -5,9 +5,9 @@ Class create C { # methods - :method plain_method {} {return [self proc]} - :public method public_method {} {return [self proc]} - :protected method protected_method {} {return [self proc]} + :method plain_method {} {return [current proc]} + :public method public_method {} {return [current proc]} + :protected method protected_method {} {return [current proc]} # forwards :forward plain_forward %self plain_method @@ -25,9 +25,9 @@ :protected alias protected_alias [C info method name protected_method] # object - :object method plain_object_method {} {return [self proc]} - :public object method public_object_method {} {return [self proc]} - :protected object method protected_object_method {} {return [self proc]} + :object method plain_object_method {} {return [current proc]} + :public object method public_object_method {} {return [current proc]} + :protected object method protected_object_method {} {return [current proc]} :object forward plain_object_forward %self plain_object_method :public object forward public_object_forward %self public_object_method :protected object forward protected_object_forward %self protected_object_method @@ -40,9 +40,9 @@ } C create c1 { # methods - :method plain_object_method {} {return [self proc]} - :public method public_object_method {} {return [self proc]} - :protected method protected_object_method {} {return [self proc]} + :method plain_object_method {} {return [current proc]} + :public method public_object_method {} {return [current proc]} + :protected method protected_object_method {} {return [current proc]} # forwards :forward plain_object_forward %self plain_object_method @@ -92,7 +92,7 @@ ? {::nx::core::dispatch c2 protected_setter 4} "4" } -# class level alias ....TODO: wanted behavior of [self proc]? not "plain_alias"? +# class level alias ....TODO: wanted behavior of [current proc]? not "plain_alias"? Test case class-level-alias { ? {c2 plain_alias} "plain_method" ? {c2 public_alias} "public_method" @@ -126,7 +126,7 @@ ? {::nx::core::dispatch C protected_object_setter 4} "4" } -# class-object level alias ....TODO: wanted behavior of [self proc]? not "plain_alias"? +# class-object level alias ....TODO: wanted behavior of [current proc]? not "plain_alias"? Test case class-object-level-alias { ? {C plain_object_alias} "plain_object_method" ? {C public_object_alias} "public_object_method" @@ -159,7 +159,7 @@ ? {catch {c1 protected_object_setter 3}} 1 ? {::nx::core::dispatch c1 protected_object_setter 4} "4" -# object level alias ....TODO: wanted behavior of [self proc]? not "plain_alias"? +# object level alias ....TODO: wanted behavior of [current proc]? not "plain_alias"? Test case object-level-alias { ? {c1 plain_object_alias} "plain_object_method" ? {c1 public_object_alias} "public_object_method" @@ -213,14 +213,14 @@ Object create o { :method bar {-y:required -x:required} { - #puts stderr "+++ o x=$x, y=$y [self args] ... next [self next]" - return [list x $x y $y [self args]] + #puts stderr "+++ o x=$x, y=$y [current args] ... next [current next]" + return [list x $x y $y [current args]] } } Class create M { :method bar {-x:required -y:required} { - #puts stderr "+++ M x=$x, y=$y [self args] ... next [self next]" - return [list x $x y $y [self args] -- {*}[next]] + #puts stderr "+++ M x=$x, y=$y [current args] ... next [current next]" + return [list x $x y $y [current args] -- {*}[next]] } } Index: tests/parameters.tcl =================================================================== diff -u -r35c67391973a07983d0b0dfe70706e6a69fbdbfc -r89b5047e54e47a88a7de75d8523a07ffa5743407 --- tests/parameters.tcl (.../parameters.tcl) (revision 35c67391973a07983d0b0dfe70706e6a69fbdbfc) +++ tests/parameters.tcl (.../parameters.tcl) (revision 89b5047e54e47a88a7de75d8523a07ffa5743407) @@ -377,20 +377,20 @@ :create d1 :method bar { - {-s:substdefault "[self]"} - {-literal "[self]"} + {-s:substdefault "[current]"} + {-literal "[current]"} {-c:substdefault "[my c]"} {-d:integer,substdefault "$d"} } { return $s-$literal-$c-$d } } - ? {d1 bar -c 1} {::d1-[self]-1-2} "substdefault in method parameter" + ? {d1 bar -c 1} {::d1-[current]-1-2} "substdefault in method parameter" Class create Bar -superclass D -parameter { - {s "[self]"} - {literal "\\[self\\]"} + {s "[current]"} + {literal "\\[current\\]"} {c "[:info class]"} {d "literal $d"} {switch:switch} @@ -399,12 +399,12 @@ #puts stderr [bar1 objectparameter] ? {subst {[bar1 s]-[bar1 literal]-[bar1 c]-[bar1 d]-[bar1 switch]}} \ - {::bar1-[self]-::Bar-literal $d-0} \ + {::bar1-[current]-::Bar-literal $d-0} \ "substdefault and switch in object parameter 1" Bar create bar2 -switch ? {subst {[bar2 s]-[bar2 literal]-[bar2 c]-[bar2 d]-[bar2 switch]}} \ - {::bar2-[self]-::Bar-literal $d-1} \ + {::bar2-[current]-::Bar-literal $d-1} \ "substdefault and switch in object parameter 2" # Observations: @@ -423,8 +423,8 @@ # deactivated for now; otherwise we would need "\\" D method bar { - {-s:substdefault "[self]"} - {-literal "[self]"} + {-s:substdefault "[current]"} + {-literal "[current]"} {-c:substdefault "[my c]"} {-d:integer,substdefault "$d"} {-switch:switch} @@ -438,12 +438,12 @@ ? {D info method args bar} {s literal c d switch optflag x y z} "all args" ? {D info method parameter bar} \ - {{-s:substdefault "[self]"} {-literal "[self]"} {-c:substdefault "[my c]"} {-d:integer,substdefault "$d"} -switch:switch -optflag x y:integer {z 1}} \ + {{-s:substdefault "[current]"} {-literal "[current]"} {-c:substdefault "[my c]"} {-d:integer,substdefault "$d"} -switch:switch -optflag x y:integer {z 1}} \ "query method parameter" D method foo {a b {-c 1} {-d} x {-end 100}} { set result [list] - foreach v [[self class] info method args [self proc]] { + foreach v [[current class] info method args [current proc]] { lappend result $v [info exists $v] } return $result @@ -454,7 +454,7 @@ D method foo {a b c {end 100}} { set result [list] - foreach v [[self class] info method args [self proc]] { + foreach v [[current class] info method args [current proc]] { lappend result $v [info exists $v] } return $result @@ -696,7 +696,7 @@ ? {s1 method foo {{a:substdefault $aaa}} {return $a}} ::s1::foo ? {s1 foo} {can't read "aaa": no such variable} - ? {s1 method foo {{a:substdefault [self]}} {return $a}} ::s1::foo + ? {s1 method foo {{a:substdefault [current]}} {return $a}} ::s1::foo ? {s1 foo} ::s1 } @@ -708,16 +708,16 @@ Class create Bar { # simple, implicit substdefault - :attribute {s0 "[self]"} + :attribute {s0 "[current]"} # explicit substdefault - :attribute {s1:substdefault "[self]"} + :attribute {s1:substdefault "[current]"} # unneeded double substdefault - :attribute {s2:substdefault,substdefault "[self]"} + :attribute {s2:substdefault,substdefault "[current]"} # substdefault with incremental - :attribute {s3:substdefault "[self]"} { + :attribute {s3:substdefault "[current]"} { # Bypassing the Optimizer helps after applying the patch (solving step 1) set :incremental 1 } @@ -844,7 +844,7 @@ Test case multivalued-app-converter { ::nx::methodParameterSlot method type=sex {name value args} { - #puts stderr "[self] slot specific converter" + #puts stderr "[current] slot specific converter" switch -glob $value { m* {return m} f* {return f} @@ -903,7 +903,7 @@ Person slots { Attribute create sex -type "sex" { :method type=sex {name value} { - #puts stderr "[self] slot specific converter" + #puts stderr "[current] slot specific converter" switch -glob $value { m* {return m} f* {return f} Index: tests/protected.tcl =================================================================== diff -u -r35c67391973a07983d0b0dfe70706e6a69fbdbfc -r89b5047e54e47a88a7de75d8523a07ffa5743407 --- tests/protected.tcl (.../protected.tcl) (revision 35c67391973a07983d0b0dfe70706e6a69fbdbfc) +++ tests/protected.tcl (.../protected.tcl) (revision 89b5047e54e47a88a7de75d8523a07ffa5743407) @@ -6,8 +6,8 @@ Class create C { :alias SET ::set - :method foo {} {return [self proc]} - :method bar {} {return [self proc]} + :method foo {} {return [current proc]} + :method bar {} {return [current proc]} :method bar-foo {} { c1 foo } @@ -62,7 +62,7 @@ ? {c2 bar-foo} {foo} # define a protected method -C protected method foo {} {return [self proc]} +C protected method foo {} {return [current proc]} ? {::nx::core::methodproperty C SET protected} 0 ? {c1 SET x 3} 3 ? {::nx::core::dispatch c1 SET x 4} {4} Index: tests/varresolutiontest.tcl =================================================================== diff -u -r8274c68ad85f12b1e4a41a01273079405fa865ef -r89b5047e54e47a88a7de75d8523a07ffa5743407 --- tests/varresolutiontest.tcl (.../varresolutiontest.tcl) (revision 8274c68ad85f12b1e4a41a01273079405fa865ef) +++ tests/varresolutiontest.tcl (.../varresolutiontest.tcl) (revision 89b5047e54e47a88a7de75d8523a07ffa5743407) @@ -51,33 +51,33 @@ set x 1 set :y 2 set ::z 3 - set [self]::X 4 + set [current]::X 4 set g 1 set :a(:b) 1 set :a(::c) 1 } ? {::nx::core::importvar o2 j} \ "importvar cannot import variable 'j' into method scope; not called from a method frame" -o method foo {} {::nx::core::importvar [self] :a} +o method foo {} {::nx::core::importvar [current] :a} ? {o foo} "variable name \":a\" must not contain namespace separator or colon prefix" -o method foo {} {::nx::core::importvar [self] ::a} +o method foo {} {::nx::core::importvar [current] ::a} ? {o foo} "variable name \"::a\" must not contain namespace separator or colon prefix" -o method foo {} {::nx::core::importvar [self] a(:b)} +o method foo {} {::nx::core::importvar [current] a(:b)} ? {o foo} "can't make instance variable a(:b) on ::o: Variable cannot be an element in an array; use e.g. an alias." -o method foo {} {::nx::core::importvar [self] {a(:b) ab}} +o method foo {} {::nx::core::importvar [current] {a(:b) ab}} ? {o foo} "" -o method foo {} {::nx::core::existsvar [self] ::a} +o method foo {} {::nx::core::existsvar [current] ::a} ? {o foo} "variable name \"::a\" must not contain namespace separator or colon prefix" -o method foo {} {::nx::core::existsvar [self] a(:b)} +o method foo {} {::nx::core::existsvar [current] a(:b)} ? {o foo} 1 -o method foo {} {::nx::core::existsvar [self] a(::c)} +o method foo {} {::nx::core::existsvar [current] a(::c)} ? {o foo} 1 set ::o::Y 5 @@ -109,7 +109,7 @@ set x 1 set :y 2 set ::z 3 - set [self]::X 4 + set [current]::X 4 set g 1 } set ::o::Y 5 @@ -371,7 +371,7 @@ ############################################### Class create C C method bar {args} { - #puts stderr "[self] bar called with [list $args]" + #puts stderr "[current] bar called with [list $args]" return $args } C forward test %self bar