diff options
Diffstat (limited to 'generic/tclOOBasic.c')
| -rw-r--r-- | generic/tclOOBasic.c | 120 |
1 files changed, 109 insertions, 11 deletions
diff --git a/generic/tclOOBasic.c b/generic/tclOOBasic.c index 0d38dcd..b286088 100644 --- a/generic/tclOOBasic.c +++ b/generic/tclOOBasic.c @@ -680,10 +680,11 @@ TclOO_Object_VarName( /* * ---------------------------------------------------------------------- * - * TclOONextObjCmd -- + * TclOONextObjCmd, TclOONextToObjCmd -- * - * Implementation of the [next] command. Note that this command is only - * ever to be used inside the body of a procedure-like method. + * Implementation of the [next] and [nextto] commands. Note that these + * commands are only ever to be used inside the body of a procedure-like + * method. * * ---------------------------------------------------------------------- */ @@ -723,6 +724,97 @@ TclOONextObjCmd( return TclNRObjectContextInvokeNext(interp, context, objc, objv, 1); } +int +TclOONextToObjCmd( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const *objv) +{ + Interp *iPtr = (Interp *) interp; + CallFrame *framePtr = iPtr->varFramePtr; + Class *classPtr; + CallContext *contextPtr; + int i; + Tcl_Object object; + + /* + * Start with sanity checks on the calling context to make sure that we + * are invoked from a suitable method context. If so, we can safely + * retrieve the handle to the object call context. + */ + + if (framePtr == NULL || !(framePtr->isProcCallFrame & FRAME_IS_METHOD)) { + Tcl_AppendResult(interp, TclGetString(objv[0]), + " may only be called from inside a method", NULL); + Tcl_SetErrorCode(interp, "TCL", "OO", "CONTEXT_REQUIRED", NULL); + return TCL_ERROR; + } + contextPtr = framePtr->clientData; + + /* + * Sanity check the arguments; we need the first one to refer to a class. + */ + + if (objc < 2) { + Tcl_WrongNumArgs(interp, 1, objv, "class ?arg...?"); + return TCL_ERROR; + } + object = Tcl_GetObjectFromObj(interp, objv[1]); + if (object == NULL) { + return TCL_ERROR; + } + classPtr = ((Object *)object)->classPtr; + if (classPtr == NULL) { + Tcl_AppendResult(interp, "\"", TclGetString(objv[1]), + "\" is not a class", NULL); + return TCL_ERROR; + } + + /* + * Search for an implementation of a method associated with the current + * call on the call chain past the point where we currently are. Do not + * allow jumping backwards! + */ + + for (i=contextPtr->index+1 ; i<contextPtr->callPtr->numChain ; i++) { + struct MInvoke *miPtr = contextPtr->callPtr->chain + i; + + if (!miPtr->isFilter && miPtr->mPtr->declaringClassPtr == classPtr) { + /* + * Invoke the (advanced) method call context in the caller + * context. Note that this is like [uplevel 1] and not [eval]. + */ + + TclNRAddCallback(interp, RestoreFrame, framePtr, contextPtr, + INT2PTR(contextPtr->index), NULL); + contextPtr->index = i-1; + iPtr->varFramePtr = framePtr->callerVarPtr; + return TclNRObjectContextInvokeNext(interp, + (Tcl_ObjectContext) contextPtr, objc, objv, 2); + } + } + + /* + * Generate an appropriate error message, depending on whether the value + * is on the chain but unreachable, or not on the chain at all. + */ + + for (i=contextPtr->index ; i>=0 ; i--) { + struct MInvoke *miPtr = contextPtr->callPtr->chain + i; + + if (!miPtr->isFilter && miPtr->mPtr->declaringClassPtr == classPtr) { + Tcl_AppendResult(interp, "method implementation by \"", + TclGetString(objv[1]), "\" not reachable from here", + NULL); + return TCL_ERROR; + } + } + Tcl_AppendResult(interp, "method has no non-filter implementation by \"", + TclGetString(objv[1]), "\"", NULL); + return TCL_ERROR; +} + static int RestoreFrame( ClientData data[], @@ -730,8 +822,12 @@ RestoreFrame( int result) { Interp *iPtr = (Interp *) interp; + CallContext *contextPtr = data[1]; iPtr->varFramePtr = data[0]; + if (contextPtr != NULL) { + contextPtr->index = PTR2INT(data[2]); + } return result; } @@ -754,16 +850,17 @@ TclOOSelfObjCmd( Tcl_Obj *const *objv) { static const char *const subcmds[] = { - "caller", "class", "filter", "method", "namespace", "next", "object", - "target", NULL + "call", "caller", "class", "filter", "method", "namespace", "next", + "object", "target", NULL }; enum SelfCmds { - SELF_CALLER, SELF_CLASS, SELF_FILTER, SELF_METHOD, SELF_NS, SELF_NEXT, - SELF_OBJECT, SELF_TARGET + SELF_CALL, SELF_CALLER, SELF_CLASS, SELF_FILTER, SELF_METHOD, SELF_NS, + SELF_NEXT, SELF_OBJECT, SELF_TARGET }; Interp *iPtr = (Interp *) interp; CallFrame *framePtr = iPtr->varFramePtr; CallContext *contextPtr; + Tcl_Obj *result[3]; int index; #define CurrentlyInvoked(contextPtr) \ @@ -834,7 +931,6 @@ TclOOSelfObjCmd( return TCL_ERROR; } else { register struct MInvoke *miPtr = &CurrentlyInvoked(contextPtr); - Tcl_Obj *result[3]; Object *oPtr; const char *type; @@ -862,7 +958,6 @@ TclOOSelfObjCmd( CallContext *callerPtr = framePtr->callerVarPtr->clientData; Method *mPtr = callerPtr->callPtr->chain[callerPtr->index].mPtr; Object *declarerPtr; - Tcl_Obj *result[3]; if (mPtr->declaringClassPtr != NULL) { declarerPtr = mPtr->declaringClassPtr->thisPtr; @@ -894,7 +989,6 @@ TclOOSelfObjCmd( Method *mPtr = contextPtr->callPtr->chain[contextPtr->index+1].mPtr; Object *declarerPtr; - Tcl_Obj *result[2]; if (mPtr->declaringClassPtr != NULL) { declarerPtr = mPtr->declaringClassPtr->thisPtr; @@ -928,7 +1022,6 @@ TclOOSelfObjCmd( } else { Method *mPtr; Object *declarerPtr; - Tcl_Obj *result[2]; int i; for (i=contextPtr->index ; i<contextPtr->callPtr->numChain ; i++){ @@ -957,6 +1050,11 @@ TclOOSelfObjCmd( Tcl_SetObjResult(interp, Tcl_NewListObj(2, result)); return TCL_OK; } + case SELF_CALL: + result[0] = TclOORenderCallChain(interp, contextPtr->callPtr); + result[1] = Tcl_NewIntObj(contextPtr->index); + Tcl_SetObjResult(interp, Tcl_NewListObj(2, result)); + return TCL_OK; } return TCL_ERROR; } |