From 11c980f3f2f0b56543c09b737d17e6ddc8257d39 Mon Sep 17 00:00:00 2001 From: dkf Date: Wed, 1 Jul 2015 09:45:04 +0000 Subject: Implementation of TIP #436: Improve TclOO isa Introspection --- generic/tclOOInfo.c | 59 +++++++++++++++++++++++------------------------------ 1 file changed, 25 insertions(+), 34 deletions(-) diff --git a/generic/tclOOInfo.c b/generic/tclOOInfo.c index 3217f98..a12208d 100644 --- a/generic/tclOOInfo.c +++ b/generic/tclOOInfo.c @@ -412,27 +412,25 @@ 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; + goto failPrecondition; } switch ((enum IsACats) idx) { + case IsObject: + if (objc != 3) { + Tcl_WrongNumArgs(interp, 2, objv, "objName"); + return TCL_ERROR; + } + Tcl_SetObjResult(interp, Tcl_NewBooleanObj(1)); + return TCL_OK; case IsClass: if (objc != 3) { Tcl_WrongNumArgs(interp, 2, objv, "objName"); return TCL_ERROR; } - Tcl_SetObjResult(interp, Tcl_NewIntObj(oPtr->classPtr ? 1 : 0)); + Tcl_SetObjResult(interp, Tcl_NewBooleanObj(!!oPtr->classPtr)); return TCL_OK; case IsMetaclass: if (objc != 3) { @@ -440,12 +438,12 @@ InfoObjectIsACmd( return TCL_ERROR; } if (oPtr->classPtr == NULL) { - Tcl_SetObjResult(interp, Tcl_NewIntObj(0)); + Tcl_SetObjResult(interp, Tcl_NewBooleanObj(0)); } else { Class *classCls = TclOOGetFoundation(interp)->classCls; - Tcl_SetObjResult(interp, Tcl_NewIntObj( - TclOOIsReachable(classCls, oPtr->classPtr) ? 1 : 0)); + Tcl_SetObjResult(interp, Tcl_NewBooleanObj( + TclOOIsReachable(classCls, oPtr->classPtr))); } return TCL_OK; case IsMixin: @@ -455,24 +453,19 @@ InfoObjectIsACmd( } 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)); + Tcl_SetObjResult(interp, Tcl_NewBooleanObj(1)); return TCL_OK; } } } - Tcl_SetObjResult(interp, Tcl_NewIntObj(0)); + Tcl_SetObjResult(interp, Tcl_NewBooleanObj(0)); return TCL_OK; case IsType: if (objc != 4) { @@ -481,24 +474,22 @@ InfoObjectIsACmd( } 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 types", -1)); - Tcl_SetErrorCode(interp, "TCL", "OO", "NONCLASS", NULL); - return TCL_ERROR; - } - if (TclOOIsReachable(o2Ptr->classPtr, oPtr->selfCls)) { - Tcl_SetObjResult(interp, Tcl_NewIntObj(1)); + Tcl_SetObjResult(interp, Tcl_NewBooleanObj(0)); } else { - Tcl_SetObjResult(interp, Tcl_NewIntObj(0)); + Tcl_SetObjResult(interp, Tcl_NewBooleanObj( + TclOOIsReachable(o2Ptr->classPtr, oPtr->selfCls))); } return TCL_OK; - case IsObject: - Tcl_Panic("unexpected fallthrough"); } return TCL_ERROR; + + failPrecondition: + Tcl_ResetResult(interp); + Tcl_SetObjResult(interp, Tcl_NewBooleanObj(0)); + return TCL_OK; } /* -- cgit v0.12 From d73743625ca06bbbd8c8b013a31a9ffffce40bd1 Mon Sep 17 00:00:00 2001 From: dkf Date: Wed, 1 Jul 2015 09:58:42 +0000 Subject: Say what is meant more clearly, put syntax checks before semantic checks. --- generic/tclOOInfo.c | 85 +++++++++++++++++++++++++++-------------------------- 1 file changed, 43 insertions(+), 42 deletions(-) diff --git a/generic/tclOOInfo.c b/generic/tclOOInfo.c index a12208d..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,45 +412,53 @@ InfoObjectIsACmd( return TCL_ERROR; } - oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[2]); - if (oPtr == NULL) { - goto failPrecondition; - } + /* + * 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: - if (objc != 3) { - Tcl_WrongNumArgs(interp, 2, objv, "objName"); - return TCL_ERROR; - } - Tcl_SetObjResult(interp, Tcl_NewBooleanObj(1)); - return TCL_OK; case IsClass: - if (objc != 3) { - Tcl_WrongNumArgs(interp, 2, objv, "objName"); - return TCL_ERROR; - } - Tcl_SetObjResult(interp, Tcl_NewBooleanObj(!!oPtr->classPtr)); - 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_NewBooleanObj(0)); - } else { - Class *classCls = TclOOGetFoundation(interp)->classCls; - - Tcl_SetObjResult(interp, Tcl_NewBooleanObj( - TclOOIsReachable(classCls, oPtr->classPtr))); - } - 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) { goto failPrecondition; @@ -459,32 +467,25 @@ InfoObjectIsACmd( Class *mixinPtr; FOREACH(mixinPtr, oPtr->mixins) { - if (mixinPtr == o2Ptr->classPtr) { - Tcl_SetObjResult(interp, Tcl_NewBooleanObj(1)); - return TCL_OK; + if (TclOOIsReachable(o2Ptr->classPtr, mixinPtr)) { + result = 1; + break; } } } - Tcl_SetObjResult(interp, Tcl_NewBooleanObj(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) { goto failPrecondition; } - if (o2Ptr->classPtr == NULL) { - Tcl_SetObjResult(interp, Tcl_NewBooleanObj(0)); - } else { - Tcl_SetObjResult(interp, Tcl_NewBooleanObj( - TclOOIsReachable(o2Ptr->classPtr, oPtr->selfCls))); + if (o2Ptr->classPtr != NULL) { + result = TclOOIsReachable(o2Ptr->classPtr, oPtr->selfCls); } - return TCL_OK; + break; } - return TCL_ERROR; + Tcl_SetObjResult(interp, Tcl_NewBooleanObj(result)); + return TCL_OK; failPrecondition: Tcl_ResetResult(interp); -- cgit v0.12 From f4fd861a23e2867e38607aad65b39d2ed61f10c1 Mon Sep 17 00:00:00 2001 From: dkf Date: Fri, 10 Jul 2015 12:40:49 +0000 Subject: Added tests. --- tests/oo.test | 24 ++++++++++++++++++++++++ 1 file changed, 24 insertions(+) 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 -- cgit v0.12