summaryrefslogtreecommitdiffstats
path: root/generic
diff options
context:
space:
mode:
authordkf <donal.k.fellows@manchester.ac.uk>2008-07-16 22:08:59 (GMT)
committerdkf <donal.k.fellows@manchester.ac.uk>2008-07-16 22:08:59 (GMT)
commit50c3ec45e663031133f8f9024976f0d5501a3f46 (patch)
tree5b9a400f27bd9a63da7d8ee2cf2d277ed927df28 /generic
parent98c0b4df207d373b44cdb132ffa4f3404b245e57 (diff)
downloadtcl-50c3ec45e663031133f8f9024976f0d5501a3f46.zip
tcl-50c3ec45e663031133f8f9024976f0d5501a3f46.tar.gz
tcl-50c3ec45e663031133f8f9024976f0d5501a3f46.tar.bz2
NRE-aware TclOO.
Diffstat (limited to 'generic')
-rw-r--r--generic/tclOO.c136
-rw-r--r--generic/tclOOBasic.c21
-rw-r--r--generic/tclOOCall.c86
-rw-r--r--generic/tclOOInt.h11
-rw-r--r--generic/tclOOMethod.c40
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;
}