summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authordkf <donal.k.fellows@manchester.ac.uk>2008-07-18 17:23:56 (GMT)
committerdkf <donal.k.fellows@manchester.ac.uk>2008-07-18 17:23:56 (GMT)
commit7c31170f9b9f73628665a5656daddd8002c771f7 (patch)
tree51d468120cb21c5f86ab5cacff83f3fe4c6ee77a
parenta0226c67f814c3d4a641687615bf4171ea749088 (diff)
downloadtcl-7c31170f9b9f73628665a5656daddd8002c771f7.zip
tcl-7c31170f9b9f73628665a5656daddd8002c771f7.tar.gz
tcl-7c31170f9b9f73628665a5656daddd8002c771f7.tar.bz2
NRE-enable the TclOO constructor system.
-rw-r--r--ChangeLog7
-rw-r--r--generic/tclOO.c151
-rw-r--r--generic/tclOOBasic.c83
-rw-r--r--generic/tclOOInt.h7
4 files changed, 211 insertions, 37 deletions
diff --git a/ChangeLog b/ChangeLog
index 02a578a..521fe711 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,10 @@
+2008-07-18 Donal K. Fellows <dkf@users.sf.net>
+
+ * generic/tclOO.c (TclNRNewObjectInstance, FinalizeAlloc):
+ * generic/tclOOBasic.c (TclOO_Class_Create, TclOO_Class_CreateNs)
+ (TclOO_Class_New, FinalizeConstruction, AddConstructionFinalizer):
+ NRE-enablement of the class construction methods.
+
2008-07-18 Miguel Sofer <msofer@users.sf.net>
* tests/NRE.test: Added basic tests for deep TclOO calls
diff --git a/generic/tclOO.c b/generic/tclOO.c
index dbf85ea..7280172 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.11 2008/07/18 13:46:46 msofer Exp $
+ * RCS: @(#) $Id: tclOO.c,v 1.12 2008/07/18 17:23:56 dkf Exp $
*/
#ifdef HAVE_CONFIG_H
@@ -70,6 +70,8 @@ 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 FinalizeAlloc(ClientData data[],
+ Tcl_Interp *interp, int result);
static int FinalizeNext(ClientData data[],
Tcl_Interp *interp, int result);
static int FinalizeObjectCall(ClientData data[],
@@ -1271,6 +1273,118 @@ Tcl_NewObjectInstance(
return (Tcl_Object) oPtr;
}
+
+int
+TclNRNewObjectInstance(
+ Tcl_Interp *interp, /* Interpreter context. */
+ Tcl_Class cls, /* Class to create an instance of. */
+ const char *nameStr, /* Name of object to create, or NULL to ask
+ * the code to pick its own unique name. */
+ const char *nsNameStr, /* Name of namespace to create inside object,
+ * or NULL to ask the code to pick its own
+ * unique name. */
+ int objc, /* Number of arguments. Negative value means
+ * do not call constructor. */
+ Tcl_Obj *const *objv, /* Argument list. */
+ int skip, /* Number of arguments to _not_ pass to the
+ * constructor. */
+ Tcl_Object *objectPtr) /* Place to write the object reference upon
+ * successful allocation. */
+{
+ register Class *classPtr = (Class *) cls;
+ Foundation *fPtr = GetFoundation(interp);
+ CallContext *contextPtr;
+ Tcl_InterpState state;
+ Object *oPtr;
+
+ /*
+ * Check if we're going to create an object over an existing command;
+ * that's not allowed.
+ */
+
+ if (nameStr && Tcl_FindCommand(interp, nameStr, NULL, 0)) {
+ Tcl_AppendResult(interp, "can't create object \"", nameStr,
+ "\": command already exists with that name", NULL);
+ return TCL_ERROR;
+ }
+
+ /*
+ * Create the object.
+ */
+
+ oPtr = AllocObject(interp, nameStr, nsNameStr);
+ oPtr->selfCls = classPtr;
+ TclOOAddToInstances(oPtr, classPtr);
+
+ /*
+ * Check to see if we're really creating a class. If so, allocate the
+ * class structure as well.
+ */
+
+ if (TclOOIsReachable(fPtr->classCls, classPtr)) {
+ /*
+ * Is a class, so attach a class structure. Note that the AllocClass
+ * function splices the structure into the object, so we don't have
+ * to. Once that's done, we need to repatch the object to have the
+ * right class since AllocClass interferes with that.
+ */
+
+ AllocClass(interp, oPtr);
+ oPtr->selfCls = classPtr;
+ TclOOAddToSubclasses(oPtr->classPtr, fPtr->objectCls);
+ }
+
+ /*
+ * Run constructors, except when objc < 0 (a special flag case used for
+ * object cloning only). If there aren't any constructors, we do nothing.
+ */
+
+ if (objc < 0) {
+ *objectPtr = (Tcl_Object) oPtr;
+ return TCL_OK;
+ }
+ contextPtr = TclOOGetCallContext(oPtr,NULL,CONSTRUCTOR);
+ if (contextPtr == NULL) {
+ *objectPtr = (Tcl_Object) oPtr;
+ return TCL_OK;
+ }
+
+ AddRef(oPtr);
+ state = Tcl_SaveInterpState(interp, TCL_OK);
+ contextPtr->callPtr->flags |= CONSTRUCTOR;
+ contextPtr->skip = skip;
+
+ /*
+ * Fire off the constructors non-recursively.
+ */
+
+ Tcl_NRAddCallback(interp, FinalizeAlloc, contextPtr, oPtr, state,
+ objectPtr);
+ return TclOOInvokeContext(contextPtr, interp, objc, objv);
+}
+
+static int
+FinalizeAlloc(
+ ClientData data[],
+ Tcl_Interp *interp,
+ int result)
+{
+ CallContext *contextPtr = data[0];
+ Object *oPtr = data[1];
+ Tcl_InterpState state = data[2];
+ Tcl_Object *objectPtr = data[3];
+
+ TclOODeleteContext(contextPtr);
+ DelRef(oPtr);
+ if (result != TCL_OK) {
+ Tcl_DiscardInterpState(state);
+ Tcl_DeleteCommandFromToken(interp, oPtr->command);
+ return TCL_ERROR;
+ }
+ Tcl_RestoreInterpState(interp, state);
+ *objectPtr = (Tcl_Object) oPtr;
+ return TCL_OK;
+}
/*
* ----------------------------------------------------------------------
@@ -1776,12 +1890,12 @@ Tcl_ObjectSetMetadata(
/*
* ----------------------------------------------------------------------
*
- * PublicObjectCmd, PrivateObjectCmd, TclOOInvokeObject, TclOOObjectCmdCore --
+ * PublicObjectCmd, PrivateObjectCmd, TclOOInvokeObject --
*
* Main entry point for object invokations. The Public* and Private*
- * wrapper functions are just thin wrappers round the main
- * TclOOObjectCmdCore function that does call chain creation, management
- * and invokation.
+ * wrapper functions (implementations of both object instance commands
+ * and [my]) are just thin wrappers round the main TclOOObjectCmdCore
+ * function. Note that the core is function is NRE-aware.
*
* ----------------------------------------------------------------------
*/
@@ -1857,6 +1971,18 @@ TclOOInvokeObject(
(Class *) startCls);
}
}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * TclOOObjectCmdCore, FinalizeObjectCall --
+ *
+ * Main function for object invokations. Does call chain creation,
+ * management and invokation. The function FinalizeObjectCall exists to
+ * clean up after the non-recursive processing of TclOOObjectCmdCore.
+ *
+ * ----------------------------------------------------------------------
+ */
int
TclOOObjectCmdCore(
@@ -1922,13 +2048,15 @@ TclOOObjectCmdCore(
*/
if (startCls != NULL) {
- while (contextPtr->index < contextPtr->callPtr->numChain) {
+ for (; contextPtr->index < contextPtr->callPtr->numChain;
+ contextPtr->index++) {
register struct MInvoke *miPtr =
&contextPtr->callPtr->chain[contextPtr->index];
- if (miPtr->isFilter || miPtr->mPtr->declaringClassPtr!=startCls) {
- contextPtr->index++;
- } else {
+ if (miPtr->isFilter) {
+ continue;
+ }
+ if (miPtr->mPtr->declaringClassPtr == startCls) {
break;
}
}
@@ -1972,12 +2100,13 @@ FinalizeObjectCall(
/*
* ----------------------------------------------------------------------
*
- * Tcl_ObjectContextInvokeNext, TclNRObjectContextInvokeNext --
+ * Tcl_ObjectContextInvokeNext, TclNRObjectContextInvokeNext, FinalizeNext --
*
* 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. Available in public
- * (standard API) and private (NRE-aware) forms.
+ * (standard API) and private (NRE-aware) forms. FinalizeNext is a
+ * private function used to clean up in the NRE case.
*
* ----------------------------------------------------------------------
*/
diff --git a/generic/tclOOBasic.c b/generic/tclOOBasic.c
index 2951cc8..cb717ee 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.5 2008/07/18 13:46:46 msofer Exp $
+ * RCS: @(#) $Id: tclOOBasic.c,v 1.6 2008/07/18 17:23:57 dkf Exp $
*/
#ifdef HAVE_CONFIG_H
@@ -17,7 +17,11 @@
#endif
#include "tclInt.h"
#include "tclOOInt.h"
+#include "tclNRE.h"
+static inline Tcl_Object *AddConstructionFinalizer(Tcl_Interp *interp);
+static int FinalizeConstruction(ClientData data[],
+ Tcl_Interp *interp, int result);
static int FinalizeEval(ClientData data[],
Tcl_Interp *interp, int result);
static int RestoreFrame(ClientData data[],
@@ -26,6 +30,50 @@ static int RestoreFrame(ClientData data[],
/*
* ----------------------------------------------------------------------
*
+ * AddCreateCallback, FinalizeConstruction --
+ *
+ * Special version of Tcl_NRAddCallback that allows the caller to splice
+ * the object created later on. Always calls FinalizeConstruction, which
+ * converts the object into its name and stores that in the interpreter
+ * result. This is shared by all the construction methods (create,
+ * createWithNamespace, new).
+ *
+ * Note that this is the only code in this file (or, indeed, the whole of
+ * TclOO) that uses tclNRE.h; it is the only code that does non-standard
+ * poking in the NRE guts.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static inline Tcl_Object *
+AddConstructionFinalizer(
+ Tcl_Interp *interp)
+{
+ TEOV_record *recordPtr;
+
+ Tcl_NRAddCallback(interp, FinalizeConstruction, NULL, NULL, NULL, NULL);
+ recordPtr = TOP_RECORD(interp);
+ return (Tcl_Object *) &recordPtr->callbackPtr->data[0];
+}
+
+static int
+FinalizeConstruction(
+ ClientData data[],
+ Tcl_Interp *interp,
+ int result)
+{
+ Object *oPtr = data[0];
+
+ if (result != TCL_OK) {
+ return result;
+ }
+ Tcl_SetObjResult(interp, TclOOObjectName(interp, oPtr));
+ return TCL_OK;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
* TclOO_Class_Create --
*
* Implementation for oo::class->create method.
@@ -43,7 +91,6 @@ TclOO_Class_Create(
Tcl_Obj *const *objv) /* The actual arguments. */
{
Object *oPtr = (Object *) Tcl_ObjectContextObject(context);
- Tcl_Object newObject;
const char *objName;
int len;
@@ -80,14 +127,10 @@ TclOO_Class_Create(
* Make the object and return its name.
*/
- newObject = Tcl_NewObjectInstance(interp, (Tcl_Class) oPtr->classPtr,
+ return TclNRNewObjectInstance(interp, (Tcl_Class) oPtr->classPtr,
objName, NULL, objc, objv,
- Tcl_ObjectContextSkippedArgs(context)+1);
- if (newObject == NULL) {
- return TCL_ERROR;
- }
- Tcl_SetObjResult(interp, TclOOObjectName(interp, (Object *) newObject));
- return TCL_OK;
+ Tcl_ObjectContextSkippedArgs(context)+1,
+ AddConstructionFinalizer(interp));
}
/*
@@ -110,7 +153,6 @@ TclOO_Class_CreateNs(
Tcl_Obj *const *objv) /* The actual arguments. */
{
Object *oPtr = (Object *) Tcl_ObjectContextObject(context);
- Tcl_Object newObject;
const char *objName, *nsName;
int len;
@@ -153,14 +195,10 @@ TclOO_Class_CreateNs(
* Make the object and return its name.
*/
- newObject = Tcl_NewObjectInstance(interp, (Tcl_Class) oPtr->classPtr,
+ return TclNRNewObjectInstance(interp, (Tcl_Class) oPtr->classPtr,
objName, nsName, objc, objv,
- Tcl_ObjectContextSkippedArgs(context)+2);
- if (newObject == NULL) {
- return TCL_ERROR;
- }
- Tcl_SetObjResult(interp, TclOOObjectName(interp, (Object *) newObject));
- return TCL_OK;
+ Tcl_ObjectContextSkippedArgs(context)+2,
+ AddConstructionFinalizer(interp));
}
/*
@@ -183,7 +221,6 @@ TclOO_Class_New(
Tcl_Obj *const *objv) /* The actual arguments. */
{
Object *oPtr = (Object *) Tcl_ObjectContextObject(context);
- Tcl_Object newObject;
/*
* Sanity check; should not be possible to invoke this method on a
@@ -202,13 +239,9 @@ TclOO_Class_New(
* Make the object and return its name.
*/
- newObject = Tcl_NewObjectInstance(interp, (Tcl_Class) oPtr->classPtr,
- NULL, NULL, objc, objv, Tcl_ObjectContextSkippedArgs(context));
- if (newObject == NULL) {
- return TCL_ERROR;
- }
- Tcl_SetObjResult(interp, TclOOObjectName(interp, (Object *) newObject));
- return TCL_OK;
+ return TclNRNewObjectInstance(interp, (Tcl_Class) oPtr->classPtr,
+ NULL, NULL, objc, objv, Tcl_ObjectContextSkippedArgs(context),
+ AddConstructionFinalizer(interp));
}
/*
diff --git a/generic/tclOOInt.h b/generic/tclOOInt.h
index 569ac2f..66dfca5 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.3 2008/07/16 22:09:02 dkf Exp $
+ * RCS: @(#) $Id: tclOOInt.h,v 1.4 2008/07/18 17:23:57 dkf Exp $
*/
#include <tclInt.h>
@@ -478,6 +478,11 @@ MODULE_SCOPE int TclOO_Object_VarName(ClientData clientData,
MODULE_SCOPE void TclOOAddToInstances(Object *oPtr, Class *clsPtr);
MODULE_SCOPE void TclOOAddToMixinSubs(Class *subPtr, Class *mixinPtr);
MODULE_SCOPE void TclOOAddToSubclasses(Class *subPtr, Class *superPtr);
+MODULE_SCOPE int TclNRNewObjectInstance(Tcl_Interp *interp,
+ Tcl_Class cls, const char *nameStr,
+ const char *nsNameStr, int objc,
+ Tcl_Obj *const *objv, int skip,
+ Tcl_Object *objectPtr);
MODULE_SCOPE void TclOODeleteChain(CallChain *callPtr);
MODULE_SCOPE void TclOODeleteChainCache(Tcl_HashTable *tablePtr);
MODULE_SCOPE void TclOODeleteContext(CallContext *contextPtr);