1. my class Signature { # declared in BOOTSTRAP
  2. # class Signature is Any
  3. # has @!params; # VM's array of parameters
  4. # has Mu $!returns; # return type
  5. # has int $!arity; # arity
  6. # has Num $!count; # count
  7. # has Code $!code;
  8. multi method ACCEPTS(Signature:D: Capture $topic) {
  9. nqp::p6bool(nqp::p6isbindable(self, nqp::decont($topic)));
  10. }
  11. multi method ACCEPTS(Signature:D: @topic) {
  12. self.ACCEPTS(@topic.Capture)
  13. }
  14. multi method ACCEPTS(Signature:D: %topic) {
  15. self.ACCEPTS(%topic.Capture)
  16. }
  17. multi method ACCEPTS(Signature:D: Signature:D $topic) {
  18. my $sclass = self.params.classify({.named});
  19. my $tclass = $topic.params.classify({.named});
  20. my @spos := $sclass{False} // ();
  21. my @tpos := $tclass{False} // ();
  22. while @spos {
  23. my $s;
  24. my $t;
  25. last unless @tpos && ($t = @tpos.shift);
  26. $s=@spos.shift;
  27. if $s.slurpy or $s.capture {
  28. @spos=();
  29. @tpos=();
  30. last;
  31. }
  32. if $t.slurpy or $t.capture {
  33. return False unless any(@spos) ~~ {.slurpy or .capture};
  34. @spos=();
  35. @tpos=();
  36. last;
  37. }
  38. if not $s.optional {
  39. return False if $t.optional
  40. }
  41. return False unless $t ~~ $s;
  42. }
  43. return False if @tpos;
  44. if @spos {
  45. return False unless @spos[0].optional or @spos[0].slurpy or @spos[0].capture;
  46. }
  47. for flat ($sclass{True} // ()).grep({!.optional and !.slurpy}) -> $this {
  48. my $other;
  49. return False unless $other=($tclass{True} // ()).grep(
  50. {!.optional and $_ ~~ $this });
  51. return False unless +$other == 1;
  52. }
  53. my $here=($sclass{True}:v).SetHash;
  54. my $hasslurpy=($sclass{True} // ()).grep({.slurpy});
  55. $here{@$hasslurpy} :delete;
  56. $hasslurpy .= Bool;
  57. for flat @($tclass{True} // ()) -> $other {
  58. my $this;
  59. if $other.slurpy {
  60. return False if any($here.keys) ~~ -> Any $_ { !(.type =:= Mu) };
  61. return $hasslurpy;
  62. }
  63. if $this=$here.keys.grep( -> $t { $other ~~ $t }) {
  64. $here{$this[0]} :delete;
  65. }
  66. else {
  67. return False unless $hasslurpy;
  68. }
  69. }
  70. return False unless self.returns =:= $topic.returns;
  71. True;
  72. }
  73. method arity() {
  74. $!arity
  75. }
  76. method count() {
  77. $!count
  78. }
  79. method params() {
  80. nqp::p6bindattrinvres(nqp::create(List), List, '$!reified',
  81. nqp::clone(@!params));
  82. }
  83. method !gistperl(Signature:D: $perl, Mu:U :$elide-type = Mu,
  84. :&where = -> $ { 'where { ... }' } ) {
  85. # Opening.
  86. my $text = $perl ?? ':(' !! '(';
  87. # Parameters.
  88. if self.params.Array -> @params {
  89. $text ~= @params.shift.perl(:$elide-type) ~ ': '
  90. if @params[0].invocant;
  91. $text ~= ';; '
  92. if !@params[0].multi-invocant;
  93. my $sep = '';
  94. for @params.kv -> $i, $param {
  95. my $parmstr = $param.perl(:$elide-type, :&where);
  96. return Nil without $parmstr;
  97. $text ~= $sep ~ $parmstr;
  98. # Remove sigils from anon typed scalars, leaving type only
  99. $text .= subst(/ยป ' $'$/,'') unless $perl;
  100. $sep = $param.multi-invocant && !@params[$i+1].?multi-invocant
  101. ?? ';; '
  102. !! ', '
  103. }
  104. }
  105. if !nqp::isnull($!returns) && !($!returns =:= Mu) {
  106. $text = $text ~ ' --> ' ~ $!returns.perl
  107. }
  108. # Closer.
  109. $text ~ ')'
  110. }
  111. method !deftype(Signature:D:) {
  112. !nqp::isnull($!code) && $!code ~~ Routine ?? Any !! Mu
  113. }
  114. multi method perl(Signature:D:) {
  115. self!gistperl(True, :elide-type(self!deftype))
  116. }
  117. multi method gist(Signature:D:) {
  118. self!gistperl(False, :elide-type(self!deftype))
  119. }
  120. }
  121. multi sub infix:<eqv>(Signature:D \a, Signature:D \b) {
  122. # we're us
  123. return True if a =:= b;
  124. # different container type
  125. return False unless a.WHAT =:= b.WHAT;
  126. # arity or count mismatch
  127. return False if a.arity != b.arity || a.count != b.count;
  128. # different number of parameters or no parameters
  129. my $ap := nqp::getattr(a.params,List,'$!reified');
  130. my $bp := nqp::getattr(b.params,List,'$!reified');
  131. my int $elems = nqp::elems($ap);
  132. return False if nqp::isne_i($elems,nqp::elems($bp));
  133. return True unless $elems;
  134. # compare all positionals
  135. my int $i = -1;
  136. Nil
  137. while nqp::islt_i(++$i,$elems)
  138. && nqp::atpos($ap,$i) eqv nqp::atpos($bp,$i);
  139. # not all matching positionals
  140. if nqp::islt_i($i,$elems) {
  141. # not all same and different number of positionals
  142. return False
  143. if (!nqp::atpos($ap,$i).named || !nqp::atpos($bp,$i).named);
  144. # create lookup table
  145. my int $j = $i = $i - 1;
  146. my $lookup := nqp::hash;
  147. while nqp::islt_i(++$j,$elems) {
  148. my $p := nqp::atpos($ap,$j);
  149. my $nn := nqp::getattr($p,Parameter,'@!named_names');
  150. my str $key =
  151. nqp::isnull($nn) ?? '' !! nqp::elems($nn) ?? nqp::atpos_s($nn,0) !! '';
  152. die "Found named parameter '{
  153. nqp::chars($key) ?? $key !! '(unnamed)'
  154. }' twice in signature {a.perl}: {$p.perl} vs {nqp::atkey($lookup,$key).perl}"
  155. if nqp::existskey($lookup,$key);
  156. nqp::bindkey($lookup,$key,$p);
  157. }
  158. # named variable mismatch
  159. while nqp::islt_i(++$i,$elems) {
  160. my $p := nqp::atpos($bp,$i);
  161. my $nn := nqp::getattr($p,Parameter,'@!named_names');
  162. my str $key = nqp::defined($nn) && nqp::elems($nn)
  163. ?? nqp::atpos_s($nn,0)
  164. !! '';
  165. # named param doesn't exist in other or is not equivalent
  166. return False
  167. unless nqp::existskey($lookup,$key)
  168. && $p eqv nqp::atkey($lookup,$key);
  169. }
  170. }
  171. # it's a match
  172. True
  173. }
  174. Perl6::Metamodel::Configuration.set_multi_sig_comparator(
  175. -> \a, \b { a.signature eqv b.signature }
  176. );