summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
Diffstat
-rw-r--r--ChangeLog4
-rw-r--r--generic/tclOO.c16
-rw-r--r--generic/tclOOBasic.c3
-rw-r--r--generic/tclOODefineCmds.c31
-rw-r--r--generic/tclOOInfo.c22
-rw-r--r--generic/tclOOMethod.c2
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;
}
generated by cgit v0.12 at 2024-11-20 05:51:52 (GMT)