From a6c8180f5d7e8eceb575c34573531ce86af8164f Mon Sep 17 00:00:00 2001 From: Vadim Belman Date: Tue, 5 Feb 2019 22:09:15 -0500 Subject: [PATCH] Fixed #2657 --- src/Perl6/Metamodel/ClassHOW.nqp | 13 +------ src/Perl6/Metamodel/ConcreteRoleHOW.nqp | 1 + src/Perl6/Metamodel/Concretization.nqp | 37 +++++++++++++++++++ .../Metamodel/MROBasedMethodDispatch.nqp | 4 +- src/Perl6/Metamodel/ParametricRoleHOW.nqp | 10 +++-- tools/build/common_bootstrap_sources | 1 + 6 files changed, 49 insertions(+), 17 deletions(-) create mode 100644 src/Perl6/Metamodel/Concretization.nqp diff --git a/src/Perl6/Metamodel/ClassHOW.nqp b/src/Perl6/Metamodel/ClassHOW.nqp index e6e80f33f95..ac74a18192c 100644 --- a/src/Perl6/Metamodel/ClassHOW.nqp +++ b/src/Perl6/Metamodel/ClassHOW.nqp @@ -22,10 +22,10 @@ class Perl6::Metamodel::ClassHOW does Perl6::Metamodel::REPRComposeProtocol does Perl6::Metamodel::InvocationProtocol does Perl6::Metamodel::Finalization + does Perl6::Metamodel::Concretization { has @!roles; has @!role_typecheck_list; - has @!concretizations; has @!fallbacks; has $!composed; @@ -98,7 +98,7 @@ class Perl6::Metamodel::ClassHOW @!role_typecheck_list[+@!role_typecheck_list] := $r; my $ins := $r.HOW.specialize($r, $obj); @ins_roles.push($ins); - nqp::push(@!concretizations, [$r, $ins]); + self.add_concretization($obj, $r, $ins); } self.compute_mro($obj); # to the best of our knowledge, because the role applier wants it. @stubs := RoleToClassApplier.apply($obj, @ins_roles); @@ -249,15 +249,6 @@ class Perl6::Metamodel::ClassHOW $!composed ?? @!role_typecheck_list !! self.roles_to_compose($obj) } - method concretization($obj, $ptype) { - for @!concretizations { - if nqp::decont($_[0]) =:= nqp::decont($ptype) { - return $_[1]; - } - } - nqp::die("No concretization found for " ~ $ptype.HOW.name($ptype)); - } - method is_composed($obj) { $!composed } diff --git a/src/Perl6/Metamodel/ConcreteRoleHOW.nqp b/src/Perl6/Metamodel/ConcreteRoleHOW.nqp index f56dce30e71..d72f7542baa 100644 --- a/src/Perl6/Metamodel/ConcreteRoleHOW.nqp +++ b/src/Perl6/Metamodel/ConcreteRoleHOW.nqp @@ -8,6 +8,7 @@ class Perl6::Metamodel::ConcreteRoleHOW does Perl6::Metamodel::RoleContainer does Perl6::Metamodel::MultipleInheritance does Perl6::Metamodel::ArrayType + does Perl6::Metamodel::Concretization { # Any collisions to resolve. has @!collisions; diff --git a/src/Perl6/Metamodel/Concretization.nqp b/src/Perl6/Metamodel/Concretization.nqp new file mode 100644 index 00000000000..e366b422eea --- /dev/null +++ b/src/Perl6/Metamodel/Concretization.nqp @@ -0,0 +1,37 @@ +# Support for mapping of non-specialized roles into their concretized state. +role Perl6::Metamodel::Concretization { + has @!concretizations; + + method add_concretization($obj, $role, $concrete) { + @!concretizations[+@!concretizations] := [$role, $concrete]; + } + + method concretization_lookup($obj, $ptype, :$local, :$transitive) { + my @result; + if nqp::istype($obj, $ptype) { + for @!concretizations { + if nqp::decont($_[0]) =:= nqp::decont($ptype) { + return [1, $_[1]]; + } + # Do preliminary type check for concrete role to avoid extra calls. + if $transitive && nqp::istype($_[1], $ptype) { + @result := $_[1].HOW.concretization_lookup($_[1], $ptype, :$local, :transitive(1)); + return @result if @result[0]; + } + } + unless $local { + for self.parents($obj, :local(1)) { + @result := $_.HOW.concretization_lookup($_, $ptype, :local(0), :$transitive); + return @result if @result[0]; + } + } + } + [0] + } + + method concretization($obj, $ptype, :$local = 0, :$transitive = 1) { + my @result := self.concretization_lookup($obj, $ptype, :$local, :$transitive); + nqp::die("No concretization found for " ~ $ptype.HOW.name($ptype)) unless @result[0]; + @result[1] + } +} diff --git a/src/Perl6/Metamodel/MROBasedMethodDispatch.nqp b/src/Perl6/Metamodel/MROBasedMethodDispatch.nqp index 524c377c64a..148c00e0272 100644 --- a/src/Perl6/Metamodel/MROBasedMethodDispatch.nqp +++ b/src/Perl6/Metamodel/MROBasedMethodDispatch.nqp @@ -26,8 +26,8 @@ role Perl6::Metamodel::MROBasedMethodDispatch { method find_method_qualified($obj, $qtype, $name) { if $qtype.HOW.archetypes.parametric && nqp::can(self, 'concretization') { - # Resolve it via the concrete form of this parametric. - my $conc := self.concretization($obj, $qtype); + # Resolve it via the concrete form of this parametric. Look deep for a candidate. + my $conc := self.concretization($obj, $qtype, :local(0), :transitive(1)); nqp::hllize($conc.HOW.method_table($conc)){$name} } else { diff --git a/src/Perl6/Metamodel/ParametricRoleHOW.nqp b/src/Perl6/Metamodel/ParametricRoleHOW.nqp index 81ac72489dd..2bb13997aaa 100644 --- a/src/Perl6/Metamodel/ParametricRoleHOW.nqp +++ b/src/Perl6/Metamodel/ParametricRoleHOW.nqp @@ -192,12 +192,14 @@ class Perl6::Metamodel::ParametricRoleHOW # Roles done by this role need fully specializing also; all # they'll be missing is the target class (e.g. our first arg). for self.roles_to_compose($obj) { - my $r := $_; + my $ins := my $r := $_; if $_.HOW.archetypes.generic { - $r := $r.HOW.instantiate_generic($r, $type_env); - $conc.HOW.add_to_role_typecheck_list($conc, $r); + $ins := $ins.HOW.instantiate_generic($ins, $type_env); + $conc.HOW.add_to_role_typecheck_list($conc, $ins); } - $conc.HOW.add_role($conc, $r.HOW.specialize($r, @pos_args[0])); + $ins := $ins.HOW.specialize($ins, @pos_args[0]); + $conc.HOW.add_role($conc, $ins); + $conc.HOW.add_concretization($conc, $r, $ins); } # Pass along any parents that have been added, resolving them in diff --git a/tools/build/common_bootstrap_sources b/tools/build/common_bootstrap_sources index 4ffff99a5e8..1a185753ea2 100644 --- a/tools/build/common_bootstrap_sources +++ b/tools/build/common_bootstrap_sources @@ -31,6 +31,7 @@ src/Perl6/Metamodel/InvocationProtocol.nqp src/Perl6/Metamodel/RolePunning.nqp src/Perl6/Metamodel/ArrayType.nqp src/Perl6/Metamodel/RoleToRoleApplier.nqp +src/Perl6/Metamodel/Concretization.nqp src/Perl6/Metamodel/ConcreteRoleHOW.nqp src/Perl6/Metamodel/CurriedRoleHOW.nqp src/Perl6/Metamodel/ParametricRoleHOW.nqp