diff options
author | dkf <dkf@noemail.net> | 2008-07-16 22:08:59 (GMT) |
---|---|---|
committer | dkf <dkf@noemail.net> | 2008-07-16 22:08:59 (GMT) |
commit | bee0ad363e7fc22f7900fa3e8aa20cb9bf509118 (patch) | |
tree | 5b9a400f27bd9a63da7d8ee2cf2d277ed927df28 /generic/tclOO.c | |
parent | c1d69c0fae455a76a96c430c183f4b5ac1fae38d (diff) | |
download | tcl-bee0ad363e7fc22f7900fa3e8aa20cb9bf509118.zip tcl-bee0ad363e7fc22f7900fa3e8aa20cb9bf509118.tar.gz tcl-bee0ad363e7fc22f7900fa3e8aa20cb9bf509118.tar.bz2 |
NRE-aware TclOO.
FossilOrigin-Name: a8d83acd188df8a873518f5d731cf8cea8f0c668
Diffstat (limited to 'generic/tclOO.c')
-rw-r--r-- | generic/tclOO.c | 136 |
1 files changed, 126 insertions, 10 deletions
diff --git a/generic/tclOO.c b/generic/tclOO.c index 2b892af..176e90a 100644 --- a/generic/tclOO.c +++ b/generic/tclOO.c @@ -8,7 +8,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclOO.c,v 1.9 2008/06/19 21:29:03 dkf Exp $ + * RCS: @(#) $Id: tclOO.c,v 1.10 2008/07/16 22:09:00 dkf Exp $ */ #ifdef HAVE_CONFIG_H @@ -70,6 +70,10 @@ static int CloneClassMethod(Tcl_Interp *interp, Class *clsPtr, Method **newMPtrPtr); static int CloneObjectMethod(Tcl_Interp *interp, Object *oPtr, Method *mPtr, Tcl_Obj *namePtr); +static int FinalizeNext(ClientData data[], + Tcl_Interp *interp, int result); +static int FinalizeObjectCall(ClientData data[], + Tcl_Interp *interp, int result); static void InitFoundation(Tcl_Interp *interp); static void KillFoundation(ClientData clientData, Tcl_Interp *interp); @@ -82,9 +86,15 @@ static void ReleaseClassContents(Tcl_Interp *interp,Object *oPtr); static int PublicObjectCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv); +static int PublicNRObjectCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const *objv); static int PrivateObjectCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv); +static int PrivateNRObjectCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const *objv); /* * Methods in the oo::object and oo::class classes. First, we define a helper @@ -476,6 +486,7 @@ AllocObject( oPtr->command = Tcl_CreateObjCommand(interp, oPtr->namespacePtr->fullName, PublicObjectCmd, oPtr, NULL); } + ((Command *) oPtr->command)->nreProc = PublicNRObjectCmd; /* * Access the namespace command table directly when creating "my" to avoid @@ -494,6 +505,7 @@ AllocObject( cmdPtr->objClientData = oPtr; cmdPtr->proc = TclInvokeObjectCommand; cmdPtr->clientData = cmdPtr; + cmdPtr->nreProc = PrivateNRObjectCmd; Tcl_SetHashValue(cmdPtr->hPtr, cmdPtr); } @@ -558,7 +570,8 @@ ObjectRenamedTrace( contextPtr->callPtr->flags |= DESTRUCTOR; contextPtr->skip = 0; state = Tcl_SaveInterpState(interp, TCL_OK); - result = TclOOInvokeContext(interp, contextPtr, 0, NULL); + result = TclNR_CallObjProc(interp, TclOOInvokeContext, contextPtr, + 0, NULL); if (result != TCL_OK) { Tcl_BackgroundError(interp); } @@ -1243,7 +1256,8 @@ Tcl_NewObjectInstance( state = Tcl_SaveInterpState(interp, TCL_OK); contextPtr->callPtr->flags |= CONSTRUCTOR; contextPtr->skip = skip; - result = TclOOInvokeContext(interp, contextPtr, objc, objv); + result = TclNR_CallObjProc(interp, TclOOInvokeContext, contextPtr, + objc, objv); TclOODeleteContext(contextPtr); DelRef(oPtr); if (result != TCL_OK) { @@ -1779,6 +1793,16 @@ PublicObjectCmd( int objc, Tcl_Obj *const *objv) { + return TclNR_CallObjProc(interp, PublicNRObjectCmd, clientData,objc,objv); +} + +static int +PublicNRObjectCmd( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const *objv) +{ return TclOOObjectCmdCore(clientData, interp, objc, objv, PUBLIC_METHOD, NULL); } @@ -1790,6 +1814,16 @@ PrivateObjectCmd( int objc, Tcl_Obj *const *objv) { + return TclNR_CallObjProc(interp, PrivateNRObjectCmd,clientData,objc,objv); +} + +static int +PrivateNRObjectCmd( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const *objv) +{ return TclOOObjectCmdCore(clientData, interp, objc, objv, 0, NULL); } @@ -1902,8 +1936,8 @@ TclOOObjectCmdCore( result = TCL_ERROR; Tcl_SetResult(interp, "no valid method implementation", TCL_STATIC); - AddRef(oPtr); /* Just to balance. */ - goto disposeChain; + TclOODeleteContext(contextPtr); + return TCL_ERROR; } } @@ -1913,13 +1947,23 @@ TclOOObjectCmdCore( */ AddRef(oPtr); - result = TclOOInvokeContext(interp, contextPtr, objc, objv); + TclNR_AddCallback(interp, FinalizeObjectCall, contextPtr,oPtr, NULL,NULL); + return TclOOInvokeContext(contextPtr, interp, objc, objv); +} + +static int +FinalizeObjectCall( + ClientData data[], + Tcl_Interp *interp, + int result) +{ + register CallContext *contextPtr = data[0]; + register Object *oPtr = data[1]; /* * Dispose of the call chain and drop the lock on the object's structure. */ - disposeChain: TclOODeleteContext(contextPtr); DelRef(oPtr); return result; @@ -1928,11 +1972,12 @@ TclOOObjectCmdCore( /* * ---------------------------------------------------------------------- * - * Tcl_ObjectContextInvokeNext -- + * Tcl_ObjectContextInvokeNext, TclNRObjectContextInvokeNext -- * * Invokes the next stage of the call chain described in an object * context. This is the core of the implementation of the [next] command. - * Does not do management of the call-frame stack. + * Does not do management of the call-frame stack. Available in public + * (standard API) and private (NRE-aware) forms. * * ---------------------------------------------------------------------- */ @@ -1987,7 +2032,8 @@ Tcl_ObjectContextInvokeNext( * Invoke the (advanced) method call context in the caller context. */ - result = TclOOInvokeContext(interp, contextPtr, objc, objv); + result = TclNR_CallObjProc(interp, TclOOInvokeContext, contextPtr, objc, + objv); /* * Restore the call chain context index as we've finished the inner invoke @@ -1999,6 +2045,76 @@ Tcl_ObjectContextInvokeNext( return result; } + +int +TclNRObjectContextInvokeNext( + Tcl_Interp *interp, + Tcl_ObjectContext context, + int objc, + Tcl_Obj *const *objv, + int skip) +{ + register CallContext *contextPtr = (CallContext *) context; + + if (contextPtr->index+1 >= contextPtr->callPtr->numChain) { + /* + * We're at the end of the chain; generate an error message. + */ + + const char *methodType; + + if (contextPtr->callPtr->flags & CONSTRUCTOR) { + methodType = "constructor"; + } else if (contextPtr->callPtr->flags & DESTRUCTOR) { + methodType = "destructor"; + } else { + methodType = "method"; + } + + Tcl_AppendResult(interp, "no next ", methodType, " implementation", + NULL); + return TCL_ERROR; + } + + /* + * Advance to the next method implementation in the chain in the method + * call context while we process the body. However, need to adjust the + * argument-skip control because we're guaranteed to have a single prefix + * arg (i.e., 'next') and not the variable amount that can happen because + * method invokations (i.e., '$obj meth' and 'my meth'), constructors + * (i.e., '$cls new' and '$cls create obj') and destructors (no args at + * all) come through the same code. + */ + + TclNR_AddCallback(interp, FinalizeNext, contextPtr, + INT2PTR(contextPtr->index), INT2PTR(contextPtr->skip), NULL); + contextPtr->index++; + contextPtr->skip = skip; + + /* + * Invoke the (advanced) method call context in the caller context. + */ + + return TclOOInvokeContext(contextPtr, interp, objc, objv); +} + +static int +FinalizeNext( + ClientData data[], + Tcl_Interp *interp, + int result) +{ + CallContext *contextPtr = data[0]; + + /* + * Restore the call chain context index as we've finished the inner invoke + * and want to operate in the outer context again. + */ + + contextPtr->index = PTR2INT(data[1]); + contextPtr->skip = PTR2INT(data[2]); + return result; +} /* * ---------------------------------------------------------------------- |