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