More generation of error codes (TclOO miscellany).

6 files changed, 65 insertions, 13 deletions

diff --git a/ChangeLog b/ChangeLog
index 5f66c86..c516389 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,5 +1,9 @@
 2011-04-04  Donal K. Fellows  <dkf@users.sf.net>
 
+	* generic/tclOO.c, generic/tclOOBasic.c, generic/tclOODefineCmds.c
+	* generic/tclOOInfo.c, generic/tclOOMethod.c: More generation of
+	error codes (TclOO miscellany).
+
 	* generic/tclCmdAH.c, generic/tclCmdIL.c: More generation of error
 	codes (miscellaneous commands mostly already handled).
 
diff --git a/generic/tclOO.c b/generic/tclOO.c
index 047b4c5..6ae82d1 100644
--- a/generic/tclOO.c
+++ b/generic/tclOO.c
@@ -1401,6 +1401,7 @@ Tcl_NewObjectInstance(
 	    TCL_NAMESPACE_ONLY)) {
 	Tcl_AppendResult(interp, "can't create object \"", nameStr,
 		"\": command already exists with that name", NULL);
+	Tcl_SetErrorCode(interp, "TCL", "OO", "OVERWRITE_OBJECT", NULL);
 	return NULL;
     }
 
@@ -1459,6 +1460,7 @@ Tcl_NewObjectInstance(
 	    if (result != TCL_ERROR && (flags & OBJECT_DELETED)) {
 		Tcl_SetResult(interp, "object deleted in constructor",
 			TCL_STATIC);
+		Tcl_SetErrorCode(interp, "TCL", "OO", "STILLBORN", NULL);
 		result = TCL_ERROR;
 	    }
 	    TclOODeleteContext(contextPtr);
@@ -1514,6 +1516,7 @@ TclNRNewObjectInstance(
 	    TCL_NAMESPACE_ONLY)) {
 	Tcl_AppendResult(interp, "can't create object \"", nameStr,
 		"\": command already exists with that name", NULL);
+	Tcl_SetErrorCode(interp, "TCL", "OO", "OVERWRITE_OBJECT", NULL);
 	return TCL_ERROR;
     }
 
@@ -1592,6 +1595,7 @@ FinalizeAlloc(
 
     if (result != TCL_ERROR && (flags & OBJECT_DELETED)) {
 	Tcl_SetResult(interp, "object deleted in constructor", TCL_STATIC);
+	Tcl_SetErrorCode(interp, "TCL", "OO", "STILLBORN", NULL);
 	result = TCL_ERROR;
     }
     TclOODeleteContext(contextPtr);
@@ -1646,10 +1650,12 @@ Tcl_CopyObjectInstance(
     if (targetName == NULL && oPtr->classPtr != NULL) {
 	Tcl_AppendResult(interp, "must supply a name when copying a class",
 		NULL);
+	Tcl_SetErrorCode(interp, "TCL", "OO", "NO_COPY_TARGET", NULL);
 	return NULL;
     }
     if (oPtr->flags & ROOT_CLASS) {
 	Tcl_AppendResult(interp, "may not clone the class of classes", NULL);
+	Tcl_SetErrorCode(interp, "TCL", "OO", "CLONING_CLASS", NULL);
 	return NULL;
     }
 
@@ -2265,6 +2271,8 @@ TclOOObjectCmdCore(
 	    Tcl_AppendResult(interp, "impossible to invoke method \"",
 		    TclGetString(methodNamePtr),
 		    "\": no defined method or unknown method", NULL);
+	    Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD_MAPPED",
+		    TclGetString(methodNamePtr), NULL);
 	    return TCL_ERROR;
 	}
     } else {
@@ -2279,6 +2287,8 @@ TclOOObjectCmdCore(
 	    Tcl_AppendResult(interp, "impossible to invoke method \"",
 		    TclGetString(methodNamePtr),
 		    "\": no defined method or unknown method", NULL);
+	    Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD",
+		    TclGetString(methodNamePtr), NULL);
 	    return TCL_ERROR;
 	}
     }
@@ -2304,6 +2314,8 @@ TclOOObjectCmdCore(
 	if (contextPtr->index >= contextPtr->callPtr->numChain) {
 	    Tcl_SetResult(interp, "no valid method implementation",
 		    TCL_STATIC);
+	    Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD",
+		    TclGetString(methodNamePtr), NULL);
 	    TclOODeleteContext(contextPtr);
 	    return TCL_ERROR;
 	}
@@ -2384,6 +2396,7 @@ Tcl_ObjectContextInvokeNext(
 
 	Tcl_AppendResult(interp, "no next ", methodType, " implementation",
 		NULL);
+	Tcl_SetErrorCode(interp, "TCL", "OO", "NOTHING_NEXT", NULL);
 	return TCL_ERROR;
     }
 
@@ -2452,6 +2465,7 @@ TclNRObjectContextInvokeNext(
 
 	Tcl_AppendResult(interp, "no next ", methodType, " implementation",
 		NULL);
+	Tcl_SetErrorCode(interp, "TCL", "OO", "NOTHING_NEXT", NULL);
 	return TCL_ERROR;
     }
 
@@ -2529,6 +2543,8 @@ Tcl_GetObjectFromObj(
   notAnObject:
     Tcl_AppendResult(interp, TclGetString(objPtr),
 	    " does not refer to an object", NULL);
+    Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "OBJECT", TclGetString(objPtr),
+	    NULL);
     return NULL;
 }
 
diff --git a/generic/tclOOBasic.c b/generic/tclOOBasic.c
index 3fee439..0d38dcd 100644
--- a/generic/tclOOBasic.c
+++ b/generic/tclOOBasic.c
@@ -100,6 +100,7 @@ TclOO_Class_Create(
 
 	Tcl_AppendResult(interp, "object \"", TclGetString(cmdnameObj),
 		"\" is not a class", NULL);
+	Tcl_SetErrorCode(interp, "TCL", "OO", "INSTANTIATE_NONCLASS", NULL);
 	return TCL_ERROR;
     }
 
@@ -163,6 +164,7 @@ TclOO_Class_CreateNs(
 
 	Tcl_AppendResult(interp, "object \"", TclGetString(cmdnameObj),
 		"\" is not a class", NULL);
+	Tcl_SetErrorCode(interp, "TCL", "OO", "INSTANTIATE_NONCLASS", NULL);
 	return TCL_ERROR;
     }
 
@@ -231,6 +233,7 @@ TclOO_Class_New(
 
 	Tcl_AppendResult(interp, "object \"", TclGetString(cmdnameObj),
 		"\" is not a class", NULL);
+	Tcl_SetErrorCode(interp, "TCL", "OO", "INSTANTIATE_NONCLASS", NULL);
 	return TCL_ERROR;
     }
 
diff --git a/generic/tclOODefineCmds.c b/generic/tclOODefineCmds.c
index 8d8eb85..72732da 100644
--- a/generic/tclOODefineCmds.c
+++ b/generic/tclOODefineCmds.c
@@ -342,6 +342,8 @@ RenameDeleteMethod(
 	noSuchMethod:
 	    Tcl_AppendResult(interp, "method ", TclGetString(fromPtr),
 		    " does not exist", NULL);
+	    Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD",
+		    TclGetString(fromPtr), NULL);
 	    return TCL_ERROR;
 	}
 	hPtr = Tcl_FindHashEntry(oPtr->methodsPtr, (char *) fromPtr);
@@ -355,11 +357,13 @@ RenameDeleteMethod(
 	    renameToSelf:
 		Tcl_AppendResult(interp, "cannot rename method to itself",
 			NULL);
+		Tcl_SetErrorCode(interp, "TCL", "OO", "RENAME_TO_SELF", NULL);
 		return TCL_ERROR;
 	    } else if (!isNew) {
 	    renameToExisting:
 		Tcl_AppendResult(interp, "method called ",
 			TclGetString(toPtr), " already exists", NULL);
+		Tcl_SetErrorCode(interp, "TCL", "OO", "RENAME_OVER", NULL);
 		return TCL_ERROR;
 	    }
 	}
@@ -427,6 +431,7 @@ TclOOUnknownDefinition(
 
     if (objc < 2) {
 	Tcl_AppendResult(interp, "bad call of unknown handler", NULL);
+	Tcl_SetErrorCode(interp, "TCL", "OO", "BAD_UNKNOWN", NULL);
 	return TCL_ERROR;
     }
     if (TclOOGetDefineCmdContext(interp) == NULL) {
@@ -471,6 +476,7 @@ TclOOUnknownDefinition(
 
   noMatch:
     Tcl_AppendResult(interp, "invalid command name \"",soughtStr,"\"", NULL);
+    Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "COMMAND", soughtStr, NULL);
     return TCL_ERROR;
 }
 
@@ -560,6 +566,7 @@ InitDefineContext(
 	Tcl_AppendResult(interp,
 		"cannot process definitions; support namespace deleted",
 		NULL);
+	Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL);
 	return TCL_ERROR;
     }
 
@@ -598,6 +605,7 @@ TclOOGetDefineCmdContext(
 	Tcl_AppendResult(interp, "this command may only be called from within"
 		" the context of an ::oo::define or ::oo::objdefine command",
 		NULL);
+	Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL);
 	return NULL;
     }
     return (Tcl_Object) iPtr->varFramePtr->clientData;
@@ -638,6 +646,8 @@ GetClassInOuterContext(
     }
     if (oPtr->classPtr == NULL) {
 	Tcl_AppendResult(interp, errMsg, NULL);
+	Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "CLASS",
+		TclGetString(className), NULL);
 	return NULL;
     }
     return oPtr->classPtr;
@@ -679,6 +689,8 @@ TclOODefineObjCmd(
     if (oPtr->classPtr == NULL) {
 	Tcl_AppendResult(interp, TclGetString(objv[1]),
 		" does not refer to a class", NULL);
+	Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "CLASS",
+		TclGetString(objv[1]), NULL);
 	return TCL_ERROR;
     }
 
@@ -1038,11 +1050,13 @@ TclOODefineClassObjCmd(
     if (oPtr->flags & ROOT_OBJECT) {
 	Tcl_AppendResult(interp,
 		"may not modify the class of the root object class", NULL);
+	Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL);
 	return TCL_ERROR;
     }
     if (oPtr->flags & ROOT_CLASS) {
 	Tcl_AppendResult(interp,
 		"may not modify the class of the class of classes", NULL);
+	Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL);
 	return TCL_ERROR;
     }
 
@@ -1070,6 +1084,7 @@ TclOODefineClassObjCmd(
 	Tcl_AppendResult(interp, "may not change a ",
 		(oPtr->classPtr==NULL ? "non-" : ""), "class object into a ",
 		(oPtr->classPtr==NULL ? "" : "non-"), "class object", NULL);
+	Tcl_SetErrorCode(interp, "TCL", "OO", "TRANSMUTATION", NULL);
 	return TCL_ERROR;
     }
 
@@ -1190,6 +1205,7 @@ TclOODefineDeleteMethodObjCmd(
     }
     if (!isInstanceDeleteMethod && !oPtr->classPtr) {
 	Tcl_AppendResult(interp, "attempt to misuse API", NULL);
+	Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL);
 	return TCL_ERROR;
     }
 
@@ -1312,6 +1328,7 @@ TclOODefineExportObjCmd(
     clsPtr = oPtr->classPtr;
     if (!isInstanceExport && !clsPtr) {
 	Tcl_AppendResult(interp, "attempt to misuse API", NULL);
+	Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL);
 	return TCL_ERROR;
     }
 
@@ -1393,6 +1410,7 @@ TclOODefineFilterObjCmd(
     }
     if (!isInstanceFilter && !oPtr->classPtr) {
 	Tcl_AppendResult(interp, "attempt to misuse API", NULL);
+	Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL);
 	return TCL_ERROR;
     }
 
@@ -1438,6 +1456,7 @@ TclOODefineForwardObjCmd(
     }
     if (!isInstanceForward && !oPtr->classPtr) {
 	Tcl_AppendResult(interp, "attempt to misuse API", NULL);
+	Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL);
 	return TCL_ERROR;
     }
     isPublic = Tcl_StringMatch(TclGetString(objv[1]), "[a-z]*")
@@ -1494,6 +1513,7 @@ TclOODefineMethodObjCmd(
     }
     if (!isInstanceMethod && !oPtr->classPtr) {
 	Tcl_AppendResult(interp, "attempt to misuse API", NULL);
+	Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL);
 	return TCL_ERROR;
     }
     isPublic = Tcl_StringMatch(TclGetString(objv[1]), "[a-z]*")
@@ -1544,6 +1564,7 @@ TclOODefineMixinObjCmd(
     }
     if (!isInstanceMixin && !oPtr->classPtr) {
 	Tcl_AppendResult(interp, "attempt to misuse API", NULL);
+	Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL);
 	return TCL_ERROR;
     }
     mixins = TclStackAlloc(interp, sizeof(Class *) * (objc-1));
@@ -1557,6 +1578,7 @@ TclOODefineMixinObjCmd(
 	}
 	if (!isInstanceMixin && TclOOIsReachable(oPtr->classPtr, clsPtr)) {
 	    Tcl_AppendResult(interp, "may not mix a class into itself", NULL);
+	    Tcl_SetErrorCode(interp, "TCL", "OO", "SELF_MIXIN", NULL);
 	    goto freeAndError;
 	}
 	mixins[i-1] = clsPtr;
@@ -1607,6 +1629,7 @@ TclOODefineRenameMethodObjCmd(
     }
     if (!isInstanceRenameMethod && !oPtr->classPtr) {
 	Tcl_AppendResult(interp, "attempt to misuse API", NULL);
+	Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL);
 	return TCL_ERROR;
     }
 
@@ -1667,11 +1690,13 @@ TclOODefineSuperclassObjCmd(
     if (oPtr->classPtr == NULL) {
 	Tcl_AppendResult(interp, "only classes may have superclasses defined",
 		NULL);
+	Tcl_SetErrorCode(interp, "TCL", "OO", "OBJECT_NOT_CLASS", NULL);
 	return TCL_ERROR;
     }
     if (oPtr->flags & ROOT_OBJECT) {
 	Tcl_AppendResult(interp,
 		"may not modify the superclass of the root object", NULL);
+	Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL);
 	return TCL_ERROR;
     }
 
@@ -1696,12 +1721,14 @@ TclOODefineSuperclassObjCmd(
 	    if (superclasses[j] == clsPtr) {
 		Tcl_AppendResult(interp,
 			"class should only be a direct superclass once",NULL);
+		Tcl_SetErrorCode(interp, "TCL", "OO", "REPETITIOUS", NULL);
 		goto failedAfterAlloc;
 	    }
 	}
 	if (TclOOIsReachable(oPtr->classPtr, clsPtr)) {
 	    Tcl_AppendResult(interp,
 		    "attempt to form circular dependency graph", NULL);
+	    Tcl_SetErrorCode(interp, "TCL", "OO", "CIRCULARITY", NULL);
 	failedAfterAlloc:
 	    ckfree(superclasses);
 	    return TCL_ERROR;
@@ -1768,6 +1795,7 @@ TclOODefineUnexportObjCmd(
     clsPtr = oPtr->classPtr;
     if (!isInstanceUnexport && !clsPtr) {
 	Tcl_AppendResult(interp, "attempt to misuse API", NULL);
+	Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL);
 	return TCL_ERROR;
     }
 
@@ -1851,6 +1879,7 @@ TclOODefineVariablesObjCmd(
     }
     if (!isInstanceVars && !oPtr->classPtr) {
 	Tcl_AppendResult(interp, "attempt to misuse API", NULL);
+	Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL);
 	return TCL_ERROR;
     }
 
@@ -1861,11 +1890,13 @@ TclOODefineVariablesObjCmd(
 	    Tcl_AppendResult(interp, "invalid declared variable name \"",
 		    varName, "\": must not contain namespace separators",
 		    NULL);
+	    Tcl_SetErrorCode(interp, "TCL", "OO", "BAD_DECLVAR", NULL);
 	    return TCL_ERROR;
 	}
 	if (Tcl_StringMatch(varName, "*(*)")) {
 	    Tcl_AppendResult(interp, "invalid declared variable name \"",
 		    varName, "\": must not refer to an array element", NULL);
+	    Tcl_SetErrorCode(interp, "TCL", "OO", "BAD_DECLVAR", NULL);
 	    return TCL_ERROR;
 	}
     }
diff --git a/generic/tclOOInfo.c b/generic/tclOOInfo.c
index 2cd7cc3..4f25772 100644
--- a/generic/tclOOInfo.c
+++ b/generic/tclOOInfo.c
@@ -216,30 +216,22 @@ InfoObjectClassCmd(
 		TclOOObjectName(interp, oPtr->selfCls->thisPtr));
 	return TCL_OK;
     } else {
-	Object *o2Ptr;
-	Class *mixinPtr;
+	Class *mixinPtr, *o2clsPtr;
 	int i;
 
-	o2Ptr = (Object *) Tcl_GetObjectFromObj(interp, objv[2]);
-	if (o2Ptr == NULL) {
-	    return TCL_ERROR;
-	}
-	if (o2Ptr->classPtr == NULL) {
-	    Tcl_AppendResult(interp, "object \"", TclGetString(objv[2]),
-		    "\" is not a class", NULL);
-	    Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "CLASS",
-		    TclGetString(objv[2]), NULL);
+	o2clsPtr = GetClassFromObj(interp, objv[2]);
+	if (o2clsPtr == NULL) {
 	    return TCL_ERROR;
 	}
 
 	FOREACH(mixinPtr, oPtr->mixins) {
-	    if (TclOOIsReachable(o2Ptr->classPtr, mixinPtr)) {
+	    if (TclOOIsReachable(o2clsPtr, mixinPtr)) {
 		Tcl_SetObjResult(interp, Tcl_NewIntObj(1));
 		return TCL_OK;
 	    }
 	}
 	Tcl_SetObjResult(interp, Tcl_NewIntObj(
-		TclOOIsReachable(o2Ptr->classPtr, oPtr->selfCls)));
+		TclOOIsReachable(o2clsPtr, oPtr->selfCls)));
 	return TCL_OK;
     }
 }
@@ -496,6 +488,7 @@ InfoObjectIsACmd(
 	}
 	if (o2Ptr->classPtr == NULL) {
 	    Tcl_AppendResult(interp, "non-classes cannot be mixins", NULL);
+	    Tcl_SetErrorCode(interp, "TCL", "OO", "NONCLASS", NULL);
 	    return TCL_ERROR;
 	} else {
 	    Class *mixinPtr;
@@ -520,6 +513,7 @@ InfoObjectIsACmd(
 	}
 	if (o2Ptr->classPtr == NULL) {
 	    Tcl_AppendResult(interp, "non-classes cannot be types", NULL);
+	    Tcl_SetErrorCode(interp, "TCL", "OO", "NONCLASS", NULL);
 	    return TCL_ERROR;
 	}
 	if (TclOOIsReachable(o2Ptr->classPtr, oPtr->selfCls)) {
@@ -882,6 +876,7 @@ InfoClassConstrCmd(
     if (procPtr == NULL) {
 	Tcl_AppendResult(interp,
 		"definition not available for this kind of method", NULL);
+	Tcl_SetErrorCode(interp, "TCL", "OO", "METHOD_TYPE", NULL);
 	return TCL_ERROR;
     }
 
@@ -1009,6 +1004,7 @@ InfoClassDestrCmd(
     if (procPtr == NULL) {
 	Tcl_AppendResult(interp,
 		"definition not available for this kind of method", NULL);
+	Tcl_SetErrorCode(interp, "TCL", "OO", "METHOD_TYPE", NULL);
 	return TCL_ERROR;
     }
 
diff --git a/generic/tclOOMethod.c b/generic/tclOOMethod.c
index 112d663..4e7edb8 100644
--- a/generic/tclOOMethod.c
+++ b/generic/tclOOMethod.c
@@ -1340,6 +1340,7 @@ TclOONewForwardInstanceMethod(
     if (prefixLen < 1) {
 	Tcl_AppendResult(interp, "method forward prefix must be non-empty",
 		NULL);
+	Tcl_SetErrorCode(interp, "TCL", "OO", "BAD_FORWARD", NULL);
 	return NULL;
     }
 
@@ -1381,6 +1382,7 @@ TclOONewForwardMethod(
     if (prefixLen < 1) {
 	Tcl_AppendResult(interp, "method forward prefix must be non-empty",
 		NULL);
+	Tcl_SetErrorCode(interp, "TCL", "OO", "BAD_FORWARD", NULL);
 	return NULL;
     }