1. ## miscellaneous operators can go here.
  2. ## generic numeric operators are in Numeric.pm6
  3. ## generic string operators are in Stringy.pm6
  4. ## Int/Rat/Num operators are in {Int|Rat|Num}.pm6
  5. # infix:<=> only exists to allow it to be referenced as an operator in
  6. # meta-operator usage. You cannot add other candidates for it. Therefore
  7. # it doesn't make sense to make it a multi.
  8. only sub infix:<=>(Mu \a, Mu \b) is raw {
  9. nqp::p6store(a, b)
  10. }
  11. my class X::Does::TypeObject is Exception {
  12. has Mu $.type;
  13. has %.nameds;
  14. method message() {
  15. "Cannot use 'does' operator on a type object {$!type.^name}."
  16. ~ ("\nAdditional named parameters: {%!nameds.perl}." if %!nameds)
  17. }
  18. }
  19. proto sub infix:<does>(|) {*}
  20. multi sub infix:<does>(Mu:D \obj, Mu:U \rolish) is raw {
  21. # XXX Mutability check.
  22. my $role := rolish.HOW.archetypes.composable() ?? rolish !!
  23. rolish.HOW.archetypes.composalizable() ?? rolish.HOW.composalize(rolish) !!
  24. X::Mixin::NotComposable.new(:target(obj), :rolish(rolish)).throw;
  25. obj.^mixin($role).BUILD_LEAST_DERIVED({});
  26. }
  27. multi sub infix:<does>(Mu:D \obj, Mu:U \rolish, :$value! is raw) is raw {
  28. # XXX Mutability check.
  29. my $role := rolish.HOW.archetypes.composable() ?? rolish !!
  30. rolish.HOW.archetypes.composalizable() ?? rolish.HOW.composalize(rolish) !!
  31. X::Mixin::NotComposable.new(:target(obj), :rolish(rolish)).throw;
  32. my \mixedin = obj.^mixin($role, :need-mixin-attribute);
  33. mixedin.BUILD_LEAST_DERIVED({ substr(mixedin.^mixin_attribute.Str,2) => $value });
  34. }
  35. multi sub infix:<does>(Mu:U \obj, Mu:U \role, *%_) is raw {
  36. X::Does::TypeObject.new(type => obj, nameds => %_).throw
  37. }
  38. multi sub infix:<does>(Mu:D \obj, **@roles) is raw {
  39. # XXX Mutability check.
  40. my \real-roles = eager @roles.map: -> \rolish {
  41. rolish.DEFINITE
  42. ?? GENERATE-ROLE-FROM-VALUE(rolish)
  43. !! rolish.HOW.archetypes.composable()
  44. ?? rolish
  45. !! rolish.HOW.archetypes.composalizable()
  46. ?? rolish.HOW.composalize(rolish)
  47. !! X::Mixin::NotComposable.new(:target(obj), :rolish(rolish)).throw
  48. }
  49. obj.^mixin(|real-roles).BUILD_LEAST_DERIVED({});
  50. }
  51. multi sub infix:<does>(Mu:U \obj, **@roles) is raw {
  52. X::Does::TypeObject.new(type => obj).throw
  53. }
  54. # we need this candidate tighter than infix:<cmp>(Real:D, Real:D)
  55. # but can't yet use `is default` at the place where that candidate
  56. # is defined because it uses `infix:<does>`
  57. multi sub infix:<cmp>(Rational:D \a, Rational:D \b) is default {
  58. a.isNaN || b.isNaN ?? a.Num cmp b.Num !! a <=> b
  59. }
  60. proto sub infix:<but>(|) is pure {*}
  61. multi sub infix:<but>(Mu:D \obj, Mu:U \rolish) {
  62. my $role := rolish.HOW.archetypes.composable() ?? rolish !!
  63. rolish.HOW.archetypes.composalizable() ?? rolish.HOW.composalize(rolish) !!
  64. X::Mixin::NotComposable.new(:target(obj), :rolish(rolish)).throw;
  65. obj.clone.^mixin($role).BUILD_LEAST_DERIVED({});
  66. }
  67. multi sub infix:<but>(Mu:D \obj, Mu:U \rolish, :$value! is raw) {
  68. my $role := rolish.HOW.archetypes.composable() ?? rolish !!
  69. rolish.HOW.archetypes.composalizable() ?? rolish.HOW.composalize(rolish) !!
  70. X::Mixin::NotComposable.new(:target(obj), :rolish(rolish)).throw;
  71. my \mixedin = obj.clone.^mixin($role, :need-mixin-attribute);
  72. my \attr = mixedin.^mixin_attribute;
  73. my $mixin-value := $value;
  74. unless nqp::istype($value, attr.type) {
  75. if attr.type.HOW.^name eq 'Perl6::Metamodel::EnumHOW' {
  76. $mixin-value := attr.type.($value);
  77. }
  78. }
  79. mixedin.BUILD_LEAST_DERIVED({ substr(attr.Str,2) => $mixin-value });
  80. }
  81. multi sub infix:<but>(Mu:U \obj, Mu:U \rolish) {
  82. my $role := rolish.HOW.archetypes.composable() ?? rolish !!
  83. rolish.HOW.archetypes.composalizable() ?? rolish.HOW.composalize(rolish) !!
  84. X::Mixin::NotComposable.new(:target(obj), :rolish(rolish)).throw;
  85. obj.^mixin($role);
  86. }
  87. sub GENERATE-ROLE-FROM-VALUE($val) {
  88. my $role := Metamodel::ParametricRoleHOW.new_type();
  89. my $meth := method () { $val };
  90. $meth.set_name($val.^name);
  91. $role.^add_method($meth.name, $meth);
  92. $role.^set_body_block(
  93. -> |c { nqp::list($role, nqp::hash('$?CLASS', c<$?CLASS>)) });
  94. $role.^compose;
  95. }
  96. multi sub infix:<but>(Mu \obj, Mu:D $val) is raw {
  97. obj.clone.^mixin(GENERATE-ROLE-FROM-VALUE($val));
  98. }
  99. multi sub infix:<but>(Mu:D \obj, **@roles) {
  100. my \real-roles := eager @roles.map: -> \rolish {
  101. rolish.DEFINITE ?? GENERATE-ROLE-FROM-VALUE(rolish) !!
  102. rolish.HOW.archetypes.composable() ?? rolish !!
  103. rolish.HOW.archetypes.composalizable() ?? rolish.HOW.composalize(rolish) !!
  104. X::Mixin::NotComposable.new(:target(obj), :rolish(rolish)).throw
  105. }
  106. obj.clone.^mixin(|real-roles).BUILD_LEAST_DERIVED({});
  107. }
  108. multi sub infix:<but>(Mu:U \obj, **@roles) {
  109. my \real-roles := eager @roles.map: -> \rolish {
  110. rolish.DEFINITE ?? GENERATE-ROLE-FROM-VALUE(rolish) !!
  111. rolish.HOW.archetypes.composable() ?? rolish !!
  112. rolish.HOW.archetypes.composalizable() ?? rolish.HOW.composalize(rolish) !!
  113. X::Mixin::NotComposable.new(:target(obj), :rolish(rolish)).throw
  114. }
  115. obj.^mixin(|real-roles)
  116. }
  117. sub SEQUENCE(\left, Mu \right, :$exclude_end) {
  118. my \righti := (nqp::iscont(right) ?? right !! [right]).iterator;
  119. my $endpoint := righti.pull-one.self; # .self explodes Failures
  120. $endpoint =:= IterationEnd and X::Cannot::Empty.new(
  121. :action('get sequence endpoint'),
  122. :what('list (use * or :!elems instead?)'),
  123. ).throw;
  124. my $infinite = nqp::istype($endpoint,Whatever) || $endpoint === Inf;
  125. $endpoint := False if $infinite;
  126. my $end_code_arity = 0;
  127. if nqp::istype($endpoint,Code) && !nqp::istype($endpoint,Regex) {
  128. $end_code_arity = $endpoint.arity;
  129. $end_code_arity = $endpoint.count if $end_code_arity == 0;
  130. $end_code_arity = -Inf if $end_code_arity == Inf;
  131. }
  132. my sub succpred($a,$b) {
  133. my $cmp = $a cmp $b;
  134. if $a.WHAT === $b.WHAT === $endpoint.WHAT {
  135. $cmp < 0 && $a ~~ Stringy
  136. ?? -> $x {
  137. my $new = $x.succ;
  138. last if $new after $endpoint
  139. or $new.chars > $endpoint.chars;
  140. $new;
  141. }
  142. !! $cmp < 0
  143. ?? -> $x {
  144. my $new = $x.succ;
  145. last if $new after $endpoint;
  146. $new;
  147. }
  148. !! $cmp > 0
  149. ?? -> $x {
  150. my $new = $x.pred;
  151. last if $x before $endpoint;
  152. $new;
  153. }
  154. !! { $_ }
  155. }
  156. else {
  157. $cmp < 0 ?? { $^x.succ }
  158. !! $cmp > 0 ?? { $^x.pred }
  159. !! { $^x }
  160. }
  161. }
  162. my sub unisuccpred($a,$b) {
  163. my $cmp = $a.ord cmp $b.ord;
  164. $cmp < 0 ?? { $^x.ord.succ.chr }
  165. !! $cmp > 0 ?? { $^x.ord.pred.chr }
  166. !! { $^x }
  167. }
  168. my \gathered = GATHER({
  169. my \lefti := left.iterator;
  170. my $value;
  171. my $code;
  172. my $stop;
  173. my $looped;
  174. my @tail;
  175. my @end_tail;
  176. while !((my \value := lefti.pull-one) =:= IterationEnd) {
  177. $looped = True;
  178. if nqp::istype(value,Code) { $code = value; last }
  179. if $end_code_arity != 0 {
  180. @end_tail.push(value);
  181. if +@end_tail >= $end_code_arity {
  182. @end_tail.shift xx (@end_tail.elems - $end_code_arity)
  183. unless $end_code_arity ~~ -Inf;
  184. if $endpoint(|@end_tail) {
  185. $stop = 1;
  186. @tail.push(value) unless $exclude_end;
  187. last;
  188. }
  189. }
  190. }
  191. elsif value ~~ $endpoint {
  192. $stop = 1;
  193. @tail.push(value) unless $exclude_end;
  194. last;
  195. }
  196. @tail.push(value);
  197. }
  198. X::Cannot::Empty.new(
  199. :action('get sequence start value'), :what('list')
  200. ).throw unless $looped;
  201. if $stop {
  202. take $_ for @tail;
  203. }
  204. else {
  205. my $badseq;
  206. my $a;
  207. my $b;
  208. my $c;
  209. unless $code.defined {
  210. take @tail.shift while @tail.elems > 3;
  211. $a = @tail[0];
  212. $b = @tail[1];
  213. $c = @tail[2];
  214. }
  215. if $code.defined { }
  216. elsif @tail.grep(Real).elems != @tail.elems {
  217. if @tail.elems > 1 {
  218. $code = @tail.tail.WHAT === $endpoint.WHAT
  219. ?? succpred(@tail.tail, $endpoint)
  220. !! succpred(@tail[*-2], @tail.tail);
  221. }
  222. elsif nqp::istype($endpoint, Stringy)
  223. and nqp::istype($a, Stringy)
  224. and nqp::isconcrete($endpoint) {
  225. if $a.codes == 1 && $endpoint.codes == 1 {
  226. $code = unisuccpred($a, $endpoint);
  227. }
  228. elsif $a.codes == $endpoint.codes {
  229. my @a = $a.comb;
  230. my @e = $endpoint.comb;
  231. my @ranges;
  232. for flat @a Z @e -> $from, $to {
  233. @ranges.push: $($from ... $to);
  234. }
  235. .take for flat [X~] @ranges;
  236. $stop = 1;
  237. }
  238. elsif $a lt $endpoint {
  239. $stop = 1 if $a gt $endpoint;
  240. $code = -> $x {
  241. my $new = $x.succ;
  242. last if $new gt $endpoint
  243. or $new.chars > $endpoint.chars;
  244. $new;
  245. }
  246. }
  247. else {
  248. $stop = 1 if $a lt $endpoint;
  249. $code = -> $x {
  250. my $new = $x.pred;
  251. last if $new lt $endpoint;
  252. $new;
  253. }
  254. }
  255. }
  256. elsif $infinite or nqp::istype($endpoint, Code) {
  257. $code = *.succ;
  258. }
  259. else {
  260. $code = succpred($a,$endpoint);
  261. }
  262. }
  263. elsif @tail.elems == 3 {
  264. my $ab = $b - $a;
  265. if $ab == $c - $b {
  266. if $ab != 0
  267. || nqp::istype($a,Real)
  268. && nqp::istype($b,Real)
  269. && nqp::istype($c,Real) {
  270. if nqp::istype($endpoint, Real)
  271. and not nqp::istype($endpoint, Bool)
  272. and nqp::isconcrete($endpoint) {
  273. if $ab > 0 {
  274. $stop = 1 if $a > $endpoint;
  275. $code = -> $x {
  276. my $new = $x + $ab;
  277. last if $new > $endpoint;
  278. $new;
  279. }
  280. }
  281. else {
  282. $stop = 1 if $a < $endpoint;
  283. $code = -> $x {
  284. my $new = $x + $ab;
  285. last if $new < $endpoint;
  286. $new;
  287. }
  288. }
  289. }
  290. else {
  291. $code = { $^x + $ab }
  292. }
  293. }
  294. else {
  295. $code = succpred($b, $c)
  296. }
  297. }
  298. elsif $a != 0 && $b != 0 && $c != 0 {
  299. $ab = $b / $a;
  300. if $ab == $c / $b {
  301. # XXX TODO: this code likely has a 2 bugs:
  302. # 1) It should check Rational, not just Rat
  303. # 2) Currently Rats aren't guaranteed to be always
  304. # normalized, so denominator might not be 1, even if
  305. # it could be, if normalized
  306. $ab = $ab.Int
  307. if nqp::istype($ab, Rat) && $ab.denominator == 1;
  308. if nqp::istype($endpoint, Real)
  309. and not nqp::istype($endpoint, Bool)
  310. and nqp::isconcrete($endpoint) {
  311. if $ab > 0 {
  312. if $ab > 1 {
  313. $stop = 1 if $a > $endpoint;
  314. $code = -> $x {
  315. my $new = $x * $ab;
  316. last if $new > $endpoint;
  317. $new;
  318. }
  319. }
  320. else {
  321. $stop = 1 if $a < $endpoint;
  322. $code = -> $x {
  323. my $new = $x * $ab;
  324. last if $new < $endpoint;
  325. $new;
  326. }
  327. }
  328. }
  329. else {
  330. $code = -> $x {
  331. my $new = $x * $ab;
  332. my $absend = $endpoint.abs;
  333. last if sign( $x.abs - $absend)
  334. == -sign($new.abs - $absend);
  335. $new;
  336. }
  337. }
  338. }
  339. else {
  340. $code = { $^x * $ab }
  341. }
  342. }
  343. }
  344. if $code {
  345. @tail.pop;
  346. @tail.pop;
  347. }
  348. else {
  349. $badseq = "$a,$b,$c" unless $code;
  350. }
  351. }
  352. elsif @tail.elems == 2 {
  353. my $ab = $b - $a;
  354. if $ab != 0 || nqp::istype($a,Real) && nqp::istype($b,Real) {
  355. if nqp::istype($endpoint, Real)
  356. and not nqp::istype($endpoint, Bool)
  357. and nqp::isconcrete($endpoint) {
  358. if $ab > 0 {
  359. $stop = 1 if $a > $endpoint;
  360. $code = -> $x {
  361. my $new = $x + $ab;
  362. last if $new > $endpoint;
  363. $new;
  364. }
  365. }
  366. else {
  367. $stop = 1 if $a < $endpoint;
  368. $code = -> $x {
  369. my $new = $x + $ab;
  370. last if $new < $endpoint;
  371. $new;
  372. }
  373. }
  374. }
  375. else {
  376. $code = { $^x + $ab }
  377. }
  378. }
  379. else {
  380. $code = succpred($a, $b)
  381. }
  382. @tail.pop;
  383. }
  384. elsif @tail.elems == 1 {
  385. if nqp::istype($endpoint,Code)
  386. or not nqp::isconcrete($endpoint) {
  387. $code = { $^x.succ }
  388. }
  389. elsif nqp::istype($endpoint, Real)
  390. and not nqp::istype($endpoint, Bool)
  391. and nqp::istype($a, Real) {
  392. if $a < $endpoint {
  393. $code = -> $x {
  394. my $new = $x.succ;
  395. last if $new > $endpoint;
  396. $new;
  397. }
  398. }
  399. else {
  400. $code = -> $x {
  401. my $new = $x.pred;
  402. last if $new < $endpoint;
  403. $new;
  404. }
  405. }
  406. }
  407. else {
  408. $code = { $^x.succ }
  409. }
  410. }
  411. elsif @tail.elems == 0 {
  412. $code = {()}
  413. }
  414. if $stop { }
  415. elsif $code.defined {
  416. .take for @tail;
  417. my $count = $code.count;
  418. until $stop {
  419. @tail.shift while @tail.elems > $count;
  420. my \value = $code(|@tail);
  421. if $end_code_arity != 0 {
  422. @end_tail.push(value);
  423. if @end_tail.elems >= $end_code_arity {
  424. @end_tail.shift xx (
  425. @end_tail.elems - $end_code_arity
  426. ) unless $end_code_arity == -Inf;
  427. if $endpoint(|@end_tail) {
  428. value.take unless $exclude_end;
  429. $stop = 1;
  430. }
  431. }
  432. }
  433. elsif value ~~ $endpoint {
  434. value.take unless $exclude_end;
  435. $stop = 1;
  436. }
  437. if $stop { }
  438. else {
  439. @tail.push(value);
  440. value.take;
  441. }
  442. }
  443. }
  444. elsif $badseq {
  445. die X::Sequence::Deduction.new(:from($badseq));
  446. }
  447. else {
  448. die X::Sequence::Deduction.new;
  449. }
  450. }
  451. });
  452. $infinite
  453. ?? (gathered.Slip, Slip.from-iterator(righti)).lazy
  454. !! (gathered.Slip, Slip.from-iterator(righti))
  455. }
  456. # XXX Wants to be macros when we have them.
  457. only sub WHAT(Mu \x) { x.WHAT }
  458. only sub HOW (Mu \x) { x.HOW }
  459. only sub VAR (Mu \x) { x.VAR }
  460. proto sub infix:<...>(|) {*}
  461. multi sub infix:<...>(\a, Mu \b) { Seq.new(SEQUENCE(a, b).iterator) }
  462. multi sub infix:<...>(|lol) {
  463. my @lol := lol.list;
  464. my @end;
  465. my @seq;
  466. my @excl;
  467. my $ret := ();
  468. my int $i = 0;
  469. my int $m = +@lol - 1;
  470. while $i <= $m {
  471. @seq[$i] := @lol[$i].iterator;
  472. if $i {
  473. @end[$i-1] := @seq[$i].pull-one;
  474. if @end[$i-1] ~~ Numeric | Stringy {
  475. @seq[$i] := @lol[$i].iterator;
  476. @excl[$i-1] = True;
  477. }
  478. }
  479. ++$i;
  480. }
  481. $i = 0;
  482. while $i < $m {
  483. $ret := ($ret.Slip,
  484. SEQUENCE(
  485. (Slip.from-iterator(@seq[$i]),),
  486. @end[$i],
  487. :exclude_end(so @excl[$i])
  488. ).Slip
  489. );
  490. ++$i;
  491. }
  492. if @seq[$m] =:= Empty {
  493. Seq.new($ret.iterator);
  494. }
  495. else {
  496. Seq.new(($ret.Slip, Slip.from-iterator(@seq[$m])).iterator);
  497. }
  498. }
  499. proto sub infix:<...^>(|) {*}
  500. multi sub infix:<...^>(\a, Mu \b) { Seq.new(SEQUENCE(a, b, :exclude_end(1)).iterator) }
  501. proto sub infix:<…>(|) {*}
  502. multi sub infix:<…>(|c) { infix:<...>(|c) }
  503. proto sub infix:<…^>(|) {*}
  504. multi sub infix:<…^>(|c) { infix:<...^>(|c) }
  505. multi sub undefine(Mu \x) is raw { x = Nil }
  506. multi sub undefine(Array \x) is raw { x = Empty }
  507. multi sub undefine(Hash \x) is raw { x = Empty }
  508. sub prefix:<temp>(Mu \cont) is raw {
  509. Rakudo::Internals.TEMP-LET(nqp::getlexcaller('!TEMP-RESTORE'),cont,'temp')
  510. }
  511. sub prefix:<let>(Mu \cont) is raw {
  512. Rakudo::Internals.TEMP-LET(nqp::getlexcaller('!LET-RESTORE'),cont,'let')
  513. }
  514. # this implements the ::() indirect lookup
  515. sub INDIRECT_NAME_LOOKUP($root, *@chunks) is raw {
  516. nqp::if(
  517. # Note that each part of @chunks itself can contain double colons.
  518. # That's why joining and re-splitting is necessary
  519. (my str $name = @chunks.join('::')),
  520. nqp::stmts(
  521. (my $parts := nqp::split('::',$name)),
  522. (my str $first = nqp::shift($parts)),
  523. nqp::if( # move the sigil to the last part of the name if available
  524. nqp::elems($parts),
  525. nqp::stmts(
  526. (my str $sigil = nqp::substr($first,0,1)),
  527. nqp::if(
  528. nqp::iseq_s($sigil,'$')
  529. || nqp::iseq_s($sigil,'@')
  530. || nqp::iseq_s($sigil,'%')
  531. || nqp::iseq_s($sigil,'&'),
  532. nqp::stmts(
  533. nqp::push($parts,nqp::concat($sigil,nqp::pop($parts))),
  534. ($first = nqp::substr($first,1))
  535. )
  536. ),
  537. nqp::unless(
  538. $first,
  539. nqp::stmts(
  540. ($first = nqp::shift($parts)),
  541. ($name = nqp::join("::",$parts)),
  542. )
  543. )
  544. )
  545. ),
  546. (my Mu $thing := nqp::if(
  547. $root.EXISTS-KEY('%REQUIRE_SYMBOLS')
  548. && (my $REQUIRE_SYMBOLS := $root.AT-KEY('%REQUIRE_SYMBOLS'))
  549. && $REQUIRE_SYMBOLS.EXISTS-KEY($first),
  550. $REQUIRE_SYMBOLS.AT-KEY($first),
  551. nqp::if(
  552. $root.EXISTS-KEY($first),
  553. $root.AT-KEY($first),
  554. nqp::if(
  555. GLOBAL::.EXISTS-KEY($first),
  556. GLOBAL::.AT-KEY($first),
  557. nqp::if(
  558. nqp::iseq_s($first,'GLOBAL'),
  559. GLOBAL,
  560. X::NoSuchSymbol.new(symbol => $name).fail
  561. )
  562. )
  563. )
  564. )),
  565. nqp::while(
  566. nqp::elems($parts),
  567. nqp::if(
  568. $thing.WHO.EXISTS-KEY(my $part := nqp::shift($parts)),
  569. ($thing := $thing.WHO.AT-KEY($part)),
  570. X::NoSuchSymbol.new(symbol => $name).fail
  571. )
  572. ),
  573. $thing
  574. ),
  575. Failure.new(X::NoSuchSymbol.new(symbol => ""))
  576. )
  577. }
  578. sub REQUIRE_IMPORT($compunit, $existing-path,$top-existing-pkg,$stubname, *@syms --> Nil) {
  579. my $handle := $compunit.handle;
  580. my $DEFAULT := $handle.export-package()<DEFAULT>.WHO;
  581. my $GLOBALish := $handle.globalish-package;
  582. my @missing;
  583. my $block := CALLER::.EXISTS-KEY('%REQUIRE_SYMBOLS')
  584. ?? CALLER::MY::
  585. !! CALLER::OUTER::;
  586. my $targetWHO;
  587. my $sourceWHO;
  588. if $existing-path {
  589. my @existing-path = @$existing-path;
  590. my $topname := @existing-path.shift;
  591. $targetWHO := $top-existing-pkg.WHO;
  592. $sourceWHO := $GLOBALish.AT-KEY($topname).WHO;
  593. # Yes! the target CAN be the source if it's something like Cool::Utils
  594. # because Cool is common to both compunits..so no need to do anything
  595. unless $targetWHO === $sourceWHO {
  596. # We want to skip over the parts of the Package::That::Already::Existed
  597. for @existing-path {
  598. $targetWHO := $targetWHO.AT-KEY($_).WHO;
  599. $sourceWHO := $sourceWHO.AT-KEY($_).WHO;
  600. }
  601. # Now we are just above our target stub. If it exists
  602. # delete it so it can be replaced by the real one we're importing.
  603. if $stubname {
  604. $targetWHO.DELETE-KEY($stubname);
  605. }
  606. $targetWHO.merge-symbols($sourceWHO);
  607. }
  608. } elsif $stubname {
  609. $targetWHO := $block.AT-KEY($stubname).WHO;
  610. $sourceWHO := $GLOBALish.AT-KEY($stubname).WHO;
  611. $targetWHO.merge-symbols($sourceWHO);
  612. }
  613. # Set the runtime values for compile time stub symbols
  614. for @syms {
  615. unless $DEFAULT.EXISTS-KEY($_) {
  616. @missing.push: $_;
  617. next;
  618. }
  619. $block{$_} := $DEFAULT{$_};
  620. }
  621. if @missing {
  622. X::Import::MissingSymbols.new(:from($compunit.short-name), :@missing).throw;
  623. }
  624. # Merge GLOBAL from compunit.
  625. nqp::gethllsym('perl6','ModuleLoader').merge_globals(
  626. $block<%REQUIRE_SYMBOLS>,
  627. $GLOBALish,
  628. );
  629. }
  630. proto sub infix:<andthen>(|) {*}
  631. multi sub infix:<andthen>(+a) {
  632. # We need to be able to process `Empty` in our args, which we can get
  633. # when we're chained with, say, `andthen`. Since Empty disappears in normal
  634. # arg handling, we use nqp::p6argvmarray op to fetch the args, and then
  635. # emulate the `+@foo` slurpy by inspecting the list the op gave us.
  636. nqp::if(
  637. (my int $els = nqp::elems(my $args := nqp::p6argvmarray)),
  638. nqp::stmts(
  639. (my $current := nqp::atpos($args, 0)),
  640. nqp::if( # emulate the +@foo slurpy
  641. nqp::iseq_i($els, 1) && nqp::istype($current, Iterable),
  642. nqp::stmts(
  643. ($args := $current.List),
  644. ($current := $args[0]),
  645. $els = $args.elems)),
  646. (my int $i),
  647. nqp::until(
  648. nqp::iseq_i($els, $i = nqp::add_i($i, 1))
  649. || ( # if $current not defined, set it to Empty and bail from the loop
  650. nqp::isfalse($current.defined)
  651. && nqp::stmts(($current := Empty), 1)
  652. ),
  653. ($current := nqp::if(
  654. nqp::istype(($_ := $args[$i]), Callable),
  655. nqp::if(.count, $_($current), $_()),
  656. $_)),
  657. :nohandler), # do not handle control stuff in thunks
  658. $current), # either the last arg or Empty if any but last were undefined
  659. True) # We were given no args, return True
  660. }
  661. proto sub infix:<notandthen>(|) {*}
  662. multi sub infix:<notandthen>(+a) {
  663. # We need to be able to process `Empty` in our args, which we can get
  664. # when we're chained with, say, `andthen`. Since Empty disappears in normal
  665. # arg handling, we use nqp::p6argvmarray op to fetch the args, and then
  666. # emulate the `+@foo` slurpy by inspecting the list the op gave us.
  667. nqp::if(
  668. (my int $els = nqp::elems(my $args := nqp::p6argvmarray)),
  669. nqp::stmts(
  670. (my $current := nqp::atpos($args, 0)),
  671. nqp::if( # emulate the +@foo slurpy
  672. nqp::iseq_i($els, 1) && nqp::istype($current, Iterable),
  673. nqp::stmts(
  674. ($args := $current.List),
  675. ($current := $args[0]),
  676. $els = $args.elems)),
  677. (my int $i),
  678. nqp::until(
  679. nqp::iseq_i($els, $i = nqp::add_i($i, 1))
  680. || ( # if $current is defined, set it to Empty and bail from the loop
  681. $current.defined
  682. && nqp::stmts(($current := Empty), 1)
  683. ),
  684. ($current := nqp::if(
  685. nqp::istype(($_ := $args[$i]), Callable),
  686. nqp::if(.count, $_($current), $_()),
  687. $_)),
  688. :nohandler), # do not handle control stuff in thunks
  689. $current), # either the last arg or Empty if any but last were undefined
  690. True) # We were given no args, return True
  691. }
  692. proto sub infix:<orelse>(|) {*}
  693. multi sub infix:<orelse>(+$) {
  694. # We need to be able to process `Empty` in our args, which we can get
  695. # when we're chained with, say, `andthen`. Since Empty disappears in normal
  696. # arg handling, we use nqp::p6argvmarray op to fetch the args, and then
  697. # emulate the `+@foo` slurpy by inspecting the list the op gave us.
  698. nqp::if(
  699. (my int $els = nqp::elems(my $args := nqp::p6argvmarray)),
  700. nqp::stmts(
  701. (my $current := nqp::atpos($args, 0)),
  702. nqp::if( # emulate the +@foo slurpy
  703. nqp::iseq_i($els, 1) && nqp::istype($current, Iterable),
  704. nqp::stmts(
  705. ($args := $current.List),
  706. ($current := $args[0]),
  707. $els = $args.elems)),
  708. (my int $i),
  709. nqp::until(
  710. nqp::iseq_i($els, $i = nqp::add_i($i, 1)) || $current.defined,
  711. ($current := nqp::if(
  712. nqp::istype(($_ := $args[$i]), Callable),
  713. nqp::if(.count, $_($current), $_()),
  714. $_)),
  715. :nohandler), # do not handle control stuff in thunks
  716. $current),
  717. Nil) # We were given no args, return Nil
  718. }
  719. # next three sub would belong to traits.pm6 if PseudoStash were available
  720. # so early in the setting compunit
  721. multi sub trait_mod:<is>(Routine $r, Str :$equiv!) {
  722. if (my $i = nqp::index($r.name, ':')) > 0 {
  723. my \nm ='&' ~ nqp::substr($r.name, 0, $i+1) ~ '<' ~ nqp::escape($equiv) ~ '>';
  724. trait_mod:<is>($r, equiv => ::(nm));
  725. return;
  726. }
  727. die "Routine given to equiv does not appear to be an operator";
  728. }
  729. multi sub trait_mod:<is>(Routine $r, Str :$tighter!) {
  730. if (my $i = nqp::index($r.name, ':')) > 0 {
  731. my \nm ='&' ~ nqp::substr($r.name, 0, $i+1) ~ '<' ~ nqp::escape($tighter) ~ '>';
  732. trait_mod:<is>($r, tighter => ::(nm));
  733. return;
  734. }
  735. die "Routine given to tighter does not appear to be an operator";
  736. }
  737. multi sub trait_mod:<is>(Routine $r, Str :$looser!) {
  738. if (my $i = nqp::index($r.name, ':')) > 0 {
  739. my \nm ='&' ~ nqp::substr($r.name, 0, $i+1) ~ '<' ~ nqp::escape($looser) ~ '>';
  740. trait_mod:<is>($r, looser => ::(nm));
  741. return;
  742. }
  743. die "Routine given to looser does not appear to be an operator";
  744. }
  745. proto sub infix:<o> (&?, &?) {*}
  746. multi sub infix:<o> () { -> \v { v } }
  747. multi sub infix:<o> (&f) { &f }
  748. multi sub infix:<o> (&f, &g --> Block:D) {
  749. my \ret = &f.count > 1
  750. ?? -> |args { f |g |args }
  751. !! -> |args { f g |args }
  752. my role FakeSignature[$arity, $count, $of] {
  753. method arity { $arity }
  754. method count { $count }
  755. method of { $of }
  756. }
  757. ret.^mixin(FakeSignature[&g.arity, &g.count, &f.of]);
  758. ret
  759. }
  760. # U+2218 RING OPERATOR
  761. my constant &infix:<∘> := &infix:<o>;