diff --git a/build/Makefile.in b/build/Makefile.in index b9560184120..761424bbc54 100644 --- a/build/Makefile.in +++ b/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 diff --git a/src/cheats/parrot/P6role.pir b/src/cheats/parrot/P6role.pir index 244a488b29c..567abe49c0b 100644 --- a/src/cheats/parrot/P6role.pir +++ b/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 diff --git a/src/core/operators.pm b/src/core/operators.pm index 4e6a85ac790..e232ebb024d 100644 --- a/src/core/operators.pm +++ b/src/core/operators.pm @@ -83,7 +83,7 @@ our sub undefine(\$x) { our multi infix:(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 } diff --git a/src/glue/dispatch.pir b/src/glue/dispatch.pir index cf60e45f7a8..3e2f4a2cc58 100644 --- a/src/glue/dispatch.pir +++ b/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 diff --git a/src/metamodel/RoleHOW.pir b/src/metamodel/RoleHOW.pir index 074b87764f4..9d3e2cf829b 100644 --- a/src/metamodel/RoleHOW.pir +++ b/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 diff --git a/src/metamodel/RoleToInstanceApplier.nqp b/src/metamodel/RoleToInstanceApplier.nqp new file mode 100644 index 00000000000..2d4bc55a55d --- /dev/null +++ b/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