diff options
| -rw-r--r-- | ChangeLog | 7 | ||||
| -rw-r--r-- | generic/tclOO.c | 151 | ||||
| -rw-r--r-- | generic/tclOOBasic.c | 83 | ||||
| -rw-r--r-- | generic/tclOOInt.h | 7 |
4 files changed, 211 insertions, 37 deletions
@@ -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); |