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