diff --git a/src/how/MonicMachine.nqp b/src/how/MonicMachine.nqp new file mode 100644 index 000000000..7fe355189 --- /dev/null +++ b/src/how/MonicMachine.nqp @@ -0,0 +1,80 @@ +knowhow MonicMachine is repr('VMArray') { + method new() { + nqp::create(self) + } + + method accept($member) { + nqp::push(self, $member); + self + } + + method veneer(@members) { + nqp::splice(self, @members, nqp::elems(self), 0) + } + + method embody(*@members) { + nqp::splice(self, @members, 0, nqp::elems(self)) + } + + method emboss(*@members) { + nqp::push(self, nqp::splice(nqp::create(self), @members, 0, 0)); + self + } + + method summon($evoke) { + if nqp::elems(self) -> $cursor { + repeat { $evoke(self, nqp::shift(self)) } while --$cursor; + } + self + } + + method banish($evoke, @keep) { + if nqp::elems(self) -> $cursor { + repeat { $evoke(self, nqp::shift(self)) } while --$cursor; + nqp::splice(@keep, self, nqp::elems(@keep), 0); + nqp::setelems(self, 0); + } + @keep + } + + method beckon(@keep) { + my @safe; + my $cursor := 0; + while nqp::elems(self) -> $n { + repeat { + my @members := self[$cursor]; + next unless nqp::elems(@members); + + my $member := @members[0]; + my $i; + repeat { + my @blocks := self[$i]; + next if @blocks =:= @members; + next unless my $b := nqp::elems(@blocks); + my $j; + last if @blocks[$j] =:= $member while ++$j < $b; + last if $j < $b; + } while ++$i < $n; + last if $i == $n; + } while ++$cursor < $n; + last if $cursor == $n; + + nqp::push(@safe, my $member := self[$cursor][0]); + $cursor := nqp::elems(self); + repeat { + my @members := nqp::pop(self); + next unless nqp::elems(@members); + nqp::shift(@members) if @members[0] =:= $member; + nqp::unshift(self, @members) if nqp::elems(@members); + } while --$cursor; + } + if $cursor && @safe { + nqp::die("Could not build C3 linearization: ambiguous hierarchy"); + } + nqp::splice(@keep, @safe, nqp::elems(@keep), 0) + } + + method list() { + nqp::splice(nqp::list(), self, 0, 0) + } +} diff --git a/src/how/NQPClassHOW.nqp b/src/how/NQPClassHOW.nqp index 5d062d58e..8e8b6be61 100644 --- a/src/how/NQPClassHOW.nqp +++ b/src/how/NQPClassHOW.nqp @@ -48,7 +48,7 @@ knowhow NQPClassHOW { has @!mro; # Full list of roles that we do. - has @!done; + has @!role_typecheck_list; # If needed, a cached flattened method table accounting for all methods in # this class and its parents. This is only needed in the sitaution that a @@ -91,7 +91,7 @@ knowhow NQPClassHOW { @!parents := nqp::list(); @!roles := nqp::list(); @!mro := nqp::list(); - @!done := nqp::list(); + @!role_typecheck_list := nqp::list(); @!BUILDALLPLAN := nqp::list(); @!BUILDPLAN := nqp::list(); $!is_mixin := 0; @@ -229,11 +229,12 @@ knowhow NQPClassHOW { # the composer. if @!roles { my @specialized_roles; - for @!roles { - my $ins := $_.HOW.specialize($_, $obj); + for @!roles -> $role { + my $ins := nqp::how_nd($role).specialize($role, $obj); + my @ins_rtl := nqp::how_nd($ins).role_typecheck_list($ins); + nqp::push(@!role_typecheck_list, $ins); + nqp::splice(@!role_typecheck_list, @ins_rtl, nqp::elems(@!role_typecheck_list), 0); nqp::push(@specialized_roles, $ins); - nqp::push(@!done, $_); - nqp::push(@!done, $ins); } RoleToClassApplier.apply($obj, @specialized_roles); } @@ -383,94 +384,9 @@ knowhow NQPClassHOW { # Computes C3 MRO. sub compute_c3_mro($class) { my @immediate_parents := $class.HOW.parents($class, :local); - - # Provided we have immediate parents... - my @result; - if nqp::elems(@immediate_parents) { - if nqp::elems(@immediate_parents) == 1 { - @result := compute_c3_mro(@immediate_parents[0]); - } else { - # Build merge list of linearizations of all our parents, add - # immediate parents and merge. - my @merge_list; - for @immediate_parents { - nqp::push(@merge_list, compute_c3_mro($_)); - } - nqp::push(@merge_list, @immediate_parents); - @result := c3_merge(@merge_list); - } - } - - # Put this class on the start of the list, and we're done. - nqp::unshift(@result, $class); - return @result; - } - - # C3 merge routine. - sub c3_merge(@merge_list) { - my @result; - my $accepted; - my $something_accepted := 0; - my $cand_count := 0; - - # Try to find something appropriate to add to the MRO. - for @merge_list { - my @cand_list := $_; - if @cand_list { - my $rejected := 0; - my $cand_class := @cand_list[0]; - $cand_count := $cand_count + 1; - for @merge_list { - # Skip current list. - unless $_ =:= @cand_list { - # Is current candidate in the tail? If so, reject. - my $cur_pos := 1; - while $cur_pos <= nqp::elems($_) { - if $_[$cur_pos] =:= $cand_class { - $rejected := 1; - } - $cur_pos := $cur_pos + 1; - } - } - } - - # If we didn't reject it, this candidate will do. - unless $rejected { - $accepted := $cand_class; - $something_accepted := 1; - last; - } - } - } - - # If we never found any candidates, return an empty list. - if $cand_count == 0 { - return @result; - } - - # If we didn't find anything to accept, error. - unless $something_accepted { - nqp::die("Could not build C3 linearization: ambiguous hierarchy"); - } - - # Otherwise, remove what was accepted from the merge lists. - my $i := 0; - while $i < nqp::elems(@merge_list) { - my @new_list; - for @merge_list[$i] { - unless $_ =:= $accepted { - nqp::push(@new_list, $_); - } - } - @merge_list[$i] := @new_list; - $i := $i + 1; - } - - # Need to merge what remains of the list, then put what was accepted on - # the start of the list, and we're done. - @result := c3_merge(@merge_list); - nqp::unshift(@result, $accepted); - return @result; + my @hier := MonicMachine.new; + @hier.emboss(|$_.HOW.mro($_)) for @immediate_parents; + @hier.beckon(nqp::list($class)) } method publish_type_cache($obj) { @@ -480,17 +396,16 @@ knowhow NQPClassHOW { nqp::push(@tc, $_); if nqp::can($_.HOW, 'role_typecheck_list') { for $_.HOW.role_typecheck_list($_) -> $role { + my @role_rtl := nqp::how_nd($role).role_typecheck_list($role); nqp::push(@tc, $role); - if nqp::can($role.HOW, 'role_typecheck_list') { - for $role.HOW.role_typecheck_list($role) { - nqp::push(@tc, $_); - } - } + nqp::splice(@tc, @role_rtl, nqp::elems(@tc), 0); } } } - nqp::settypecache($obj, @tc) + nqp::settypecache($obj, @tc); + nqp::settypecheckmode($obj, + nqp::const::TYPE_CHECK_CACHE_DEFINITIVE); } sub reverse(@in) { @@ -619,20 +534,67 @@ knowhow NQPClassHOW { ## Introspecty ## - method parents($obj, :$local = 0) { - $local ?? @!parents !! @!mro + my &PARENTS-TREE := nqp::getstaticcode( + anon sub PARENTS-TREE(@self, $obj) { + (my @parents := $obj.HOW.parents($obj, :tree)) + ?? @self.accept(nqp::list($obj, @parents)) + !! @self.accept(nqp::list($obj)) + }); + + my &PARENTS-ALL := nqp::getstaticcode( + anon sub PARENTS-ALL(@self, $obj) { + @self.emboss(|$obj.HOW.mro($obj)) + }); + + method parents($obj, :$local = 0, :$tree = 0, :$excl, :$all) { + $local + ?? @!parents + !! $tree + ?? nqp::elems(my @p := MonicMachine.new.veneer(@!parents).banish(&PARENTS-TREE, nqp::list())) == 1 + ?? @p[0] + !! @p + !! $!composed + ?? nqp::slice(@!mro, 1, nqp::elems(@!mro) - 1) + !! MonicMachine.new.veneer(@!parents).summon(&PARENTS-ALL).beckon(nqp::list()) } - method mro($obj) { + method mro($obj, :$concretizations, :$roles) { @!mro } - method roles($obj, :$local!) { - @!roles + my &ROLES-REMOTE := nqp::getstaticcode(anon sub ROLES-REMOTE(@self, $obj) { + @self.veneer($obj.HOW.roles($obj, :local, :!transitive, :!mro)) + }); + + my &ROLES-TRANSITIVE := nqp::getstaticcode(anon sub ROLES-TRANSITIVE(@self, $obj) { + @self.accept($obj).veneer($obj.HOW.roles($obj, :local, :transitive, :!mro)) + }); + + my &ROLES-MRO := nqp::getstaticcode(anon sub ROLES-MRO(@self, $obj) { + @self.accept(nqp::splice(nqp::list($obj), $obj.HOW.roles($obj, :local, :transitive, :!mro), 1, 0)) + }); + + method roles($obj, :$local = 0, :$transitive = 1, :$mro = 0) { + my @roles; + if $local { + @roles := @!roles; + } + else { + @roles := nqp::clone(@!roles); + MonicMachine.new.veneer(@!parents).banish(&ROLES-REMOTE, @roles); + @roles := @roles.list(); + } + if $transitive { + @roles := MonicMachine.new.veneer(@roles); + @roles := $mro + ?? @roles.summon(&ROLES-MRO).beckon(nqp::list()) + !! @roles.banish(&ROLES-TRANSITIVE, nqp::list()); + } + @roles } method role_typecheck_list($obj) { - @!done; + @!role_typecheck_list } method methods($obj, :$local = 0, :$all) { @@ -702,10 +664,10 @@ knowhow NQPClassHOW { } method does($obj, $check) { - my $i := nqp::elems(@!done); + my $i := nqp::elems(@!role_typecheck_list); while $i > 0 { $i := $i - 1; - if @!done[$i] =:= $check { + if @!role_typecheck_list[$i] =:= $check { return 1; } } diff --git a/src/how/NQPConcreteRoleHOW.nqp b/src/how/NQPConcreteRoleHOW.nqp index adb90b8cd..48a58b84b 100644 --- a/src/how/NQPConcreteRoleHOW.nqp +++ b/src/how/NQPConcreteRoleHOW.nqp @@ -40,7 +40,7 @@ knowhow NQPConcreteRoleHOW { # Creates a new instance of this meta-class. method new(:$name!, :$instance_of!) { my $obj := nqp::create(self); - $obj.BUILD(:name($name), :instance_of($instance_of)); + $obj.BUILD(:$name, :$instance_of); $obj } @@ -55,13 +55,14 @@ knowhow NQPConcreteRoleHOW { @!collisions := nqp::list(); @!roles := nqp::list(); @!role_typecheck_list := nqp::list(); + nqp::isnull($instance_of) || nqp::push(@!role_typecheck_list, $instance_of); $!composed := 0; } # Create a new meta-object instance, and then a new type object # to go with it, and return that. - method new_type(:$name = '', :$instance_of!) { - my $metarole := self.new(:name($name), :instance_of($instance_of)); + method new_type(:$name = '', :$instance_of = nqp::null()) { + my $metarole := self.new(:$name, :$instance_of); nqp::settypehll($metarole, 'nqp'); nqp::setdebugtypename(nqp::newtype($metarole, 'Uninstantiable'), $name); } @@ -109,23 +110,35 @@ knowhow NQPConcreteRoleHOW { # Incorporate roles. They're already instantiated. We need to # add to done list their instantiation source. if @!roles { - for @!roles { - nqp::push(@!role_typecheck_list, $_); - nqp::push(@!role_typecheck_list, $_.HOW.instance_of($_)); + for @!roles -> $role { + my @role_rtl := nqp::how_nd($role).role_typecheck_list($role); + nqp::push(@!role_typecheck_list, $role); + nqp::splice(@!role_typecheck_list, @role_rtl, nqp::elems(@!role_typecheck_list), 0); } RoleToRoleApplier.apply($obj, @!roles); } - # Mark composed. - $!composed := 1; - nqp::settypecache($obj, [$obj.WHAT]); + # Publish type cache. + my @tc := nqp::clone(@!role_typecheck_list); + nqp::unshift(@tc, $obj.WHAT); + nqp::settypecache($obj, @tc); + nqp::settypecheckmode($obj, + nqp::const::TYPE_CHECK_CACHE_DEFINITIVE); + + # Publish method cache. #?if !moar nqp::setmethcache($obj, {}); nqp::setmethcacheauth($obj, 1); #?endif + + # Mark composed. + $!composed := 1; $obj } + method is_composed($obj) { + $!composed + } ## ## Introspecty @@ -164,8 +177,23 @@ knowhow NQPConcreteRoleHOW { @!attributes } - method roles($obj, :$transitive = 0) { - @!roles + my &ROLES-TRANSITIVE := nqp::getstaticcode(anon sub ROLES-TRANSITIVE(@self, $obj) { + @self.accept($obj).veneer($obj.HOW.roles($obj, :transitive, :!mro)) + }); + + my &ROLES-MRO := nqp::getstaticcode(anon sub ROLES-MRO(@self, $obj) { + @self.accept(nqp::splice(nqp::list($obj), $obj.HOW.roles($obj, :transitive, :!mro), 1, 0)) + }); + + method roles($obj, :$local, :$transitive = 1, :$mro = 1) { + my @roles := @!roles; + if $transitive { + @roles := MonicMachine.new.veneer(@roles); + @roles := $mro + ?? @roles.summon(&ROLES-MRO).beckon(nqp::list()) + !! @roles.banish(&ROLES-TRANSITIVE, nqp::list()); + } + @roles } method role_typecheck_list($obj) { @@ -175,4 +203,12 @@ knowhow NQPConcreteRoleHOW { method instance_of($obj) { $!instance_of } + + method parents($obj, *%named) { + [] + } + + method mro($obj, *%named) { + [$obj] + } } diff --git a/src/how/NQPCurriedRoleHOW.nqp b/src/how/NQPCurriedRoleHOW.nqp index 622cb55f2..4a1c66017 100644 --- a/src/how/NQPCurriedRoleHOW.nqp +++ b/src/how/NQPCurriedRoleHOW.nqp @@ -1,6 +1,7 @@ knowhow NQPCurriedRoleHOW { has $!curried_role; has @!pos_args; + has @!role_typecheck_list; my $archetypes := Archetypes.new( :nominal(1), :composable(1), :parametric(1) ); method archetypes() { @@ -16,6 +17,9 @@ knowhow NQPCurriedRoleHOW { method BUILD(:$curried_role!, :@pos_args!) { $!curried_role := $curried_role; @!pos_args := @pos_args; + @!role_typecheck_list := nqp::clone( + nqp::how_nd($curried_role).role_typecheck_list($curried_role)); + nqp::unshift(@!role_typecheck_list, $curried_role); } method new_type($curried_role!, *@pos_args) { @@ -23,7 +27,11 @@ knowhow NQPCurriedRoleHOW { my $type := nqp::newtype($meta, 'Uninstantiable'); nqp::settypehll($type, 'nqp'); nqp::setdebugtypename($type, 'Curried ' ~ $curried_role.HOW.name($curried_role)); - $type + + my @rtl := $meta.role_typecheck_list($type); + nqp::settypecache($type, @rtl); + nqp::settypecheckmode($type, + nqp::const::TYPE_CHECK_CACHE_DEFINITIVE); } method specialize($obj, $class_arg) { @@ -42,4 +50,20 @@ knowhow NQPCurriedRoleHOW { method curried_role($obj) { $!curried_role } + + method role_typecheck_list($obj) { + @!role_typecheck_list + } + + method roles($obj, *%named) { + $!curried_role.HOW.roles($!curried_role, |%named) + } + + method parents($obj, *%named) { + $!curried_role.HOW.parents($!curried_role, |%named) + } + + method mro($obj, *%named) { + [$obj] + } } diff --git a/src/how/NQPParametricRoleHOW.nqp b/src/how/NQPParametricRoleHOW.nqp index 08b5e1a0d..c75680115 100644 --- a/src/how/NQPParametricRoleHOW.nqp +++ b/src/how/NQPParametricRoleHOW.nqp @@ -107,19 +107,28 @@ knowhow NQPParametricRoleHOW { # Compose the role. Beyond this point, no changes are allowed. method compose($obj) { - for @!roles { - nqp::push(@!role_typecheck_list, $_); - for $_.HOW.role_typecheck_list($_) { - nqp::push(@!role_typecheck_list, $_); - } + # Update the role typecheck list. + for @!roles -> $role { + my @role_rtl := nqp::how_nd($role).role_typecheck_list($role); + nqp::push(@!role_typecheck_list, $role); + nqp::splice(@!role_typecheck_list, @role_rtl, nqp::elems(@!role_typecheck_list), 0); } - $!composed := 1; - nqp::settypecache($obj, [$obj.WHAT]); + # Publish type cache. + my @tc := nqp::clone(@!role_typecheck_list); + nqp::unshift(@tc, $obj.WHAT); + nqp::settypecache($obj, @tc); + nqp::settypecheckmode($obj, + nqp::const::TYPE_CHECK_CACHE_DEFINITIVE); + + # Publish method cache. #?if !moar nqp::setmethcache($obj, {}); nqp::setmethcacheauth($obj, 1); #?endif + + # Mark composed. + $!composed := 1; $obj } @@ -214,11 +223,34 @@ knowhow NQPParametricRoleHOW { @!attributes } - method roles($obj, :$transitive = 0) { - @!roles + my &ROLES-TRANSITIVE := nqp::getstaticcode(anon sub ROLES-TRANSITIVE(@self, $obj) { + @self.accept($obj).veneer($obj.HOW.roles($obj, :transitive, :!mro)) + }); + + my &ROLES-MRO := nqp::getstaticcode(anon sub ROLES-MRO(@self, $obj) { + @self.accept(nqp::splice(nqp::list($obj), $obj.HOW.roles($obj, :transitive, :!mro), 1, 0)) + }); + + method roles($obj, :$local, :$transitive = 1, :$mro = 0) { + my @roles := @!roles; + if $transitive { + @roles := MonicMachine.new.veneer(@roles); + @roles := $mro + ?? @roles.summon(&ROLES-MRO).beckon(nqp::list()) + !! @roles.banish(&ROLES-TRANSITIVE, nqp::list()); + } + @roles } method role_typecheck_list($obj) { @!role_typecheck_list } + + method parents($obj, *%named) { + [] + } + + method mro($obj, *%named) { + [$obj] + } } diff --git a/src/how/RoleToClassApplier.nqp b/src/how/RoleToClassApplier.nqp index 1440de7cb..bf216750f 100644 --- a/src/how/RoleToClassApplier.nqp +++ b/src/how/RoleToClassApplier.nqp @@ -23,7 +23,7 @@ knowhow RoleToClassApplier { $to_compose_meta := $to_compose.HOW; } else { - $to_compose := NQPConcreteRoleHOW.new_type(:instance_of(NQPMu)); + $to_compose := NQPConcreteRoleHOW.new_type(); $to_compose_meta := $to_compose.HOW; for @roles { $to_compose_meta.add_role($to_compose, $_); diff --git a/t/nqp/056-role.t b/t/nqp/056-role.t index 916959679..3e9478d21 100644 --- a/t/nqp/056-role.t +++ b/t/nqp/056-role.t @@ -1,4 +1,4 @@ -plan(18); +plan(21); role R1 { has $!a; @@ -57,9 +57,20 @@ class X does PackageUsingRole { } is(X.name(), 'PackageUsingRole', 'using $?PACKAGE from a role'); -role Bar does Foo { } -role Baz does Bar { } +role Bar does Foo { +} +role Baz does Bar { +} +class Qux does Bar { +} +class Quux does Baz { +} +class Todo is Quux { +} -my @roles := Baz.HOW.role_typecheck_list(Baz); -ok(nqp::eqaddr(@roles[0], Bar), 'role typecheck list includes roles done'); -ok(nqp::eqaddr(@roles[1], Foo), 'role typecheck list includes roles done by roles done'); +ok(nqp::istype_nd(Baz, Foo), 'role RTL includes roles done'); +ok(nqp::istype_nd(Qux, Bar), 'class RTL includes roles done after specialization'); +ok(nqp::istype_nd(Quux, Baz), 'class RTL includes roles done by parents'); +ok(nqp::istype_nd(Todo, Baz), 'class RTL includes roles done after reparenting...'); +Todo.HOW.reparent(Todo, Qux); +ok(!nqp::istype_nd(Todo, Baz), '...and not those prior'); diff --git a/tools/templates/Makefile-common.in b/tools/templates/Makefile-common.in index c214ff90a..5b51b6367 100644 --- a/tools/templates/Makefile-common.in +++ b/tools/templates/Makefile-common.in @@ -90,6 +90,7 @@ QAST_COMBINED = QAST.nqp NQP_MO_SOURCES = \ @nfp(src/how/Archetypes.nqp)@ \ + @nfp(src/how/MonicMachine.nqp)@ \ @nfp(src/how/RoleToRoleApplier.nqp)@ \ @nfp(src/how/NQPConcreteRoleHOW.nqp)@ \ @nfp(src/how/RoleToClassApplier.nqp)@ \