Index: generic/gentclAPI.decls =================================================================== diff -u -rbe717fe9ef13e09dcfabf496ca61d75e4c042422 -re61fc14f5c25172a1d1f93bea03be54a772fb4b5 --- generic/gentclAPI.decls (.../gentclAPI.decls) (revision be717fe9ef13e09dcfabf496ca61d75e4c042422) +++ generic/gentclAPI.decls (.../gentclAPI.decls) (revision e61fc14f5c25172a1d1f93bea03be54a772fb4b5) @@ -20,6 +20,7 @@ {-argName "object" -type object} {-argName "-per-object"} {-argName "methodName"} + {-argName "-nonleaf"} {-argName "-objscope"} {-argName "cmdName" -required 1 -type tclobj} } Index: generic/predefined.xotcl =================================================================== diff -u -rbe717fe9ef13e09dcfabf496ca61d75e4c042422 -re61fc14f5c25172a1d1f93bea03be54a772fb4b5 --- generic/predefined.xotcl (.../predefined.xotcl) (revision be717fe9ef13e09dcfabf496ca61d75e4c042422) +++ generic/predefined.xotcl (.../predefined.xotcl) (revision e61fc14f5c25172a1d1f93bea03be54a772fb4b5) @@ -718,7 +718,6 @@ {withclass ::xotcl2::Object} inobject } - ::xotcl::ScopedNew method init {} { .public method new {-childof args} { ::xotcl::importvar [::xotcl::self class] {inobject object} withclass @@ -728,6 +727,7 @@ eval ::xotcl::next -childof $object $args } } + # # change the namespace to the specified object and create # objects there. This is a friendly notation for creating @@ -764,6 +764,7 @@ if {![::xotcl::is [::xotcl::self]::slot object]} { ::xotcl2::Object create [::xotcl::self]::slot } + foreach arg $arglist { set l [llength $arg] set name [lindex $arg 0] @@ -847,7 +848,7 @@ {dest ""} objLength } { - + .method makeTargetList {t} { lappend .targetList $t # if it is an object without namespace, it is a leaf @@ -964,6 +965,7 @@ } } + ::xotcl2::Object public method copy newName { if {[string compare [string trimleft $newName :] [string trimleft [::xotcl::self] :]]} { [::xotcl::CopyHandler new -volatile] copy [::xotcl::self] $newName Index: generic/tclAPI.h =================================================================== diff -u -rbe717fe9ef13e09dcfabf496ca61d75e4c042422 -re61fc14f5c25172a1d1f93bea03be54a772fb4b5 --- generic/tclAPI.h (.../tclAPI.h) (revision be717fe9ef13e09dcfabf496ca61d75e4c042422) +++ generic/tclAPI.h (.../tclAPI.h) (revision e61fc14f5c25172a1d1f93bea03be54a772fb4b5) @@ -243,7 +243,7 @@ static int XOTclOUpvarMethod(Tcl_Interp *interp, XOTclObject *obj, int objc, Tcl_Obj *CONST objv[]); static int XOTclOVolatileMethod(Tcl_Interp *interp, XOTclObject *obj); static int XOTclOVwaitMethod(Tcl_Interp *interp, XOTclObject *obj, char *varname); -static int XOTclAliasCmd(Tcl_Interp *interp, XOTclObject *object, int withPer_object, char *methodName, int withObjscope, Tcl_Obj *cmdName); +static int XOTclAliasCmd(Tcl_Interp *interp, XOTclObject *object, int withPer_object, char *methodName, int withNonleaf, int withObjscope, Tcl_Obj *cmdName); static int XOTclAssertionCmd(Tcl_Interp *interp, XOTclObject *object, int assertionsubcmd, Tcl_Obj *arg); static int XOTclConfigureCmd(Tcl_Interp *interp, int configureoption, Tcl_Obj *value); static int XOTclCreateObjectSystemCmd(Tcl_Interp *interp, Tcl_Obj *rootClass, Tcl_Obj *rootMetaClass); @@ -1508,11 +1508,12 @@ XOTclObject *object = (XOTclObject *)pc.clientData[0]; int withPer_object = (int )PTR2INT(pc.clientData[1]); char *methodName = (char *)pc.clientData[2]; - int withObjscope = (int )PTR2INT(pc.clientData[3]); - Tcl_Obj *cmdName = (Tcl_Obj *)pc.clientData[4]; + int withNonleaf = (int )PTR2INT(pc.clientData[3]); + int withObjscope = (int )PTR2INT(pc.clientData[4]); + Tcl_Obj *cmdName = (Tcl_Obj *)pc.clientData[5]; parseContextRelease(&pc); - return XOTclAliasCmd(interp, object, withPer_object, methodName, withObjscope, cmdName); + return XOTclAliasCmd(interp, object, withPer_object, methodName, withNonleaf, withObjscope, cmdName); } } @@ -2183,10 +2184,11 @@ {"::xotcl::cmd::Object::vwait", XOTclOVwaitMethodStub, 1, { {"varname", 1, 0, convertToString}} }, -{"::xotcl::alias", XOTclAliasCmdStub, 5, { +{"::xotcl::alias", XOTclAliasCmdStub, 6, { {"object", 0, 0, convertToObject}, {"-per-object", 0, 0, convertToString}, {"methodName", 0, 0, convertToString}, + {"-nonleaf", 0, 0, convertToString}, {"-objscope", 0, 0, convertToString}, {"cmdName", 1, 0, convertToTclobj}} }, Index: generic/xotcl.c =================================================================== diff -u -rbe717fe9ef13e09dcfabf496ca61d75e4c042422 -re61fc14f5c25172a1d1f93bea03be54a772fb4b5 --- generic/xotcl.c (.../xotcl.c) (revision be717fe9ef13e09dcfabf496ca61d75e4c042422) +++ generic/xotcl.c (.../xotcl.c) (revision e61fc14f5c25172a1d1f93bea03be54a772fb4b5) @@ -1543,11 +1543,13 @@ */ static int varResolver(Tcl_Interp *interp, CONST char *varName, Tcl_Namespace *nsPtr, int flags, Tcl_Var *varPtr) { - int new; + int new, frameFlags; Tcl_Obj *key; Tcl_CallFrame *varFramePtr; Var *newVar; + /*fprintf(stderr, "varResolver '%s' flags %.6x\n", varName, flags);*/ + /* Case 1: The variable is to be resolved in global scope, proceed in * resolver chain (i.e. return TCL_CONTINUE) */ @@ -1562,26 +1564,46 @@ * these cases here, so proceed in resolver chain. */ varFramePtr = (Tcl_CallFrame *)Tcl_Interp_varFramePtr(interp); - if (varFramePtr && (Tcl_CallFrame_isProcCallFrame(varFramePtr) & FRAME_IS_PROC)) { + assert(varFramePtr); + + frameFlags = Tcl_CallFrame_isProcCallFrame(varFramePtr); +#if defined (VAR_RESOLVER_TRACE) + fprintf(stderr, "varResolver '%s' frame flags %.6x\n", varName, + Tcl_CallFrame_isProcCallFrame(varFramePtr)); +#endif + + if (frameFlags & FRAME_IS_PROC) { +#if defined (VAR_RESOLVER_TRACE) + fprintf(stderr, "...... forwarding to next resolver\n"); +#endif /*fprintf(stderr, "proc-scoped var '%s' assumed, frame %p flags %.6x\n", name, varFramePtr, Tcl_CallFrame_isProcCallFrame(varFramePtr));*/ return TCL_CONTINUE; } - /* - * Case 3: Check for absolutely/relatively qualified variable names, - * i.e. make sure that the variable name does not contain any - * namespace qualifiers. Proceed with a TCL_CONTINUE, otherwise. - */ - if ((*varName == ':' && *(varName+1) == ':') || NSTail(varName) != varName) { + if ((frameFlags & (FRAME_IS_XOTCL_CMETHOD|FRAME_IS_XOTCL_OBJECT)) && *varName == '.') { + /* + * Case 3: we are in an XOTcl frame and the variable name starts with a "." + * We skip the dot, but stay in the resolver. + */ + varName ++; + } else if ((*varName == ':' && *(varName+1) == ':') || NSTail(varName) != varName) { + + /* + * Case 4: Check for absolutely/relatively qualified variable names, + * i.e. make sure that the variable name does not contain any + * namespace qualifiers. Proceed with a TCL_CONTINUE, otherwise. + */ return TCL_CONTINUE; } - /* Case 4: Does the variable exist in the per-object namespace? */ + /* + * Does the variable exist in the per-object namespace? + */ *varPtr = (Tcl_Var)LookupVarFromTable(Tcl_Namespace_varTable(nsPtr), varName, NULL); if (*varPtr == NULL) { /* We failed to find the variable so far, therefore we create it - * here in the namespace. Note that the cases (1), (2) and (3) + * in this namespace. Note that the cases (1), (2) and (4) * TCL_CONTINUE care for variable creation if necessary. */ key = Tcl_NewStringObj(varName, -1); @@ -1724,32 +1746,57 @@ static int DotCmdResolver(Tcl_Interp *interp, CONST char *cmdName, Tcl_Namespace *nsPtr, int flags, Tcl_Command *cmdPtr) { CallFrame *varFramePtr; + int frameFlags; if (*cmdName != '.' || flags & TCL_GLOBAL_ONLY) { /* ordinary names and global lookups are not for us */ return TCL_CONTINUE; } varFramePtr = Tcl_Interp_varFramePtr(interp); - if (Tcl_CallFrame_isProcCallFrame(varFramePtr) & (FRAME_IS_XOTCL_METHOD|FRAME_IS_XOTCL_OBJECT)) { - /*fprintf(stderr, "DotCmdResolver called with %s\n", cmdName);*/ + frameFlags = Tcl_CallFrame_isProcCallFrame(varFramePtr); + + /* skip over a nonproc frame, in case Tcl stacks it */ + if (frameFlags == 0 && Tcl_CallFrame_callerPtr(varFramePtr)) { + varFramePtr = (CallFrame *)Tcl_CallFrame_callerPtr(varFramePtr); + frameFlags = Tcl_CallFrame_isProcCallFrame(varFramePtr); +#if defined(DOT_CMD_RESOLVER_TRACE) + fprintf(stderr, "DotCmdResolver uses parent frame\n"); +#endif + } +#if defined(DOT_CMD_RESOLVER_TRACE) + fprintf(stderr, "DotCmdResolver cmdName %s frame flags %.6x\n",cmdName, + Tcl_CallFrame_isProcCallFrame(varFramePtr)); +#endif + + if (frameFlags & (FRAME_IS_XOTCL_METHOD|FRAME_IS_XOTCL_OBJECT|FRAME_IS_XOTCL_CMETHOD )) { +#if defined(DOT_CMD_RESOLVER_TRACE) + fprintf(stderr, " ... call dotCmd for %s\n", cmdName); +#endif /* * We have a cmd starting with ".", we are in an xotcl frame, so * forward to the dotCmd. */ *cmdPtr = RUNTIME_STATE(interp)->dotCmd; return TCL_OK; } - +#if defined(DOT_CMD_RESOLVER_TRACE) + fprintf(stderr, " ... not found %s\n", cmdName); + tcl85showStack(interp); +#endif return TCL_CONTINUE; } static int DotVarResolver(Tcl_Interp *interp, CONST char *varName, Tcl_Namespace *nsPtr, int flags, Tcl_Var *varPtr) { int new, frameFlags; CallFrame *varFramePtr; + TclVarHashTable *varTablePtr; + XOTclObject *obj; Tcl_Var var; + /*fprintf(stderr, "dotVarResolver '%s' flags %.6x\n", varName, flags);*/ + if (*varName != '.' || flags & TCL_GLOBAL_ONLY) { /* ordinary names and global lookups are not for us */ return TCL_CONTINUE; @@ -1761,54 +1808,73 @@ varName ++; varFramePtr = Tcl_Interp_varFramePtr(interp); frameFlags = Tcl_CallFrame_isProcCallFrame(varFramePtr); - /*fprintf(stderr, "dotVarResolver called var=%s var flags %.8x frame flags %.6x\n", - varName, flags, frameFlags);*/ - if (Tcl_CallFrame_isProcCallFrame(varFramePtr) & (FRAME_IS_XOTCL_METHOD|FRAME_IS_XOTCL_OBJECT)) { - TclVarHashTable *varTablePtr; - XOTclObject *obj; + +#if 0 + /* This chunk is needed in the dotcmd resolver, but does not seem to + be required here */ + if (frameFlags == 0 && Tcl_CallFrame_callerPtr(varFramePtr)) { + varFramePtr = (CallFrame *)Tcl_CallFrame_callerPtr(varFramePtr); + frameFlags = Tcl_CallFrame_isProcCallFrame(varFramePtr); + fprintf(stderr, " use parent frame\n"); + } +#endif +#if defined(VAR_RESOLVER_TRACE) + fprintf(stderr, " frame flags %.6x\n", frameFlags); +#endif + + if (frameFlags & FRAME_IS_XOTCL_METHOD) { if ((*varPtr = CompiledLocalsLookup(varFramePtr, varName))) { #if defined(VAR_RESOLVER_TRACE) fprintf(stderr, ".... found local %s\n", varName); #endif return TCL_OK; } - - obj = frameFlags & FRAME_IS_XOTCL_METHOD ? - ((XOTclCallStackContent *)varFramePtr->clientData)->self : - (XOTclObject *)(varFramePtr->clientData); - varTablePtr = obj->nsPtr ? Tcl_Namespace_varTable(obj->nsPtr) : obj->varTable; - - if (varTablePtr == NULL && obj->varTable == NULL) { - varTablePtr = obj->varTable = VarHashTableCreate(); - } - - /*fprintf(stderr, "Object Var Resolver, name=%s, obj %p, nsPtr %p, varTable %p\n", - varName, obj, obj->nsPtr, varTablePtr);*/ - var = (Tcl_Var)LookupVarFromTable(varTablePtr, varName, NULL); - if (var) { + + obj = ((XOTclCallStackContent *)varFramePtr->clientData)->self; + + } else if (frameFlags & FRAME_IS_XOTCL_CMETHOD) { + obj = ((XOTclCallStackContent *)varFramePtr->clientData)->self; + + } else if (frameFlags & FRAME_IS_XOTCL_OBJECT) { + obj = (XOTclObject *)(varFramePtr->clientData); + + } else { #if defined(VAR_RESOLVER_TRACE) - fprintf(stderr, ".... found in hashtable %s %p\n", varName, var); + fprintf(stderr, ".... not found %s\n", varName); #endif - } else { - /* We failed to find the variable, therefore we create it new */ - Tcl_Obj *key = Tcl_NewStringObj(varName, -1); + return TCL_CONTINUE; + } - INCR_REF_COUNT(key); - var = (Tcl_Var)VarHashCreateVar(varTablePtr, key, &new); - DECR_REF_COUNT(key); + /* We have an object and create the variable if not found */ + assert(obj); + + varTablePtr = obj->nsPtr ? Tcl_Namespace_varTable(obj->nsPtr) : obj->varTable; + if (varTablePtr == NULL && obj->varTable == NULL) { + varTablePtr = obj->varTable = VarHashTableCreate(); + } + + /*fprintf(stderr, "Object Var Resolver, name=%s, obj %p, nsPtr %p, varTable %p\n", + varName, obj, obj->nsPtr, varTablePtr);*/ + var = (Tcl_Var)LookupVarFromTable(varTablePtr, varName, NULL); + if (var) { #if defined(VAR_RESOLVER_TRACE) - fprintf(stderr, ".... created in hashtable %s %p\n", varName, var); + fprintf(stderr, ".... found in hashtable %s %p\n", varName, var); #endif - } - *varPtr = var; - return TCL_OK; - } + } else { + /* We failed to find the variable, therefore we create it new */ + Tcl_Obj *key = Tcl_NewStringObj(varName, -1); + + INCR_REF_COUNT(key); + var = (Tcl_Var)VarHashCreateVar(varTablePtr, key, &new); + DECR_REF_COUNT(key); #if defined(VAR_RESOLVER_TRACE) - fprintf(stderr, ".... not found %s\n", varName); + fprintf(stderr, ".... created in hashtable %s %p\n", varName, var); #endif - return TCL_CONTINUE; + } + *varPtr = var; + return TCL_OK; } #endif @@ -5577,11 +5643,12 @@ #if defined(TCL85STACK) if (cscPtr) { /* We have a call stack content, but the following dispatch will - * by itself no stack it; in order to get e.g. self working, we + * by itself not stack it; in order to get e.g. self working, we * have to stack at least an FRAME_IS_XOTCL_OBJECT. * TODO: maybe push should happen already before assertion checking, * but we have to check what happens in the finish target etc. */ + /*fprintf(stderr, "XOTcl_PushFrameCsc %s %s\n",objectName(obj), methodName);*/ XOTcl_PushFrameCsc(interp, obj, cscPtr); /*XOTcl_PushFrame(interp, obj);*/ } @@ -5652,12 +5719,16 @@ ClientData cp = Tcl_Command_objClientData(cmd); XOTclCallStackContent csc, *cscPtr; register Tcl_ObjCmdProc *proc = Tcl_Command_objProc(cmd); + int result; assert (!obj->teardown); /*fprintf(stderr, "MethodDispatch method '%s' cmd %p cp=%p objc=%d\n", methodName, cmd, cp, objc);*/ if (proc == TclObjInterpProc) { + /* + The cmd is a scripted method + */ #if defined(NRE) cscPtr = (XOTclCallStackContent *) TclStackAlloc(interp, sizeof(XOTclCallStackContent)); # if defined(TCL_STACK_ALLOC_TRACE) @@ -5666,9 +5737,6 @@ #else cscPtr = &csc; #endif - /* - * invoke a Tcl-defined method - */ #if defined(TCL85STACK) CallStackPush(cscPtr, obj, cl, cmd, frameType); #else @@ -5684,12 +5752,14 @@ #endif return result; - } else if (cp) { + } else if (cp || Tcl_Command_flags(cmd) & XOTCL_CMD_NONLEAF_METHOD) { + /* + The cmd has client data or is an aliased method + */ cscPtr = &csc; /*fprintf(stderr, "we could stuff obj %p %s\n", obj, objectName(obj));*/ - /* some cmd with client data */ if (proc == XOTclObjDispatch) { /* * invoke an aliased object via method interface @@ -5722,16 +5792,19 @@ return TCL_ERROR; #endif } else { - /* a cmd without client data */ - assert((CmdIsProc(cmd) == 0)); - cp = clientData; - cscPtr = NULL; + /* + The cmd has no client data + */ + /*fprintf(stderr, "cmdMethodDispatch %s %s, nothing stacked\n",objectName(obj), methodName);*/ + + return CmdMethodDispatch(clientData, interp, objc, objv, methodName, obj, cmd, NULL); } + result = CmdMethodDispatch(cp, interp, objc, objv, methodName, obj, cmd, cscPtr); - if (cscPtr) { - /* make sure, that csc is still in the scope; therefore, csc is currently on the top scope of this function */ - CallStackPop(interp, cscPtr); - } + /* make sure, that csc is still in the scope; therefore, csc is + currently on the top scope of this function */ + CallStackPop(interp, cscPtr); + return result; } @@ -7756,12 +7829,6 @@ /* Look for a configured default superclass */ defaultSuperclass = DefaultSuperClass(interp, cl, cl->object.cl, 0); - /* - if (defaultSuperclass) { - fprintf(stderr, "default superclass= %s\n", className(defaultSuperclass)); - } else { - fprintf(stderr, "empty super class\n"); - }*/ AddSuper(cl, defaultSuperclass); cl->color = WHITE; @@ -10280,12 +10347,14 @@ {-argName "object" -type object} {-argName "-per-object"} {-argName "methodName"} + {-argName "-nonleaf"} {-argName "-objscope"} {-argName "cmdName" -required 1 -type tclobj} } */ static int XOTclAliasCmd(Tcl_Interp *interp, XOTclObject *object, int withPer_object, - char *methodName, int withObjscope, Tcl_Obj *cmdName) { + char *methodName, int withNonleaf, int withObjscope, + Tcl_Obj *cmdName) { Tcl_ObjCmdProc *objProc, *newObjProc = NULL; Tcl_CmdDeleteProc *deleteProc = NULL; AliasCmdClientData *tcd = NULL; /* make compiler happy */ @@ -10410,6 +10479,12 @@ AliasAdd(interp, object->cmdName, methodName, cl == NULL, Tcl_DStringValue(dsPtr)); Tcl_DStringFree(dsPtr); + if (!withObjscope && withNonleaf) { + Tcl_Command_flags(newCmd) |= XOTCL_CMD_NONLEAF_METHOD; + fprintf(stderr, "setting aliased for cmd %p %s flags %.6x, tcd = %p\n", + newCmd,methodName,Tcl_Command_flags(newCmd), tcd); + } + result = ListMethodName(interp, object, cl == NULL, methodName); } @@ -11934,6 +12009,7 @@ /* special setter for init commands */ if (paramPtr->flags & (XOTCL_ARG_INITCMD|XOTCL_ARG_METHOD)) { + if (paramPtr->flags & XOTCL_ARG_INITCMD) { result = Tcl_EvalObjEx(interp, newValue, TCL_EVAL_DIRECT); } else { @@ -11965,6 +12041,7 @@ /* call residualargs only, when we have varargs and left over arguments */ if (pc.varArgs && remainingArgsc > 0) { + result = callMethod((ClientData) obj, interp, XOTclGlobalObjects[XOTE_RESIDUALARGS], remainingArgsc+2, pc.full_objv + i-1, 0); if (result != TCL_OK) { Index: generic/xotcl.h =================================================================== diff -u -r2f283277aff2bb9488419a4fbe2442a5b17546e5 -re61fc14f5c25172a1d1f93bea03be54a772fb4b5 --- generic/xotcl.h (.../xotcl.h) (revision 2f283277aff2bb9488419a4fbe2442a5b17546e5) +++ generic/xotcl.h (.../xotcl.h) (revision e61fc14f5c25172a1d1f93bea03be54a772fb4b5) @@ -76,6 +76,7 @@ #define CONFIGURE_ARGS_TRACE 1 #define TCL_STACK_ALLOC_TRACE 1 #define VAR_RESOLVER_TRACE 1 +#define DOT_CMD_RESOLVER_TRACE 1 */ /* some features Index: generic/xotclStack85.c =================================================================== diff -u -rf4cb2e4e7480820bada88c519980cfb0a4d3f1be -re61fc14f5c25172a1d1f93bea03be54a772fb4b5 --- generic/xotclStack85.c (.../xotclStack85.c) (revision f4cb2e4e7480820bada88c519980cfb0a4d3f1be) +++ generic/xotclStack85.c (.../xotclStack85.c) (revision e61fc14f5c25172a1d1f93bea03be54a772fb4b5) @@ -15,18 +15,31 @@ }*/ framePtr = (Tcl_CallFrame *)Tcl_Interp_framePtr(interp); for (; framePtr; framePtr = Tcl_CallFrame_callerPtr(framePtr)) { - XOTclCallStackContent *csc = Tcl_CallFrame_isProcCallFrame(framePtr) - & (FRAME_IS_XOTCL_METHOD|FRAME_IS_XOTCL_CMETHOD) ? + int frameFlags = Tcl_CallFrame_isProcCallFrame(framePtr); + XOTclCallStackContent *csc = + (frameFlags & (FRAME_IS_XOTCL_METHOD|FRAME_IS_XOTCL_CMETHOD)) ? ((XOTclCallStackContent *)Tcl_CallFrame_clientData(framePtr)) : NULL; - fprintf(stderr, "... var frame %p flags %.6x cd %p lvl %d frameType %d ns %p %s, %p %s %s\n", - framePtr, Tcl_CallFrame_isProcCallFrame(framePtr), + fprintf(stderr, "... var frame %p flags %.6x cd %p lvl %d ns %p %s ov %s %d", + framePtr, frameFlags, Tcl_CallFrame_clientData(framePtr), Tcl_CallFrame_level(framePtr), - csc ? csc->frameType : -1, Tcl_CallFrame_nsPtr(framePtr), Tcl_CallFrame_nsPtr(framePtr)->fullName, - csc ? csc->self : NULL, csc ? objectName(csc->self) : "", - Tcl_CallFrame_objc(framePtr) ? ObjStr(Tcl_CallFrame_objv(framePtr)[0]) : "(null)"); + Tcl_CallFrame_objc(framePtr) ? ObjStr(Tcl_CallFrame_objv(framePtr)[0]) : "(null)", + Tcl_CallFrame_objc(framePtr) ? Tcl_CallFrame_objc(framePtr) : -1); + if (csc) { + fprintf(stderr, " frameType %d %p %s\n", + csc ? csc->frameType : -1, + csc ? csc->self : NULL, + csc ? objectName(csc->self) : ""); + } else { + fprintf(stderr, " no csc"); + if (frameFlags & FRAME_IS_XOTCL_OBJECT) { + XOTclObject *object = (XOTclObject *)Tcl_CallFrame_clientData(framePtr); + fprintf(stderr, " obj %p %s", object, objectName(object)); + } + fprintf(stderr, "\n"); + } } } Index: tests/testx.xotcl =================================================================== diff -u -r7050a52ac53992d9a3aec12e48b0fa58a26449e6 -re61fc14f5c25172a1d1f93bea03be54a772fb4b5 --- tests/testx.xotcl (.../testx.xotcl) (revision 7050a52ac53992d9a3aec12e48b0fa58a26449e6) +++ tests/testx.xotcl (.../testx.xotcl) (revision e61fc14f5c25172a1d1f93bea03be54a772fb4b5) @@ -2840,6 +2840,7 @@ Class C C set w 3 + append ::recreateResult "+[C info vars]," append ::recreateResult "[C info instprocs] +" if {$i > 0} { Index: tests/varresolutiontest.xotcl =================================================================== diff -u -rf9807b1cea03590c9573b5a521760538d53ee90f -re61fc14f5c25172a1d1f93bea03be54a772fb4b5 --- tests/varresolutiontest.xotcl (.../varresolutiontest.xotcl) (revision f9807b1cea03590c9573b5a521760538d53ee90f) +++ tests/varresolutiontest.xotcl (.../varresolutiontest.xotcl) (revision e61fc14f5c25172a1d1f93bea03be54a772fb4b5) @@ -1,9 +1,8 @@ # testing var resolution for namespace-shadowed objects -package require XOTcl; xotcl::use xotcl1 +package require XOTcl; xotcl::use xotcl2 package require xotcl::test - proc ? {cmd expected {msg ""}} { set count 1 if {$msg ne ""} { @@ -15,13 +14,21 @@ $t run } +::xotcl::alias ::xotcl2::Object eval -objscope ::eval +::xotcl::alias ::xotcl2::Object array -objscope ::array +::xotcl::alias ::xotcl2::Object lappend -objscope ::lappend +::xotcl::alias ::xotcl2::Object incr -objscope ::incr +::xotcl::alias ::xotcl2::Object set -objscope ::set +::xotcl::alias ::xotcl2::Object unset -objscope ::unset + ########################################### # Basic tests for var resolution under # per-object namespaces ... ########################################### set ::globalVar 1 -Object o -requireNamespace +Object create o +o requireNamespace ? {o info vars} "" ? {info exists ::globalVar} 1 ? {set ::globalVar} 1 @@ -40,22 +47,24 @@ ########################################### # scopes ########################################### - -Object o -eval { - my requireNamespace - global z - my instvar y +Object create o +o requireNamespace +o eval { + # TODO: the next three lines don't seem to work as expected + #my requireNamespace + #global z + #::xotcl::importvar [self] y set x 1 - set y 2 - set z 3 + set .y 2 + set ::z 3 set [self]::X 4 } set ::o::Y 5 ? {info exists ::z} 1 ? {set ::z} 3 -? {lsort [o info vars]} {X Y y} -? {o exists x} 0 +? {lsort [o info vars]} {X Y x y} +? {o exists x} 1 ? {o exists y} 1 ? {o exists z} 0 ? {o exists X} 1 @@ -69,7 +78,8 @@ # mix & match namespace and object interfaces ########################################### -Object o -requireNamespace +Object create o +o requireNamespace o set x 1 ? {namespace eval ::o set x} 1 @@ -89,7 +99,8 @@ # array-specific tests ########################################### -Object o -requireNamespace +Object create o +o requireNamespace ? {o array exists a} 0 ? {namespace eval ::o array exists a} 0 @@ -113,8 +124,10 @@ # tests on namespace-qualified var names ########################################### -Object o -requireNamespace -Object o::oo -requireNamespace +Object create o +o requireNamespace +Object create o::oo +o::oo requireNamespace ? {::o set ::x 1} 1 ? {info exists ::x} [set ::x] @@ -142,7 +155,7 @@ # the tests below fail. We could consider # to require namespaces on the fly in the future -Object o +Object create o #? {::o set ::o::x 1} 1 #? {o exists x} [::o set ::o::x] #? {namespace eval ::o unset x} "" @@ -159,7 +172,7 @@ # tests for the compiled var resolver on Object ############################################### -Object o +Object create o o method foo {x} {set .y 2; return ${.x},${.y}} o method bar {} {return ${.x},${.y}} o set x 1 @@ -168,7 +181,7 @@ ? {o info vars} "x y" # recreate object, check var caching; # we have to recreate bar, so no problem -Object o +Object create o o set x 1 o method bar {} {return ${.x},${.y}} ? {catch {o bar}} "1" "compiled var y should not exist" @@ -248,7 +261,7 @@ ############################################### # tests for the var resolver ############################################### -Class C +Class create C C method bar0 {} {return ${.x}} C method bar1 {} {set a ${.x}; return [info exists .x],[info exists .y]} C method bar2 {} {return [info exists .x],[info exists .y]} @@ -270,12 +283,12 @@ ############################################### # first tests for the cmd resolver ############################################### -Class C +Class create C C method bar {args} { #puts stderr "[self] bar called with [list $args]" return $args } -C instforward test %self bar +C forward test %self bar C method foo {} { # this works lappend .r [.bar x 1] @@ -307,7 +320,7 @@ ::C create ::c namespace eval ::c {} ? {namespace exists ::c} 1 -? {::xotcl::Object isobject ::c} 1 +? {::xotcl::is ::c object} 1 ? {::c info hasnamespace} 0 ? {::c Set w 2; expr {[::c Set w] == $::w}} 0 @@ -318,4 +331,138 @@ ::c destroy ::C destroy unset ::w -unset ::tmpArray \ No newline at end of file +unset ::tmpArray + +################################################## +# Testing aliases for eval with and without flags +# +# -objscope, +# -nonleaf +# +# with a required namespace and without +################################################## + +::xotcl::alias ::xotcl2::Object eval -objscope ::eval +::xotcl::alias ::xotcl2::Object softeval -nonleaf ::eval +::xotcl::alias ::xotcl2::Object softeval2 ::eval + +Object create o { + set xxx 1 + set .x 1 +} +? {o exists x} 1 +? {o exists xxx} 0 + +o eval { + set aaa 1 + set .a 1 +} +? {o exists a} 1 +? {o exists aaa} 1 + +o softeval { + set bbb 1 + set .b 1 +} +? {o exists b} 1 +? {o exists bbb} 1 + +# softeval2 should not set variables +o softeval2 { + set zzz 1 + set .z 1 +} +? {o exists z} 0 +? {o exists zzz} 0 + +? {lsort [o info vars]} "a aaa b bbb x" + +o requireNamespace + +o eval { + set ccc 1 + set .c 1 +} +? {o exists c} 1 +? {o exists ccc} 1 + +o softeval { + set ddd 1 + set .d 1 +} +? {o exists d} 1 +? {o exists ddd} 1 + +# softeval2 should not set variables +o softeval2 { + set zzz 1 + set .z 1 +} +? {o exists z} 0 +? {o exists zzz} 0 +? {lsort [o info vars]} "a aaa b bbb c ccc d ddd x" + + +################################################## +# The same as above, but with some global vars. +# The global vars should not influence the behavior. +################################################## +foreach var {.x x xxx .a a aaa .b b bbb .c c ccc .d d ddd .z z zzz} {set $var 1} + +Object create o { + set xxx 1 + set .x 1 +} + +? {o exists x} 1 +# TODO: this should be +#? {o exists xxx} 0 +#? {lsort [o info vars]} "x" +? {o exists xxx} 1 +? {lsort [o info vars]} "x xxx" + +o eval { + set aaa 1 + set .a 1 +} +? {o exists a} 1 +? {o exists aaa} 1 + +o softeval { + set bbb 1 + set .b 1 +} +? {o exists b} 1 +? {o exists bbb} 1 + +# softeval2 should not set variables +o softeval2 { + set zzz 1 + set .z 1 +} +? {o exists z} 0 +? {o exists zzz} 0 + +o requireNamespace + +o eval { + set ccc 1 + set .c 1 +} +? {o exists c} 1 +? {o exists ccc} 1 + +o softeval { + set ddd 1 + set .d 1 +} +? {o exists d} 1 +? {o exists ddd} 1 + +# softeval2 should not set variables +o softeval2 { + set zzz 1 + set .z 1 +} +? {o exists z} 0 +? {o exists zzz} 0