NRE-enabled destructors! Also more generation of errorcodes.

2 files changed, 54 insertions, 17 deletions

diff --git a/ChangeLog b/ChangeLog
index 61a7efa..40b8a15 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -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;