NRE-aware TclOO.

5 files changed, 238 insertions, 56 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;
+}
 
 /*
  * ----------------------------------------------------------------------
diff --git a/generic/tclOOBasic.c b/generic/tclOOBasic.c
index 1cd07df..0af3a0b 100644
--- a/generic/tclOOBasic.c
+++ b/generic/tclOOBasic.c
@@ -9,7 +9,7 @@
  * See the file "license.terms" for information on usage and redistribution of
  * this file, and for a DISCLAIMER OF ALL WARRANTIES.
  *
- * RCS: @(#) $Id: tclOOBasic.c,v 1.1 2008/05/31 11:42:17 dkf Exp $
+ * RCS: @(#) $Id: tclOOBasic.c,v 1.2 2008/07/16 22:09:01 dkf Exp $
  */
 
 #ifdef HAVE_CONFIG_H
@@ -17,6 +17,9 @@
 #endif
 #include "tclInt.h"
 #include "tclOOInt.h"
+
+static int		RestoreFrame(ClientData data[],
+			    Tcl_Interp *interp, int result);
 
 /*
  * ----------------------------------------------------------------------
@@ -581,7 +584,6 @@ TclOONextObjCmd(
     Interp *iPtr = (Interp *) interp;
     CallFrame *framePtr = iPtr->varFramePtr;
     Tcl_ObjectContext context;
-    int result;
 
     /*
      * Start with sanity checks on the calling context to make sure that we
@@ -601,9 +603,20 @@ TclOONextObjCmd(
      * that this is like [uplevel 1] and not [eval].
      */
 
+    TclNR_AddCallback(interp, RestoreFrame, framePtr, NULL, NULL, NULL);
     iPtr->varFramePtr = framePtr->callerVarPtr;
-    result = Tcl_ObjectContextInvokeNext(interp, context, objc, objv, 1);
-    iPtr->varFramePtr = framePtr;
+    return TclNRObjectContextInvokeNext(interp, context, objc, objv, 1);
+}
+
+static int
+RestoreFrame(
+    ClientData data[],
+    Tcl_Interp *interp,
+    int result)
+{
+    Interp *iPtr = (Interp *) interp;
+
+    iPtr->varFramePtr = data[0];
     return result;
 }
 
diff --git a/generic/tclOOCall.c b/generic/tclOOCall.c
index bc90d09..162e7e2 100644
--- a/generic/tclOOCall.c
+++ b/generic/tclOOCall.c
@@ -9,7 +9,7 @@
  * See the file "license.terms" for information on usage and redistribution of
  * this file, and for a DISCLAIMER OF ALL WARRANTIES.
  *
- * RCS: @(#) $Id: tclOOCall.c,v 1.7 2008/06/19 20:57:23 dkf Exp $
+ * RCS: @(#) $Id: tclOOCall.c,v 1.8 2008/07/16 22:09:02 dkf Exp $
  */
 
 #ifdef HAVE_CONFIG_H
@@ -66,9 +66,15 @@ static void		AddSimpleClassChainToCallContext(Class *classPtr,
 			    Class *const filterDecl);
 static int		CmpStr(const void *ptr1, const void *ptr2);
 static void		DupMethodNameRep(Tcl_Obj *srcPtr, Tcl_Obj *dstPtr);
+static int		FinalizeMethodRefs(ClientData data[],
+			    Tcl_Interp *interp, int result);
 static void		FreeMethodNameRep(Tcl_Obj *objPtr);
 static inline int	IsStillValid(CallChain *callPtr, Object *oPtr,
 			    int flags, int reuseMask);
+static int		ResetFilterFlags(ClientData data[],
+			    Tcl_Interp *interp, int result);
+static int		SetFilterFlags(ClientData data[],
+			    Tcl_Interp *interp, int result);
 static inline void	StashCallChain(Tcl_Obj *objPtr, CallChain *callPtr);
 
 /*
@@ -231,20 +237,18 @@ FreeMethodNameRep(
 
 int
 TclOOInvokeContext(
-    Tcl_Interp *const interp,	/* Interpreter for error reporting, and many
+    ClientData clientData,	/* The method call context. */
+    Tcl_Interp *interp,		/* Interpreter for error reporting, and many
 				 * other sorts of context handling (e.g.,
 				 * commands, variables) depending on method
 				 * implementation. */
-    CallContext *const contextPtr,
-				/* The method call context. */
-    const int objc,		/* The number of arguments. */
-    Tcl_Obj *const *const objv)	/* The arguments as actually seen. */
+    int objc,			/* The number of arguments. */
+    Tcl_Obj *const objv[])	/* The arguments as actually seen. */
 {
+    register CallContext *const contextPtr = clientData;
     Method *const mPtr = contextPtr->callPtr->chain[contextPtr->index].mPtr;
-    const int isFirst = (contextPtr->index == 0);
     const int isFilter =
 	    contextPtr->callPtr->chain[contextPtr->index].isFilter;
-    int result, wasFilter;
 
     /*
      * If this is the first step along the chain, we preserve the method
@@ -252,7 +256,7 @@ TclOOInvokeContext(
      * feet.
      */
 
-    if (isFirst) {
+    if (contextPtr->index == 0) {
 	int i;
 
 	for (i=0 ; i<contextPtr->callPtr->numChain ; i++) {
@@ -267,13 +271,25 @@ TclOOInvokeContext(
 	if (contextPtr->callPtr->flags & OO_UNKNOWN_METHOD) {
 	    contextPtr->skip--;
 	}
+
+	/*
+	 * Add a callback to ensure that method references are dropped once
+	 * this call is finished.
+	 */
+
+	TclNR_AddCallback(interp, FinalizeMethodRefs, contextPtr, NULL, NULL,
+		NULL);
     }
 
     /*
      * Save whether we were in a filter and set up whether we are now.
      */
 
-    wasFilter = contextPtr->oPtr->flags & FILTER_HANDLING;
+    if (contextPtr->oPtr->flags & FILTER_HANDLING) {
+	TclNR_AddCallback(interp, SetFilterFlags, contextPtr, NULL,NULL,NULL);
+    } else {
+	TclNR_AddCallback(interp, ResetFilterFlags,contextPtr,NULL,NULL,NULL);
+    }
     if (isFilter || contextPtr->callPtr->flags & FILTER_HANDLING) {
 	contextPtr->oPtr->flags |= FILTER_HANDLING;
     } else {
@@ -284,25 +300,45 @@ TclOOInvokeContext(
      * Run the method implementation.
      */
 
-    result = mPtr->typePtr->callProc(mPtr->clientData, interp,
+    return mPtr->typePtr->callProc(mPtr->clientData, interp,
 	    (Tcl_ObjectContext) contextPtr, objc, objv);
+}
 
-    /*
-     * Restore the old filter-ness, release any locks on method
-     * implementations, and return the result code.
-     */
+static int
+SetFilterFlags(
+    ClientData data[],
+    Tcl_Interp *interp,
+    int result)
+{
+    CallContext *contextPtr = data[0];
 
-    if (wasFilter) {
-	contextPtr->oPtr->flags |= FILTER_HANDLING;
-    } else {
-	contextPtr->oPtr->flags &= ~FILTER_HANDLING;
-    }
-    if (isFirst) {
-	int i;
+    contextPtr->oPtr->flags |= FILTER_HANDLING;
+    return result;
+}
 
-	for (i=0 ; i<contextPtr->callPtr->numChain ; i++) {
-	    TclOODelMethodRef(contextPtr->callPtr->chain[i].mPtr);
-	}
+static int
+ResetFilterFlags(
+    ClientData data[],
+    Tcl_Interp *interp,
+    int result)
+{
+    CallContext *contextPtr = data[0];
+
+    contextPtr->oPtr->flags &= ~FILTER_HANDLING;
+    return result;
+}
+
+static int
+FinalizeMethodRefs(
+    ClientData data[],
+    Tcl_Interp *interp,
+    int result)
+{
+    CallContext *contextPtr = data[0];
+    int i;
+
+    for (i=0 ; i<contextPtr->callPtr->numChain ; i++) {
+	TclOODelMethodRef(contextPtr->callPtr->chain[i].mPtr);
     }
     return result;
 }
diff --git a/generic/tclOOInt.h b/generic/tclOOInt.h
index 580ea13..569ac2f 100644
--- a/generic/tclOOInt.h
+++ b/generic/tclOOInt.h
@@ -9,7 +9,7 @@
  * See the file "license.terms" for information on usage and redistribution of
  * this file, and for a DISCLAIMER OF ALL WARRANTIES.
  *
- * RCS: @(#) $Id: tclOOInt.h,v 1.2 2008/05/31 19:56:07 dkf Exp $
+ * RCS: @(#) $Id: tclOOInt.h,v 1.3 2008/07/16 22:09:02 dkf Exp $
  */
 
 #include <tclInt.h>
@@ -493,9 +493,12 @@ MODULE_SCOPE int	TclOOGetSortedMethodList(Object *oPtr, int flags,
 			    const char ***stringsPtr);
 MODULE_SCOPE int	TclOOInit(Tcl_Interp *interp);
 MODULE_SCOPE void	TclOOInitInfo(Tcl_Interp *interp);
-MODULE_SCOPE int	TclOOInvokeContext(Tcl_Interp *const interp,
-			    CallContext *const contextPtr, int const objc,
-			    Tcl_Obj *const *const objv);
+MODULE_SCOPE int	TclOOInvokeContext(ClientData clientData,
+			    Tcl_Interp *interp, int objc,
+			    Tcl_Obj *const objv[]);
+MODULE_SCOPE int	TclNRObjectContextInvokeNext(Tcl_Interp *interp,
+			    Tcl_ObjectContext context, int objc,
+			    Tcl_Obj *const *objv, int skip);
 MODULE_SCOPE void	TclOONewBasicMethod(Tcl_Interp *interp, Class *clsPtr,
 			    const DeclaredClassMethod *dcm);
 MODULE_SCOPE Tcl_Obj *	TclOOObjectName(Tcl_Interp *interp, Object *oPtr);
diff --git a/generic/tclOOMethod.c b/generic/tclOOMethod.c
index 053336e..62585b7 100644
--- a/generic/tclOOMethod.c
+++ b/generic/tclOOMethod.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: tclOOMethod.c,v 1.5 2008/06/01 08:11:07 dkf Exp $
+ * RCS: @(#) $Id: tclOOMethod.c,v 1.6 2008/07/16 22:09:02 dkf Exp $
  */
 
 #ifdef HAVE_CONFIG_H
@@ -55,6 +55,8 @@ static Tcl_Obj **	InitEnsembleRewrite(Tcl_Interp *interp, int objc,
 static int		InvokeProcedureMethod(ClientData clientData,
 			    Tcl_Interp *interp, Tcl_ObjectContext context,
 			    int objc, Tcl_Obj *const *objv);
+static int		FinalizePMCall(ClientData data[], Tcl_Interp *interp,
+			    int result);
 static int		PushMethodCallFrame(Tcl_Interp *interp,
 			    CallContext *contextPtr, ProcedureMethod *pmPtr,
 			    int objc, Tcl_Obj *const *objv,
@@ -633,7 +635,6 @@ InvokeProcedureMethod(
 {
     ProcedureMethod *pmPtr = clientData;
     int result;
-    register int skip;
     PMFrameData *fdPtr;		/* Important data that has to have a lifetime
 				 * matched by this function (or rather, by the
 				 * call frame's lifetime). */
@@ -643,7 +644,6 @@ InvokeProcedureMethod(
      */
 
     fdPtr = (PMFrameData *) TclStackAlloc(interp, sizeof(PMFrameData));
-    pmPtr->refCount++;
 
     /*
      * Create a call frame for this method.
@@ -652,8 +652,10 @@ InvokeProcedureMethod(
     result = PushMethodCallFrame(interp, (CallContext *) context, pmPtr,
 	    objc, objv, fdPtr);
     if (result != TCL_OK) {
-	goto done;
+	TclStackFree(interp, fdPtr);
+	return result;
     }
+    pmPtr->refCount++;
 
     /*
      * Give the pre-call callback a chance to do some setup and, possibly,
@@ -668,19 +670,32 @@ InvokeProcedureMethod(
 	if (isFinished || result != TCL_OK) {
 	    Tcl_PopCallFrame(interp);
 	    TclStackFree(interp, fdPtr->framePtr);
-	    goto done;
+	    if (--pmPtr->refCount < 1) {
+		DeleteProcedureMethodRecord(pmPtr);
+	    }
+	    TclStackFree(interp, fdPtr);
+	    return result;
 	}
     }
 
     /*
-     * Now invoke the body of the method. Note that we need to take special
-     * action when doing unknown processing to ensure that the missing method
-     * name is passed as an argument.
+     * Now invoke the body of the method.
      */
 
-    skip = Tcl_ObjectContextSkippedArgs(context);
-    result = TclObjInterpProcCore(interp, fdPtr->nameObj, skip,
-	    fdPtr->errProc);
+    TclNR_AddCallback(interp, FinalizePMCall, pmPtr, context, fdPtr, NULL);
+    return TclNRInterpProcCore(interp, fdPtr->nameObj,
+	    Tcl_ObjectContextSkippedArgs(context), fdPtr->errProc);
+}
+
+static int
+FinalizePMCall(
+    ClientData data[],
+    Tcl_Interp *interp,
+    int result)
+{
+    ProcedureMethod *pmPtr = data[0];
+    Tcl_ObjectContext context = data[1];
+    PMFrameData *fdPtr = data[2];
 
     /*
      * Give the post-call callback a chance to do some cleanup. Note that at
@@ -699,7 +714,6 @@ InvokeProcedureMethod(
      * sensitive when it comes to performance!
      */
 
-  done:
     if (--pmPtr->refCount < 1) {
 	DeleteProcedureMethodRecord(pmPtr);
     }
@@ -1136,7 +1150,7 @@ InvokeForwardMethod(
     argObjs = InitEnsembleRewrite(interp, objc, objv, skip,
 	    numPrefixes, prefixObjs, &len);
 
-    result = Tcl_EvalObjv(interp, len, argObjs, TCL_EVAL_INVOKE);
+    result = TclNR_EvalObjv(interp, len, argObjs, TCL_EVAL_INVOKE);
     TclStackFree(interp, argObjs);
     return result;
 }