First cut implementation of .^roles for introspecting what roles a cl…

…ass does, plus some other corrections to various bits of role introspection.

src/parrot/ClassHOW.pir

@@ -178,6 +178,62 @@ XXX Fix bugs with introspecting some built-in classes (List, Str...)
     .return (result_list)
 .end
 
+
+=item roles(object)
+
+Gets a list of roles done by the class of this object.
+
+=cut
+
+.sub 'roles' :method
+    .param pmc obj
+    .param pmc local :named('local') :optional
+
+    # Create result list.
+    .local pmc result_list
+    result_list = get_root_global [.RAKUDO_HLL], 'Array'
+    result_list = result_list.'new'()
+
+    # Get list of parents whose roles we are interested in, and put
+    # us on the start. With the local flag, that's just us.
+    .local pmc parents, parents_it, cur_class
+    if null local goto all_parents
+    unless local goto all_parents
+    parents = get_root_global [.RAKUDO_HLL], 'Array'
+    parents = parents.'new'()
+    goto parents_list_made
+  all_parents:
+    parents = self.'parents'(obj)
+  parents_list_made:
+    $P0 = obj.'WHAT'()
+    parents.'unshift'($P0)
+    parents_it = iter parents
+  parents_it_loop:
+    unless parents_it goto done
+    cur_class = shift parents_it
+
+    # Get Parrot-level class.
+    .local pmc parrot_class, roles, role_it, cur_role
+    parrot_class = self.'get_parrotclass'(cur_class)
+
+    # The list of roles is flattened out when we actually compose, so we
+    # don't inspect the Parrot class, but rather the to-compose list that
+    # is attached to it.
+    roles = getprop '@!roles', parrot_class
+    if null roles goto done
+    role_it = iter roles
+  role_it_loop:
+    unless role_it goto role_it_loop_end
+    cur_role = shift role_it
+    result_list.'push'(cur_role)
+    goto role_it_loop
+  role_it_loop_end:
+    goto parents_it_loop
+
+  done:
+    .return (result_list)
+.end
+
 =back
 
 =cut

src/parrot/P6role.pir

@@ -58,8 +58,8 @@ Puns the role to a class and returns that class.
     # Set name (don't use name=>... in register so we don't make a
     # namespace entry though).
     $P1 = proto.'HOW'()
-    $S0 = self
-    $P0 = box $S0
+    $P0 = getprop '$!owner', self
+    $P0 = getattribute $P0, '$!shortname'
     setattribute $P1, 'shortname', $P0
 
     # Stash it away, then instantiate it.
@@ -148,10 +148,11 @@ Puns the role to a class and returns that class.
 .sub 'perl' :method
     .local pmc args, it
     self = descalarref self
-    args = getprop '@!type_args', self
-    $P0 = getprop '$!shortname', self
+    $P0 = getprop '$!owner', self
+    $P0 = getattribute $P0, '$!shortname'
     $S0 = $P0
     $S0 = concat $S0, '['
+    args = getprop '@!type_args', self
     it = iter args
   it_loop:
     unless it goto it_loop_end
@@ -164,6 +165,7 @@ Puns the role to a class and returns that class.
     .return ($S0)
 .end
 
+
 =item WHICH
 
 =cut

src/pmc/p6role.pmc

@@ -57,4 +57,9 @@ pmclass P6role extends Role need_ext dynpmc group perl6_group {
         VTABLE_setprop(interp, punner, CONST_STRING(interp, "name"), boxed_name);
         return punner;
     }
+
+    VTABLE STRING *get_string() {
+        PMC *owner = VTABLE_getprop(interp, SELF, CONST_STRING(interp, "$!owner"));
+        return VTABLE_get_string(interp, owner);
+    }
 }