From 4b3579029f185d116b809a5697720ceeb868c022 Mon Sep 17 00:00:00 2001 From: dkf Date: Mon, 4 Apr 2011 22:53:26 +0000 Subject: More generation of error codes (TclOO miscellany). --- ChangeLog | 4 ++++ generic/tclOO.c | 16 ++++++++++++++++ generic/tclOOBasic.c | 3 +++ generic/tclOODefineCmds.c | 31 +++++++++++++++++++++++++++++++ generic/tclOOInfo.c | 22 +++++++++------------- generic/tclOOMethod.c | 2 ++ 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 + * 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; } -- cgit v0.12