diff options
| -rw-r--r-- | ChangeLog | 5 | ||||
| -rw-r--r-- | generic/tclOOBasic.c | 66 |
2 files changed, 54 insertions, 17 deletions
@@ -1,5 +1,10 @@ 2010-02-05 Donal K. Fellows <dkf@users.sf.net> + * generic/tclOOBasic.c (TclOO_Object_Destroy): Rewrote to be NRE-aware + when calling destructors. Note that there is no guarantee that + destructors will always be called in an NRE context; that's a feature + of the 'destroy' method only. + * generic/tclEncoding.c: Add 'const' to many function-internal vars that are never pointing to things that are written to. diff --git a/generic/tclOOBasic.c b/generic/tclOOBasic.c index 2c42fe9..b26061e 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.23 2010/02/02 09:13:45 dkf Exp $ + * RCS: @(#) $Id: tclOOBasic.c,v 1.24 2010/02/05 13:41:33 dkf Exp $ */ #ifdef HAVE_CONFIG_H @@ -19,6 +19,8 @@ #include "tclOOInt.h" static inline Tcl_Object *AddConstructionFinalizer(Tcl_Interp *interp); +static int AfterNRDestructor(ClientData data[], + Tcl_Interp *interp, int result); static int FinalizeConstruction(ClientData data[], Tcl_Interp *interp, int result); static int FinalizeEval(ClientData data[], @@ -116,6 +118,7 @@ TclOO_Class_Create( objv[Tcl_ObjectContextSkippedArgs(context)], &len); if (len == 0) { Tcl_AppendResult(interp, "object name must not be empty", NULL); + Tcl_SetErrorCode(interp, "TCL", "OO", "EMPTY_NAME", NULL); return TCL_ERROR; } @@ -178,12 +181,14 @@ TclOO_Class_CreateNs( objv[Tcl_ObjectContextSkippedArgs(context)], &len); if (len == 0) { Tcl_AppendResult(interp, "object name must not be empty", NULL); + Tcl_SetErrorCode(interp, "TCL", "OO", "EMPTY_NAME", NULL); return TCL_ERROR; } nsName = Tcl_GetStringFromObj( objv[Tcl_ObjectContextSkippedArgs(context)+1], &len); if (len == 0) { Tcl_AppendResult(interp, "namespace name must not be empty", NULL); + Tcl_SetErrorCode(interp, "TCL", "OO", "EMPTY_NAME", NULL); return TCL_ERROR; } @@ -260,30 +265,44 @@ TclOO_Object_Destroy( Tcl_Obj *const *objv) /* The actual arguments. */ { Object *oPtr = (Object *) Tcl_ObjectContextObject(context); - int result = TCL_OK; + CallContext *contextPtr; if (objc != Tcl_ObjectContextSkippedArgs(context)) { Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv, NULL); return TCL_ERROR; } - AddRef(oPtr); if (!(oPtr->flags & DESTRUCTOR_CALLED)) { - CallContext *contextPtr = - TclOOGetCallContext(oPtr, NULL, DESTRUCTOR, NULL); - oPtr->flags |= DESTRUCTOR_CALLED; + contextPtr = TclOOGetCallContext(oPtr, NULL, DESTRUCTOR, NULL); if (contextPtr != NULL) { contextPtr->callPtr->flags |= DESTRUCTOR; contextPtr->skip = 0; - result = Tcl_NRCallObjProc(interp, TclOOInvokeContext, - contextPtr, 0, NULL); - TclOODeleteContext(contextPtr); + AddRef(oPtr); + TclNRAddCallback(interp, AfterNRDestructor, oPtr, contextPtr, + NULL, NULL); + return TclOOInvokeContext(contextPtr, interp, 0, NULL); } } if (oPtr->command) { Tcl_DeleteCommandFromToken(interp, oPtr->command); } + return TCL_OK; +} + +static int +AfterNRDestructor( + ClientData data[], + Tcl_Interp *interp, + int result) +{ + Object *oPtr = data[0]; + CallContext *contextPtr = data[1]; + + TclOODeleteContext(contextPtr); + if (oPtr->command) { + Tcl_DeleteCommandFromToken(interp, oPtr->command); + } DelRef(oPtr); return result; } @@ -371,18 +390,17 @@ FinalizeEval( { if (result == TCL_ERROR) { Object *oPtr = data[0]; + const char *namePtr; if (oPtr) { - Tcl_Obj *objnameObj = TclOOObjectName(interp, oPtr); - - Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( - "\n (in \"%s eval\" script line %d)", - TclGetString(objnameObj), Tcl_GetErrorLine(interp))); + namePtr = TclGetString(TclOOObjectName(interp, oPtr)); } else { - Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( - "\n (in \"my eval\" script line %d)", - Tcl_GetErrorLine(interp))); + namePtr = "my"; } + + Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( + "\n (in \"%s eval\" script line %d)", + namePtr, Tcl_GetErrorLine(interp))); } /* @@ -443,6 +461,8 @@ TclOO_Object_Unknown( } else { Tcl_AppendResult(interp, "\" has no methods", NULL); } + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD", + TclGetString(objv[skip]), NULL); return TCL_ERROR; } @@ -459,6 +479,8 @@ TclOO_Object_Unknown( } Tcl_AppendResult(interp, methodNames[i], NULL); ckfree((char *) methodNames); + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD", + TclGetString(objv[skip]), NULL); return TCL_ERROR; } @@ -514,6 +536,7 @@ TclOO_Object_LinkVar( if (strstr(varName, "::") != NULL) { Tcl_AppendResult(interp, "variable name \"", varName, "\" illegal: must not contain namespace separator", NULL); + Tcl_SetErrorCode(interp, "TCL", "UPVAR", "INVERTED", NULL); return TCL_ERROR; } @@ -542,6 +565,7 @@ TclOO_Object_LinkVar( TclVarErrMsg(interp, varName, NULL, "define", "name refers to an element in an array"); + Tcl_SetErrorCode(interp, "TCL", "UPVAR", "LOCAL_ELEMENT", NULL); return TCL_ERROR; } @@ -621,6 +645,8 @@ TclOO_Object_VarName( } if (varPtr == NULL) { + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "VARIABLE", + TclGetString(objv[objc-1]), NULL); return TCL_ERROR; } @@ -684,6 +710,7 @@ TclOONextObjCmd( if (framePtr == NULL || !(framePtr->isProcCallFrame & FRAME_IS_METHOD)) { Tcl_AppendResult(interp, TclGetString(objv[0]), " may only be called from inside a method", NULL); + Tcl_SetErrorCode(interp, "TCL", "OO", "CONTEXT_REQUIRED", NULL); return TCL_ERROR; } context = framePtr->clientData; @@ -751,6 +778,7 @@ TclOOSelfObjCmd( if (framePtr == NULL || !(framePtr->isProcCallFrame & FRAME_IS_METHOD)) { Tcl_AppendResult(interp, TclGetString(objv[0]), " may only be called from inside a method", NULL); + Tcl_SetErrorCode(interp, "TCL", "OO", "CONTEXT_REQUIRED", NULL); return TCL_ERROR; } @@ -784,6 +812,7 @@ TclOOSelfObjCmd( if (clsPtr == NULL) { Tcl_AppendResult(interp, "method not defined by a class", NULL); + Tcl_SetErrorCode(interp, "TCL", "OO", "UNMATCHED_CONTEXT", NULL); return TCL_ERROR; } @@ -803,6 +832,7 @@ TclOOSelfObjCmd( case SELF_FILTER: if (!CurrentlyInvoked(contextPtr).isFilter) { Tcl_AppendResult(interp, "not inside a filtering context", NULL); + Tcl_SetErrorCode(interp, "TCL", "OO", "UNMATCHED_CONTEXT", NULL); return TCL_ERROR; } else { register struct MInvoke *miPtr = &CurrentlyInvoked(contextPtr); @@ -828,6 +858,7 @@ TclOOSelfObjCmd( if ((framePtr->callerVarPtr == NULL) || !(framePtr->callerVarPtr->isProcCallFrame & FRAME_IS_METHOD)){ Tcl_AppendResult(interp, "caller is not an object", NULL); + Tcl_SetErrorCode(interp, "TCL", "OO", "CONTEXT_REQUIRED", NULL); return TCL_ERROR; } else { CallContext *callerPtr = framePtr->callerVarPtr->clientData; @@ -894,6 +925,7 @@ TclOOSelfObjCmd( case SELF_TARGET: if (!CurrentlyInvoked(contextPtr).isFilter) { Tcl_AppendResult(interp, "not inside a filtering context", NULL); + Tcl_SetErrorCode(interp, "TCL", "OO", "UNMATCHED_CONTEXT", NULL); return TCL_ERROR; } else { Method *mPtr; |