1. my class Block { # declared in BOOTSTRAP
  2. # class Block is Code
  3. # has Mu $!phasers;
  4. # has Mu $!why;
  5. method of(Block:D:) { nqp::getattr(self,Code,'$!signature').returns }
  6. method returns(Block:D:) { nqp::getattr(self,Code,'$!signature').returns }
  7. method add_phaser(Str:D \name, &block --> Nil) {
  8. $!phasers := nqp::hash
  9. unless nqp::attrinited(self,Block,'$!phasers');
  10. my str $name = name;
  11. nqp::bindkey($!phasers,$name,nqp::create(IterationBuffer))
  12. unless nqp::existskey($!phasers,$name);
  13. if nqp::iseq_s($name,'LEAVE') || nqp::iseq_s($name,'KEEP') || nqp::iseq_s($name,'UNDO') {
  14. nqp::unshift(nqp::atkey($!phasers,$name),&block);
  15. self.add_phaser('!LEAVE-ORDER', &block);
  16. }
  17. elsif nqp::iseq_s($name,'NEXT') || nqp::iseq_s($name,'!LEAVE-ORDER') || nqp::iseq_s($name,'POST') {
  18. nqp::unshift(nqp::atkey($!phasers,$name),&block);
  19. }
  20. else {
  21. nqp::push(nqp::atkey($!phasers,$name),&block);
  22. }
  23. }
  24. method fire_if_phasers(Str $name --> Nil) {
  25. nqp::if(
  26. nqp::attrinited(self,Block,'$!phasers')
  27. && nqp::existskey($!phasers,$name),
  28. nqp::stmts(
  29. (my $iter := nqp::iterator(nqp::atkey($!phasers,$name))),
  30. nqp::while($iter,nqp::shift($iter)(),:nohandler)
  31. )
  32. )
  33. }
  34. method fire_phasers(Str $name --> Nil) {
  35. nqp::stmts(
  36. (my $iter := nqp::iterator(nqp::atkey($!phasers,$name))),
  37. nqp::while($iter,nqp::shift($iter)(),:nohandler)
  38. )
  39. }
  40. method has-phasers() { nqp::attrinited(self,Block,'$!phasers') }
  41. method has-phaser(Str:D \name) {
  42. nqp::attrinited(self,Block,'$!phasers')
  43. && nqp::existskey($!phasers,nqp::unbox_s(name))
  44. }
  45. method phasers(Str:D $name) {
  46. nqp::attrinited(self,Block,'$!phasers')
  47. && nqp::existskey($!phasers,nqp::unbox_s($name))
  48. ?? nqp::p6bindattrinvres(nqp::create(List),List,'$!reified',
  49. nqp::atkey($!phasers,nqp::unbox_s($name)))
  50. !! ()
  51. }
  52. method assuming(Block:D $self: |primers) {
  53. my $sig = nqp::getattr(nqp::decont($self), Code, '$!signature');
  54. # A ::() that does not throw. Also does not need to deal
  55. # with chunks or sigils.
  56. my sub soft_indirect_name_lookup($name) {
  57. my @parts = $name.split('::');
  58. my Mu $thing := ::.EXISTS-KEY(@parts[0]);
  59. return False unless $thing;
  60. $thing := ::.AT-KEY(@parts.shift);
  61. for @parts {
  62. return False unless $thing.WHO.EXISTS-KEY($_);
  63. $thing := $thing.WHO{$_};
  64. }
  65. True;
  66. }
  67. # sub strip-parm
  68. # This is mostly a stripped-down version of Parameter.perl, removing
  69. # where clauses, turning "= { ... }" from defaults into just
  70. # "?", removing type captures, subsignatures, and undeclared types
  71. # (e.g. types set to or parameterized by captured types.)
  72. my sub strip_parm (Parameter:D $parm, :$make_optional = False) {
  73. my $type = $parm.type.^name;
  74. my $perl = $type;
  75. my $rest = '';
  76. my $sigil = $parm.sigil;
  77. my $elide_agg_cont= so ($sigil eqv '@'
  78. or $sigil eqv '%'
  79. or $type ~~ /^^ Callable >> /);
  80. $perl = '' if $elide_agg_cont;
  81. unless $type eq "Any" {
  82. my int $FIRST = 1; # broken FIRST workaround
  83. while ($type ~~ / (.*?) \[ (.*) \] $$/) {
  84. # FIRST { # seems broken in setting
  85. if $FIRST { # broken FIRST workaround
  86. $perl = $elide_agg_cont
  87. ?? ~$1
  88. !! ~$/;
  89. $FIRST = 0;
  90. }
  91. $type = ~$1;
  92. unless soft_indirect_name_lookup(~$0) {
  93. $perl = '';
  94. last
  95. };
  96. }
  97. $perl = '' unless soft_indirect_name_lookup($type);
  98. }
  99. $perl ~= $parm.modifier if $perl ne '';
  100. my $name = $parm.name;
  101. if !$name and $parm.raw {
  102. $name = '$';
  103. } elsif !$name or !$name.starts-with($sigil) {
  104. $name = $sigil ~ $parm.twigil ~ ($name // '');
  105. }
  106. if $parm.slurpy {
  107. $name = '*' ~ $name;
  108. } elsif $parm.named {
  109. my @names := $parm.named_names;
  110. $name = ':' ~ $_ ~ '(' ~ $name ~ ')'for @names;
  111. $name ~= '!' unless ($parm.optional or $make_optional);
  112. $name ~= '?' if ($make_optional);
  113. } elsif $parm.optional or $parm.default {
  114. $name ~= '?';
  115. }
  116. if $parm.rw {
  117. $rest ~= ' is rw';
  118. } elsif $parm.copy {
  119. $rest ~= ' is copy';
  120. }
  121. if $parm.raw {
  122. $rest ~= ' is raw' unless $name.starts-with('\\');
  123. }
  124. if $name or $rest {
  125. $perl ~= ($perl ?? ' ' !! '') ~ $name;
  126. }
  127. $perl ~ $rest;
  128. }
  129. # If we have only one parameter and it is a capture with a
  130. # subsignature, we might as will jump down into it.
  131. while +$sig.params == 1
  132. and $sig.params[0].capture
  133. and $sig.params[0].sub_signature {
  134. $sig = $sig.params[0].sub_signature;
  135. }
  136. my @plist = (); # Positionals in the returned closure's signature
  137. my @clist = (); # The positional args used to call the original code
  138. my @tlist = (); # Positional params to verify binding primers against
  139. my @alist = (); # Primers as positional arguments after processing
  140. # Find a name safe to use across slurpies, captures and sigilless
  141. my $safename = '_';
  142. $safename ~= '_' while $sig.params.first:
  143. { $_.name.defined and $_.name eq $safename and
  144. ($_.slurpy or $_.sigil eq '\\' or $_.sigil eq '|') };
  145. my $capwrap = $safename ~ '_';
  146. $capwrap ~= '_' while $sig.params.first:
  147. { $_.name.defined and $_.name eq $capwrap and
  148. ($_.slurpy or $_.sigil eq '\\' or $_.sigil eq '|') };
  149. # Look for slurpies and captures
  150. my $slurp_p = $sig.params.first: {.slurpy and .sigil eq '@'};
  151. my $slurp_n = $sig.params.first: {.slurpy and .sigil eq '%'};
  152. $slurp_p //= ();
  153. $slurp_n //= ();
  154. # This gets sticky. A bare capture will take anything
  155. # you throw at it. A capture with a subsignature, not always.
  156. # Both will raise Signature.count to Inf, unfortunately,
  157. # and neither counts towards Signature.arity. That might
  158. # eventually change as it is LTA.
  159. #
  160. # We have no real use for any captures defined in the original
  161. # signature, but if there is one, we must emulate its slurpylike
  162. # effects. We cannot tell if it actually has slurpylike
  163. # effects without looking at subsignatures, recursively,
  164. # but really Signature should be able to tell us that.
  165. #
  166. # Until then, we will add slurpy behaviors, assuming we
  167. # do not already have them, if we see a capture.
  168. my $need_cap = ($sig.count == Inf and not ($slurp_p and $slurp_n));
  169. if $need_cap {
  170. $need_cap = False;
  171. for $sig.params.grep(*.capture) {
  172. $need_cap = True;
  173. last;
  174. }
  175. }
  176. # For now this is how we fabricate parameters.
  177. my &safeparms = EVAL
  178. sprintf('sub (|%s) { }', $safename);
  179. if ($need_cap) {
  180. $slurp_p ||= &safeparms.signature.params[0];
  181. $slurp_n ||= &safeparms.signature.params[0];
  182. }
  183. # Normal Positionals
  184. my Int $idx = -1;
  185. for $sig.params.grep(*.positional) -> $parm {
  186. $idx++;
  187. unless $idx < primers.list.elems {
  188. @plist.push($parm);
  189. @clist.push($capwrap ~ '[' ~ @plist.end ~ ']');
  190. next;
  191. }
  192. given primers.list[$idx] {
  193. when Whatever { @plist.push($parm);
  194. @clist.push($capwrap ~ '[' ~ @plist.end ~ ']');
  195. }
  196. when Nil { @alist.push($parm.type);
  197. @clist.push($parm.type.^name);
  198. @tlist.push($parm);
  199. }
  200. default { @alist.push($_);
  201. @clist.push("primers.list[$idx]");
  202. @tlist.push($parm);
  203. }
  204. }
  205. }
  206. my $widx = @plist.end;
  207. @tlist.push($slurp_p) if $slurp_p;
  208. @plist.push($slurp_p) if $slurp_p and not $slurp_p.capture;
  209. $idx++;
  210. my $cidx = 0;
  211. # Even if we prime above the arity, do it anyway, for errors.
  212. while ($idx < primers.list.elems) {
  213. given primers.list[$idx] {
  214. when Whatever {
  215. @clist.push($capwrap ~ '[' ~ ++$widx ~ ']');
  216. }
  217. when Nil {
  218. my $t = "Any";
  219. if $slurp_p {
  220. unless $slurp_p.capture {
  221. $t = $slurp_p.type.of.^name
  222. }
  223. }
  224. @alist.push($t);
  225. @clist.push($t);
  226. }
  227. default {
  228. @alist.push($_);
  229. @clist.push("primers.list[$idx]");
  230. }
  231. }
  232. $idx++;
  233. }
  234. if $slurp_p {
  235. @clist.push('|' ~ $capwrap ~ '[' ~ ++$widx ~ '..*-1]' );
  236. # If it is a true slurpy we already pushed it to $plist
  237. $slurp_p = () unless $slurp_p.capture;
  238. }
  239. # Normal Nameds.
  240. # I noted this:
  241. # perl6 -e 'sub a (*%A, :$a?, *%B) { %A.say; %B.say }; a(:a(1));'
  242. # {:a(1)}<>
  243. # {}<>
  244. # I am going to treat that as a feature and preserve the behavior.
  245. # So we will care for ordering of the named parameters in the
  246. # user-facing signature as well, for introspection purposes.
  247. my %ahash = primers.hash;
  248. my @phash = $sig.params.grep: *.named;
  249. my @thash = $sig.params.grep: {
  250. .named and (
  251. .slurpy or
  252. any(%ahash.keys) eq any(.named_names.list)
  253. )
  254. }
  255. @phash .= map: {
  256. my @names = .named_names.list;
  257. my $p = strip_parm($_);
  258. if not .optional and any(%ahash.keys) eq any(@names) {
  259. # Make mandatory parameters optional once they have
  260. # been supplied at least once.
  261. $p = strip_parm($_, :make_optional);
  262. }
  263. $p;
  264. }
  265. if ($slurp_n and $slurp_n.capture and !($slurp_n === $slurp_p)) {
  266. @phash.push(strip_parm($slurp_n));
  267. }
  268. my $error = False;
  269. EVAL(sprintf('anon sub trybind (%s) { }(|@alist, |%%ahash);',
  270. (flat @tlist.map(&strip_parm),
  271. @thash.map(&strip_parm)).join(", "))
  272. );
  273. my $f;
  274. my $primed_sig = (flat @plist.map(&strip_parm), @phash,
  275. ($slurp_p ?? strip_parm($slurp_p) !! ())).join(", ");
  276. $primed_sig ~= ' --> ' ~ $sig.returns.^name;
  277. $f = EVAL sprintf(
  278. '{ my $res = (my proto __PRIMED_ANON (%s) { {*} });
  279. my multi __PRIMED_ANON (|%s(%s)) {
  280. my %%chash := %s.hash;
  281. $self(%s%s |{ %%ahash, %%chash }); # |{} workaround RT#77788
  282. };
  283. $res }()',
  284. $primed_sig, $capwrap, $primed_sig, $capwrap,
  285. (flat @clist).join(", "),
  286. (@clist ?? ',' !! '')
  287. );
  288. $error ~~ Exception ?? $f but Failure.new($error) !! $f;
  289. }
  290. multi method perl(Block:D:) {
  291. "-> {self.signature.perl.substr(2,*-1)} \{ #`({self.WHICH}) ... \}"
  292. }
  293. method WHY() {
  294. if nqp::isnull($!why) {
  295. Nil
  296. } else {
  297. $!why.set_docee(self);
  298. $!why
  299. }
  300. }
  301. method set_why($why --> Nil) {
  302. $!why := $why;
  303. }
  304. # helper method for array slicing
  305. method pos(Block:D $self: \list) {
  306. nqp::if(
  307. (nqp::istype(
  308. (my $n := nqp::getattr(
  309. nqp::getattr($self,Code,'$!signature'),Signature,'$!count')
  310. ),Num) && nqp::isnanorinf($n)) || nqp::iseq_i(nqp::unbox_i($n),1),
  311. $self(nqp::if(nqp::isconcrete(list),list.elems,0)),
  312. $self(|(nqp::if(nqp::isconcrete(list),list.elems,0) xx $n))
  313. )
  314. }
  315. }