Implement TIP 436: Improve TclOO isa Introspection

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