[svn:parrot] r35818 - in trunk: src/pmc t/oo

Author: Whiteknight
Date: Tue Jan 20 08:45:43 2009
New Revision: 35818

Modified:
   trunk/src/pmc/object.pmc
   trunk/t/oo/vtableoverride.t

Log:
[does] Allow VTABLE_does to be overriddable in PIR. Add a few tests for this feature

Modified: trunk/src/pmc/object.pmc
==============================================================================
--- trunk/src/pmc/object.pmc	(original)
+++ trunk/src/pmc/object.pmc	Tue Jan 20 08:45:43 2009
@@ -548,8 +548,23 @@
 */
 
     VTABLE INTVAL does(STRING *role_name) {
+        /* If it's a null string, return false */
         if (!role_name)
             return 0;
+        else {
+            PMC    * const classobj = VTABLE_get_class(interp, SELF);
+            STRING * meth_name      = CONST_STRING(interp, "does");
+
+            PMC * const method = Parrot_oo_find_vtable_override(interp,
+                classobj, meth_name);
+
+            if (!PMC_IS_NULL(method)
+             && Parrot_run_meth_fromc_args_reti(interp, method, SELF, meth_name, "IS", role_name))
+                return 1;
+        }
+        /* Check the superclass's vtable interface, if any. */
+        if (SUPER(role_name))
+            return 1;
 
         /* Dispatch to the object's class */
         return VTABLE_does(interp, VTABLE_get_class(interp, SELF), role_name);

Modified: trunk/t/oo/vtableoverride.t
==============================================================================
--- trunk/t/oo/vtableoverride.t	(original)
+++ trunk/t/oo/vtableoverride.t	Tue Jan 20 08:45:43 2009
@@ -18,29 +18,58 @@
 
 .sub main :main
     .include 'test_more.pir'
-    plan(4)
-    
+    plan(11)
+
+    newclass_tests()
+    subclass_tests()
+.end
+
+.sub 'newclass_tests'
     $P1 = new 'MyObject'
-    
+
     # Test get_string
     $S0 = $P1
     is($S0, "[MyObject]", "get_string VTABLE override")
     $P0 = getattribute $P1, "message"
     $S0 = $P0
     is($S0, "[MyObject]", "attribute sideeffect of get_string")
-    
+
+    # Test does
+    $I0 = does $P1, 'this_dress_make...'
+    is ($I0, 1, "check first does, ok")
+    $I0 = does $P1, 'a_body_good'
+    is ($I0, 1, "check second does, ok")
+    $I0 = does $P1, 'it_better'
+    is ($I0, 0, "no it doesn't")
+
     # Test morph (doesn't actually perform a morph)
     morph $P1, "String"
     $P0 = getattribute $P1, "message"
     $S0 = $P0
     is($S0, "Morphing [MyObject] to type String", "Morph VTABLE override 1")
-    
+
     morph $P1, "Integer"
     $P0 = getattribute $P1, "message"
     $S0 = $P0
     is($S0, "Morphing [MyObject] to type Integer", "Morph VTABLE override 1")
 .end
 
+.sub 'subclass_tests'
+    $P1 = new 'MySubObject'
+
+    # Test does, same as newclass.
+    $I0 = does $P1, 'this_dress_make...'
+    is ($I0, 1, "check first does, ok")
+    $I0 = does $P1, 'a_body_good'
+    is ($I0, 1, "check second does, ok")
+    $I0 = does $P1, 'it_better'
+    is ($I0, 0, "no it doesn't")
+    # Also verify we does what our parent does
+    $I0 = does $P1, 'array'
+    is ($I0, 1, "inherited does")
+.end
+
+
 .namespace [ 'MyObject' ]
 
 .sub '__onload' :anon :init
@@ -66,7 +95,43 @@
     $P0 = box $S1
     setattribute self, "message", $P0
 .end
-    
+
+.sub 'does' :vtable
+    .param string query
+    $S0 = 'does I do '
+    $S0 .= query
+    $P0 = box $S0
+    setattribute self, "message", $P0
+    if query == 'this_dress_make...'   goto yes
+    if query == 'a_body_good' goto yes
+    .return(0)
+yes:
+    .return (1)
+.end
+
+.namespace [ 'MySubObject' ]
+
+.sub '__onload' :anon :init
+    $P1 = get_class 'ResizablePMCArray'
+    $P0 = subclass $P1, 'MySubObject'
+    addattribute $P0, "submessage"
+.end
+
+.sub 'does' :vtable
+    .param string query
+    $S0 = 'does I do '
+    $S0 .= query
+    $P0 = box $S0
+    setattribute self, "submessage", $P0
+    if query == 'this_dress_make...'   goto yes
+    if query == 'a_body_good' goto yes
+    .return(0)
+yes:
+    .return (1)
+.end
+
+
+
 
 # Local Variables:
 #   mode: pir