summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
Diffstat
-rw-r--r--generic/tclCompile.c6
-rw-r--r--generic/tclOOInfo.c112
-rw-r--r--tests/oo.test24
3 files changed, 79 insertions, 63 deletions
diff --git a/generic/tclCompile.c b/generic/tclCompile.c
index 361c26f..824276c 100644
--- a/generic/tclCompile.c
+++ b/generic/tclCompile.c
@@ -356,7 +356,7 @@ InstructionDesc const tclInstructionTable[] = {
/* Create the variables (described in the aux data referred to by the
* second immediate argument) to mirror the state of the dictionary in
* the variable referred to by the first immediate argument. The list
- * of keys (top of the stack, not poppsed) must be the same length as
+ * of keys (top of the stack, not popped) must be the same length as
* the list of variables.
* Stack: ... keyList => ... keyList */
{"dictUpdateEnd", 9, -1, 2, {OPERAND_LVT4, OPERAND_AUX4}},
@@ -518,7 +518,7 @@ InstructionDesc const tclInstructionTable[] = {
* case. Also runs the whole-array trace on the named variable, so can
* throw anything.
* Stack: ... varName => ... boolean */
- {"arrayExistsImm", 5, +1, 1, {OPERAND_UINT4}},
+ {"arrayExistsImm", 5, +1, 1, {OPERAND_LVT4}},
/* Looks up the variable indexed by opnd and tests whether it is an
* array. Pushes a boolean describing whether this is the case. Also
* runs the whole-array trace on the named variable, so can throw
@@ -528,7 +528,7 @@ InstructionDesc const tclInstructionTable[] = {
/* Forces the element on the top of the stack to be the name of an
* array.
* Stack: ... varName => ... */
- {"arrayMakeImm", 5, 0, 1, {OPERAND_UINT4}},
+ {"arrayMakeImm", 5, 0, 1, {OPERAND_LVT4}},
/* Forces the variable indexed by opnd to be an array. Does not touch
* the stack. */
diff --git a/generic/tclOOInfo.c b/generic/tclOOInfo.c
index 3217f98..0c22bcf 100644
--- a/generic/tclOOInfo.c
+++ b/generic/tclOOInfo.c
@@ -401,7 +401,7 @@ InfoObjectIsACmd(
IsClass, IsMetaclass, IsMixin, IsObject, IsType
};
Object *oPtr, *o2Ptr;
- int idx, i;
+ int idx, i, result = 0;
if (objc < 3) {
Tcl_WrongNumArgs(interp, 1, objv, "category objName ?arg ...?");
@@ -412,93 +412,85 @@ InfoObjectIsACmd(
return TCL_ERROR;
}
- if (idx == IsObject) {
- int ok = (Tcl_GetObjectFromObj(interp, objv[2]) != NULL);
-
- if (!ok) {
- Tcl_ResetResult(interp);
- }
- Tcl_SetObjResult(interp, Tcl_NewIntObj(ok ? 1 : 0));
- return TCL_OK;
- }
- oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[2]);
- if (oPtr == NULL) {
- return TCL_ERROR;
- }
+ /*
+ * Now we know what test we are doing, we can check we've got the right
+ * number of arguments.
+ */
switch ((enum IsACats) idx) {
+ case IsObject:
case IsClass:
- if (objc != 3) {
- Tcl_WrongNumArgs(interp, 2, objv, "objName");
- return TCL_ERROR;
- }
- Tcl_SetObjResult(interp, Tcl_NewIntObj(oPtr->classPtr ? 1 : 0));
- return TCL_OK;
case IsMetaclass:
if (objc != 3) {
Tcl_WrongNumArgs(interp, 2, objv, "objName");
return TCL_ERROR;
}
- if (oPtr->classPtr == NULL) {
- Tcl_SetObjResult(interp, Tcl_NewIntObj(0));
- } else {
- Class *classCls = TclOOGetFoundation(interp)->classCls;
-
- Tcl_SetObjResult(interp, Tcl_NewIntObj(
- TclOOIsReachable(classCls, oPtr->classPtr) ? 1 : 0));
- }
- return TCL_OK;
+ break;
case IsMixin:
+ case IsType:
if (objc != 4) {
Tcl_WrongNumArgs(interp, 2, objv, "objName className");
return TCL_ERROR;
}
+ break;
+ }
+
+ /*
+ * Perform the check. Note that we can guarantee that we will not fail
+ * from here on; "failures" result in a false-TCL_OK result.
+ */
+
+ oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[2]);
+ if (oPtr == NULL) {
+ goto failPrecondition;
+ }
+
+ switch ((enum IsACats) idx) {
+ case IsObject:
+ result = 1;
+ break;
+ case IsClass:
+ result = (oPtr->classPtr != NULL);
+ break;
+ case IsMetaclass:
+ if (oPtr->classPtr != NULL) {
+ result = TclOOIsReachable(TclOOGetFoundation(interp)->classCls,
+ oPtr->classPtr);
+ }
+ break;
+ case IsMixin:
o2Ptr = (Object *) Tcl_GetObjectFromObj(interp, objv[3]);
if (o2Ptr == NULL) {
- return TCL_ERROR;
+ goto failPrecondition;
}
- if (o2Ptr->classPtr == NULL) {
- Tcl_SetObjResult(interp, Tcl_NewStringObj(
- "non-classes cannot be mixins", -1));
- Tcl_SetErrorCode(interp, "TCL", "OO", "NONCLASS", NULL);
- return TCL_ERROR;
- } else {
+ if (o2Ptr->classPtr != NULL) {
Class *mixinPtr;
FOREACH(mixinPtr, oPtr->mixins) {
- if (mixinPtr == o2Ptr->classPtr) {
- Tcl_SetObjResult(interp, Tcl_NewIntObj(1));
- return TCL_OK;
+ if (TclOOIsReachable(o2Ptr->classPtr, mixinPtr)) {
+ result = 1;
+ break;
}
}
}
- Tcl_SetObjResult(interp, Tcl_NewIntObj(0));
- return TCL_OK;
+ break;
case IsType:
- if (objc != 4) {
- Tcl_WrongNumArgs(interp, 2, objv, "objName className");
- return TCL_ERROR;
- }
o2Ptr = (Object *) Tcl_GetObjectFromObj(interp, objv[3]);
if (o2Ptr == NULL) {
- return TCL_ERROR;
- }
- if (o2Ptr->classPtr == NULL) {
- Tcl_SetObjResult(interp, Tcl_NewStringObj(
- "non-classes cannot be types", -1));
- Tcl_SetErrorCode(interp, "TCL", "OO", "NONCLASS", NULL);
- return TCL_ERROR;
+ goto failPrecondition;
}
- if (TclOOIsReachable(o2Ptr->classPtr, oPtr->selfCls)) {
- Tcl_SetObjResult(interp, Tcl_NewIntObj(1));
- } else {
- Tcl_SetObjResult(interp, Tcl_NewIntObj(0));
+ if (o2Ptr->classPtr != NULL) {
+ result = TclOOIsReachable(o2Ptr->classPtr, oPtr->selfCls);
}
- return TCL_OK;
- case IsObject:
- Tcl_Panic("unexpected fallthrough");
+ break;
}
- return TCL_ERROR;
+ Tcl_SetObjResult(interp, Tcl_NewBooleanObj(result));
+ return TCL_OK;
+
+ failPrecondition:
+ Tcl_ResetResult(interp);
+ Tcl_SetObjResult(interp, Tcl_NewBooleanObj(0));
+ return TCL_OK;
}
/*
diff --git a/tests/oo.test b/tests/oo.test
index f35b70a..c83e015 100644
--- a/tests/oo.test
+++ b/tests/oo.test
@@ -2077,6 +2077,30 @@ test oo-16.13 {OO: object introspection} -setup {
oo::objdefine foo method Bar {} {return "ok in foo"}
[info object namespace foo]::my Bar
} -result "ok in foo"
+test oo-16.14 {OO: object introspection: TIP #436} -setup {
+ oo::class create meta { superclass oo::class }
+ [meta create instance1] create instance2
+} -body {
+ list class [list [info object isa class NOTANOBJECT] \
+ [info object isa class list]] \
+ meta [list [info object isa metaclass NOTANOBJECT] \
+ [info object isa metaclass list] \
+ [info object isa metaclass oo::object]] \
+ type [list [info object isa typeof oo::object NOTANOBJECT] \
+ [info object isa typeof NOTANOBJECT oo::object] \
+ [info object isa typeof list NOTANOBJECT] \
+ [info object isa typeof NOTANOBJECT list] \
+ [info object isa typeof oo::object list] \
+ [info object isa typeof list oo::object]] \
+ mix [list [info object isa mixin oo::object NOTANOBJECT] \
+ [info object isa mixin NOTANOBJECT oo::object] \
+ [info object isa mixin list NOTANOBJECT] \
+ [info object isa mixin NOTANOBJECT list] \
+ [info object isa mixin oo::object list] \
+ [info object isa mixin list oo::object]]
+} -cleanup {
+ meta destroy
+} -result {class {0 0} meta {0 0 0} type {0 0 0 0 0 0} mix {0 0 0 0 0 0}}
test oo-17.1 {OO: class introspection} -body {
info class
generated by cgit v0.12 at 2024-07-05 01:25:27 (GMT)