Get role to instance application implemented (operators are fully in …

…Perl 6, applicator is in NQP with one little Parrot-specific bit that we can eliminate later).

build/Makefile.in

@@ -87,6 +87,7 @@ BUILTINS_PIR = \
   src/metamodel/RoleHOW.pir \
   src/gen/RoleToRoleApplier.pir \
   src/gen/RoleToClassApplier.pir \
+  src/gen/RoleToInstanceApplier.pir \
   src/metamodel/GrammarHOW.pir \
   src/builtins/Any.pir \
   src/builtins/Role.pir \
@@ -313,6 +314,10 @@ src/gen/RoleToRoleApplier.pir: $(PARROT) $(NQP_PBC) src/metamodel/RoleToRoleAppl
 	$(NQP_EXE) --output=src/gen/RoleToRoleApplier.pir --encoding=utf8 \
 	    --target=pir src/metamodel/RoleToRoleApplier.nqp
 
+src/gen/RoleToInstanceApplier.pir: $(PARROT) $(NQP_PBC) src/metamodel/RoleToInstanceApplier.nqp
+	$(NQP_EXE) --output=src/gen/RoleToInstanceApplier.pir --encoding=utf8 \
+	    --target=pir src/metamodel/RoleToInstanceApplier.nqp
+
 src/gen/Attribute.pir: $(PARROT) $(NQP_PBC) src/metamodel/Attribute.nqp
 	$(NQP_EXE) --output=src/gen/Attribute.pir --encoding=utf8 \
 	    --target=pir src/metamodel/Attribute.nqp

src/cheats/parrot/P6role.pir

@@ -208,11 +208,11 @@ Puns the role to a class and returns that class.
 .end
 
 
-=item postcircumfix:<[ ]>
+=item !select
 
 =cut
 
-.sub 'postcircumfix:<[ ]>' :method
+.sub '!select' :method
     .return (self)
 .end
 

src/core/operators.pm

@@ -83,7 +83,7 @@ our sub undefine(\$x) {
 our multi infix:<does>(Mu \$do-it-to-me, Role $r) {
     my $specific_role = $r!select;
     my $applicator    = $specific_role.^applier_for($do-it-to-me);
-    $applicator.apply($do-it-to-me, $r);
+    $applicator.apply($do-it-to-me, [$r]);
     $do-it-to-me
 }
 

src/glue/dispatch.pir

@@ -103,6 +103,7 @@ Does a call on the metaclass.
     .param pmc pos_args   :slurpy
     .param pmc named_args :slurpy :named
     .local pmc how
+    invocant = descalarref invocant
     how = invocant.'HOW'()
     .tailcall how.name(invocant, pos_args :flat, named_args :flat :named)
 .end

src/metamodel/RoleHOW.pir

@@ -210,7 +210,7 @@ knows how to do that).
     if $I0 goto class_applier
     $I0 = isa for, 'RoleHOW'
     if $I0 goto role_applier
-    if $I0 goto instance_applier
+    goto instance_applier
 
   class_applier:
     $P0 = get_hll_global ['Perl6';'Metamodel'], 'RoleToClassApplier'
@@ -221,7 +221,8 @@ knows how to do that).
     .return ($P0)
 
   instance_applier:
-    die 'Applying a role to an instance is not yet supported.'
+    $P0 = get_hll_global ['Perl6';'Metamodel'], 'RoleToInstanceApplier'
+    .return ($P0)
 .end
 
 

src/metamodel/RoleToInstanceApplier.nqp

@@ -0,0 +1,45 @@
+=begin
+
+=head1 TITLE
+
+Perl6::Metamodel::RoleToInstanceApplier
+
+=head1 DESCRIPTION
+
+Applies roles to an instance.
+
+=head1 METHODS
+
+=over 4
+
+=item apply(target, composees)
+
+Applies all of the composees to an instance.
+
+=end
+
+class Perl6::Metamodel::RoleToInstanceApplier;
+
+method apply($target, @composees) {
+    # Make anonymous subclass.
+    my $how      := $target.HOW;
+    my $subclass := $how.new;
+    $how.add_parent($subclass, $target.WHAT);
+
+    # Add all of our given composees to it.
+    for @composees {
+        $how.add_composable($subclass, $_);
+    }
+
+    # Complete construction of anonymous subclass and then rebless the target
+    # into it. XXX This bit is a tad Parrot-specific at the moment; need to
+    # better encapsulate reblessing.
+    my $new_class := $how.compose($subclass);
+    pir::rebless_subclass__vPP($target, $how.get_parrotclass($new_class));
+}
+
+=begin
+
+=back
+
+=end